Various changes to make it compile with MicroHs (#1043)

* Mostly #ifdefs and some type signatures.
* Add CI for MicroHs compilation.

.github/workflows/mhs-ci.yml

@@ -0,0 +1,32 @@
+name: MicroHs CI for containers
+
+on:
+  push:
+    branches: [ "master" ]
+  pull_request:
+    branches: [ "master" ]
+
+jobs:
+  build-mhs-containers:
+    runs-on: ubuntu-latest
+    steps:
+    - name: checkout containers repo
+      uses: actions/checkout@v4
+      with:
+        path: cont
+    - name: checkout mhs repo
+      uses: actions/checkout@v4
+      with:
+        repository: augustss/MicroHs
+        ref: stable-1
+        path: mhs
+    - name: make mhs
+      run: |
+        cd mhs
+        make
+# It's pretty ugly with the list of modules here, but I don't know a nice way of getting it from the cabal file.
+# I'll make it nicer with mcabal later.
+    - name: compile containers package
+      run: |
+        cd mhs
+        MHSCPPHS=./bin/cpphs ./bin/mhs -Pcontainers-test -ocontainers-test.pkg -i../cont/containers/src -XCPP -I../cont/containers/include Data.Containers.ListUtils Data.IntMap Data.IntMap.Lazy Data.IntMap.Strict Data.IntMap.Strict.Internal Data.IntMap.Internal Data.IntMap.Internal.Debug Data.IntMap.Merge.Lazy Data.IntMap.Merge.Strict Data.IntSet.Internal Data.IntSet.Internal.IntTreeCommons Data.IntSet Data.Map Data.Map.Lazy Data.Map.Merge.Lazy Data.Map.Strict.Internal Data.Map.Strict Data.Map.Merge.Strict Data.Map.Internal Data.Map.Internal.Debug Data.Set.Internal Data.Set Data.Graph Data.Sequence Data.Sequence.Internal Data.Sequence.Internal.Sorting Data.Tree Utils.Containers.Internal.BitUtil Utils.Containers.Internal.BitQueue Utils.Containers.Internal.StrictPair

containers/changelog.md

@@ -27,6 +27,8 @@
 
 ### Bug fixes
 
+* Make the package compile with MicroHs. (Lennart Augustsson)
+
 * `Data.Map.Strict.mergeWithKey` now forces the result of the combining function
   to WHNF. (Soumik Sarkar)
 

containers/containers.cabal

@@ -36,7 +36,9 @@ source-repository head
 
 Library
     default-language: Haskell2010
-    build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6, template-haskell
+    build-depends: base >= 4.10 && < 5, array >= 0.4.0.0, deepseq >= 1.2 && < 1.6
+    if impl(ghc)
+       build-depends: template-haskell
     hs-source-dirs: src
     ghc-options: -O2 -Wall -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
 

containers/include/containers.h

@@ -6,9 +6,9 @@
 #define HASKELL_CONTAINERS_H
 
 /*
- * On GHC, include MachDeps.h to get WORD_SIZE_IN_BITS macro.
+ * On GHC and MicroHs, include MachDeps.h to get WORD_SIZE_IN_BITS macro.
  */
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
 #include "MachDeps.h"
 #endif
 

containers/src/Data/Graph.hs

@@ -210,8 +210,10 @@ instance Show1 SCC where
 instance Read1 SCC where
   liftReadsPrec rp rl = readsData $
     readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>
-    readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC <>
-    readsUnaryWith (const rl) "CyclicSCC" CyclicSCC
+    readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC
+#ifdef __GLASGOW_HASKELL__
+    <> readsUnaryWith (const rl) "CyclicSCC" CyclicSCC
+#endif
 
 -- | @since 0.5.9
 instance F.Foldable SCC where

containers/src/Data/IntMap/Internal.hs

@@ -324,11 +324,13 @@ import Data.Data (Data(..), Constr, mkConstr, constrIndex,
 import qualified Data.Data as Data
 import GHC.Exts (build)
 import qualified GHC.Exts as GHCExts
-import Text.Read
 import Language.Haskell.TH.Syntax (Lift)
 -- See Note [ Template Haskell Dependencies ]
 import Language.Haskell.TH ()
 #endif
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
+import Text.Read
+#endif
 import qualified Control.Category as Category
 
 
@@ -395,8 +397,10 @@ data IntMap a = Bin {-# UNPACK #-} !Prefix
 type IntSetPrefix = Int
 type IntSetBitMap = Word
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.6.6
 deriving instance Lift a => Lift (IntMap a)
+#endif
 
 bitmapOf :: Int -> IntSetBitMap
 bitmapOf x = shiftLL 1 (x .&. IntSet.suffixBitMask)
@@ -2112,6 +2116,7 @@ mergeA
       EQL -> binA p1 (go l1 l2) (go r1 r2)
       NOM -> linkA (unPrefix p1) (g1t t1) (unPrefix p2) (g2t t2)
 
+    subsingletonBy :: Functor f => (Key -> a -> f (Maybe c)) -> Key -> a -> f (IntMap c)
     subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x
     {-# INLINE subsingletonBy #-}
 
@@ -3498,7 +3503,7 @@ instance Show1 IntMap where
   Read
 --------------------------------------------------------------------}
 instance (Read e) => Read (IntMap e) where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
   readPrec = parens $ prec 10 $ do
     Ident "fromList" <- lexP
     xs <- readPrec

containers/src/Data/IntSet/Internal.hs

@@ -1683,16 +1683,16 @@ takeWhileAntitoneBits :: Int -> (Int -> Bool) -> Nat -> Nat
 {-# INLINE foldr'Bits #-}
 {-# INLINE takeWhileAntitoneBits #-}
 
+lowestBitMask :: Nat -> Nat
+lowestBitMask x = x .&. negate x
+{-# INLINE lowestBitMask #-}
+
 #if defined(__GLASGOW_HASKELL__)
 
 lowestBitSet x = countTrailingZeros x
 
 highestBitSet x = WORD_SIZE_IN_BITS - 1 - countLeadingZeros x
 
-lowestBitMask :: Nat -> Nat
-lowestBitMask x = x .&. negate x
-{-# INLINE lowestBitMask #-}
-
 -- Reverse the order of bits in the Nat.
 revNat :: Nat -> Nat
 #if WORD_SIZE_IN_BITS==32

containers/src/Data/Map/Internal.hs

@@ -7,8 +7,8 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE Trustworthy #-}
 {-# LANGUAGE TypeFamilies #-}
-#endif
 #define USE_MAGIC_PROXY 1
+#endif
 
 #ifdef USE_MAGIC_PROXY
 {-# LANGUAGE MagicHash #-}
@@ -414,12 +414,13 @@ import Language.Haskell.TH ()
 import GHC.Exts (Proxy#, proxy# )
 #  endif
 import qualified GHC.Exts as GHCExts
-import Text.Read hiding (lift)
 import Data.Data
-import qualified Control.Category as Category
 import Data.Coerce
 #endif
-
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
+import Text.Read hiding (lift)
+#endif
+import qualified Control.Category as Category
 
 {--------------------------------------------------------------------
   Operators
@@ -4479,7 +4480,7 @@ instance (NFData k, NFData a) => NFData (Map k a) where
   Read
 --------------------------------------------------------------------}
 instance (Ord k, Read k, Read e) => Read (Map k e) where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
   readPrec = parens $ prec 10 $ do
     Ident "fromList" <- lexP
     xs <- readPrec

containers/src/Data/Map/Strict/Internal.hs

@@ -342,7 +342,9 @@ import Data.Map.Internal
   , argSet
   , assocs
   , atKeyImpl
+#ifdef __GLASGOW_HASKELL__
   , atKeyPlain
+#endif
   , balance
   , balanceL
   , balanceR

containers/src/Data/Sequence/Internal.hs

@@ -220,28 +220,31 @@ import Data.Functor.Classes
 import Data.Traversable
 
 -- GHC specific stuff
-#ifdef __GLASGOW_HASKELL__
-import GHC.Exts (build)
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
 import Text.Read (Lexeme(Ident), lexP, parens, prec,
     readPrec, readListPrec, readListPrecDefault)
+#endif
+#ifdef __GLASGOW_HASKELL__
+import GHC.Exts (build)
 import Data.Data
 import Data.String (IsString(..))
 import qualified Language.Haskell.TH.Syntax as TH
 -- See Note [ Template Haskell Dependencies ]
 import Language.Haskell.TH ()
 import GHC.Generics (Generic, Generic1)
-#endif
 
 -- Array stuff, with GHC.Arr on GHC
-import Data.Array (Ix, Array)
-import qualified Data.Array
-#ifdef __GLASGOW_HASKELL__
 import qualified GHC.Arr
+import Data.Coerce
+import qualified GHC.Exts
+#else
+import qualified Data.List
 #endif
 
+import Data.Array (Ix, Array)
+import qualified Data.Array
+
 import Utils.Containers.Internal.Coercions ((.#), (.^#))
-import Data.Coerce
-import qualified GHC.Exts
 
 import Data.Functor.Identity (Identity(..))
 
@@ -976,7 +979,7 @@ liftCmpLists cmp = go
 {-# INLINE liftCmpLists #-}
 
 instance Read a => Read (Seq a) where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
     readPrec = parens $ prec 10 $ do
         Ident "fromList" <- lexP
         xs <- readPrec
@@ -4260,7 +4263,7 @@ fromList        :: [a] -> Seq a
 -- it gets a bit hard to read.
 fromList = Seq . mkTree . map_elem
   where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
     mkTree :: forall a' . [Elem a'] -> FingerTree (Elem a')
 #else
     mkTree :: [Elem a] -> FingerTree (Elem a)
@@ -4308,7 +4311,7 @@ fromList = Seq . mkTree . map_elem
       where
         d2 = Three x1 x2 x3
         d1 = Three (Node3 3 x4 x5 x6) (Node3 3 x7 x8 x9) (Node3 3 y0 y1 y2)
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
         cont :: (Digit (Node (Elem a')), Digit (Elem a')) -> FingerTree (Node (Node (Elem a'))) -> FingerTree (Elem a')
 #endif
         cont (!r1, !r2) !sub =
@@ -4335,7 +4338,7 @@ fromList = Seq . mkTree . map_elem
             !n10 = Node3 (3*s) n1 n2 n3
 
     mkTreeC ::
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
                forall a b c .
 #endif
                (b -> FingerTree (Node a) -> c)
@@ -4377,7 +4380,7 @@ fromList = Seq . mkTree . map_elem
     mkTreeC cont s (LCons x1 (LCons x2 (LCons x3 (LCons x4 (LCons x5 (LCons x6 (LCons x7 (LCons x8 (LCons x9 (LCons y0 (LCons y1 (LCons y2 (LCons y3 (LCons y4 (LCons y5 (LCons y6 xs)))))))))))))))) =
       mkTreeC cont2 (9*s) (getNodesC (3*s) (Node3 (3*s) y3 y4 y5) y6 xs)
       where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
         cont2 :: (b, Digit (Node (Node a)), Digit (Node a)) -> FingerTree (Node (Node (Node a))) -> c
 #endif
         cont2 (b, r1, r2) !sub =

containers/src/Data/Set/Internal.hs

@@ -259,11 +259,13 @@ import Utils.Containers.Internal.StrictPair
 import Utils.Containers.Internal.PtrEquality
 import Utils.Containers.Internal.EqOrdUtil (EqM(..), OrdM(..))
 
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
+import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec
+                 , lexP, readListPrecDefault )
+#endif
 #if __GLASGOW_HASKELL__
 import GHC.Exts ( build, lazy )
 import qualified GHC.Exts as GHCExts
-import Text.Read ( readPrec, Read (..), Lexeme (..), parens, prec
-                 , lexP, readListPrecDefault )
 import Data.Data
 import Language.Haskell.TH.Syntax (Lift)
 -- See Note [ Template Haskell Dependencies ]
@@ -296,10 +298,10 @@ type Size     = Int
 
 #ifdef __GLASGOW_HASKELL__
 type role Set nominal
-#endif
 
 -- | @since 0.6.6
 deriving instance Lift a => Lift (Set a)
+#endif
 
 instance Ord a => Monoid (Set a) where
     mempty  = empty
@@ -1385,7 +1387,7 @@ instance Show1 Set where
   Read
 --------------------------------------------------------------------}
 instance (Read a, Ord a) => Read (Set a) where
-#ifdef __GLASGOW_HASKELL__
+#if defined(__GLASGOW_HASKELL__) || defined(__MHS__)
   readPrec = parens $ prec 10 $ do
     Ident "fromList" <- lexP
     xs <- readPrec

containers/src/Data/Tree.hs

@@ -73,8 +73,9 @@ import Language.Haskell.TH ()
 
 import Control.Monad.Zip (MonadZip (..))
 
+#ifdef __GLASGOW_HASKELL__
 import Data.Coerce
-
+#endif
 import Data.Functor.Classes
 
 #if !MIN_VERSION_base(4,11,0)

containers/src/Utils/Containers/Internal/Prelude.hs

@@ -1,12 +1,24 @@
+{-# LANGUAGE CPP #-}
 -- | This hideous module lets us avoid dealing with the fact that
 -- @liftA2@ and @foldl'@ were not previously exported from the standard prelude.
 module Utils.Containers.Internal.Prelude
   ( module Prelude
   , Applicative (..)
   , Foldable (..)
+#ifdef __MHS__
+  , Traversable(..)
+  , any, concatMap
+#endif
   )
   where
 
+#ifdef __MHS__
+import Prelude hiding (elem, foldr, foldl, foldr1, foldl1, maximum, minimum, product, sum, null, length, mapM, any, concatMap)
+import Data.Traversable
+import Data.List.NonEmpty(NonEmpty)
+import Data.Foldable(any, concatMap)
+#else
 import Prelude hiding (Applicative(..), Foldable(..))
+#endif
 import Control.Applicative(Applicative(..))
 import Data.Foldable (Foldable(elem, foldMap, foldr, foldl, foldl', foldr1, foldl1, maximum, minimum, product, sum, null, length))

containers/src/Utils/Containers/Internal/StrictMaybe.hs

@@ -6,6 +6,9 @@
 -- | Strict 'Maybe'
 
 module Utils.Containers.Internal.StrictMaybe (MaybeS (..), maybeS, toMaybe, toMaybeS) where
+#ifdef __MHS__
+import Data.Foldable
+#endif
 
 data MaybeS a = NothingS | JustS !a
 

containers/src/Utils/Containers/Internal/TypeError.hs

@@ -8,6 +8,7 @@
 -- | Unsatisfiable constraints for functions being removed.
 
 module Utils.Containers.Internal.TypeError where
+#ifdef __GLASGOW_HASKELL__
 import GHC.TypeLits
 
 -- | The constraint @Whoops s@ is unsatisfiable for every 'Symbol' @s@.  Trying
@@ -42,3 +43,7 @@ instance TypeError ('Text a) => Whoops a
 -- reducing the constraint because it knows someone could (theoretically)
 -- define an overlapping instance of Whoops. It doesn't commit to
 -- the polymorphic one until it has to, at the call site.
+
+#else
+class Whoops (a :: Symbol)
+#endif