Various changes to make it compile with MicroHs.

.github/workflows/mhs-ci.yml

@@ -0,0 +1,31 @@
+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
+        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

@@ -115,7 +115,7 @@ import Data.Tree (Tree(Node), Forest)
 
 -- std interfaces
 import Data.Foldable as F
-#if MIN_VERSION_base(4,18,0)
+#if MIN_VERSION_base(4,18,0) && defined(__GLASGOW_HASKELL__)
 import qualified Data.Foldable1 as F1
 #endif
 import Control.DeepSeq (NFData(rnf))
@@ -130,7 +130,9 @@ import qualified Data.Array as UA
 import qualified Data.List as L
 import Data.List.NonEmpty (NonEmpty(..))
 import qualified Data.List.NonEmpty as NE
+#ifdef __GLASGOW_HASKELL__
 import Data.Functor.Classes
+#endif
 #if !MIN_VERSION_base(4,11,0)
 import Data.Semigroup (Semigroup (..))
 #endif
@@ -194,6 +196,7 @@ instance Lift vertex => Lift (SCC vertex) where
 
 #endif
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Eq1 SCC where
   liftEq eq (AcyclicSCC v1) (AcyclicSCC v2) = eq v1 v2
@@ -209,13 +212,14 @@ instance Read1 SCC where
     readsUnaryWith rp "AcyclicSCC" AcyclicSCC <>
     readsUnaryWith (liftReadsPrec rp rl) "NECyclicSCC" NECyclicSCC <>
     readsUnaryWith (const rl) "CyclicSCC" CyclicSCC
+#endif
 
 -- | @since 0.5.9
 instance F.Foldable SCC where
   foldr c n (AcyclicSCC v) = c v n
   foldr c n (NECyclicSCC vs) = foldr c n vs
 
-#if MIN_VERSION_base(4,18,0)
+#if MIN_VERSION_base(4,18,0) && defined(__GLASGOW_HASKELL__)
 -- | @since 0.7.0
 instance F1.Foldable1 SCC where
   foldMap1 f (AcyclicSCC v) = f v

containers/src/Data/IntMap/Internal.hs

@@ -292,7 +292,9 @@ import Data.Semigroup (Semigroup(stimes))
 import Data.Semigroup (Semigroup((<>)))
 #endif
 import Data.Semigroup (stimesIdempotentMonoid)
+#ifdef __GLASGOW_HASKELL__
 import Data.Functor.Classes
+#endif
 
 import Control.DeepSeq (NFData(rnf))
 import Data.Bits
@@ -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)
@@ -2067,7 +2071,7 @@ merge g1 g2 f m1 m2 =
 --
 -- @since 0.5.9
 mergeA
-  :: (Applicative f)
+  :: forall f a b c . (Applicative f)
   => WhenMissing f a c -- ^ What to do with keys in @m1@ but not @m2@
   -> WhenMissing f b c -- ^ What to do with keys in @m2@ but not @m1@
   -> WhenMatched f a b c -- ^ What to do with keys in both @m1@ and @m2@
@@ -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 :: forall a' . (Key -> a' -> f (Maybe c)) -> Key -> a' -> f (IntMap c)
     subsingletonBy gk k x = maybe Nil (Tip k) <$> gk k x
     {-# INLINE subsingletonBy #-}
 
@@ -2133,10 +2138,10 @@ mergeA
     -- | A variant of 'link_' which makes sure to execute side-effects
     -- in the right order.
     linkA
-        :: Applicative f
-        => Int -> f (IntMap a)
-        -> Int -> f (IntMap a)
-        -> f (IntMap a)
+        :: forall a' . Applicative f
+        => Int -> f (IntMap a')
+        -> Int -> f (IntMap a')
+        -> f (IntMap a')
     linkA k1 t1 k2 t2
       | natFromInt k1 < natFromInt k2 = binA p t1 t2
       | otherwise = binA p t2 t1
@@ -2148,11 +2153,11 @@ mergeA
     -- A variant of 'bin' that ensures that effects for negative keys are executed
     -- first.
     binA
-        :: Applicative f
+        :: forall a' . Applicative f
         => Prefix
-        -> f (IntMap a)
-        -> f (IntMap a)
-        -> f (IntMap a)
+        -> f (IntMap a')
+        -> f (IntMap a')
+        -> f (IntMap a')
     binA p a b
       | signBranch p = liftA2 (flip (bin p)) b a
       | otherwise = liftA2 (bin p) a b
@@ -3444,6 +3449,7 @@ equal Nil Nil = True
 equal _   _   = False
 {-# INLINABLE equal #-}
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Eq1 IntMap where
   liftEq eq (Bin p1 l1 r1) (Bin p2 l2 r2)
@@ -3452,6 +3458,7 @@ instance Eq1 IntMap where
     = (kx == ky) && (eq x y)
   liftEq _eq Nil Nil = True
   liftEq _eq _   _   = False
+#endif
 
 {--------------------------------------------------------------------
   Ord
@@ -3460,10 +3467,12 @@ instance Eq1 IntMap where
 instance Ord a => Ord (IntMap a) where
     compare m1 m2 = compare (toList m1) (toList m2)
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Ord1 IntMap where
   liftCompare cmp m n =
     liftCompare (liftCompare cmp) (toList m) (toList n)
+#endif
 
 {--------------------------------------------------------------------
   Functor
@@ -3486,13 +3495,15 @@ instance Show a => Show (IntMap a) where
   showsPrec d m   = showParen (d > 10) $
     showString "fromList " . shows (toList m)
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Show1 IntMap where
     liftShowsPrec sp sl d m =
         showsUnaryWith (liftShowsPrec sp' sl') "fromList" d (toList m)
       where
         sp' = liftShowsPrec sp sl
         sl' = liftShowList sp sl
+#endif
 
 {--------------------------------------------------------------------
   Read
@@ -3512,13 +3523,15 @@ instance (Read e) => Read (IntMap e) where
     return (fromList xs,t)
 #endif
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Read1 IntMap where
     liftReadsPrec rp rl = readsData $
         readsUnaryWith (liftReadsPrec rp' rl') "fromList" fromList
       where
         rp' = liftReadsPrec rp rl
         rl' = liftReadList rp rl
+#endif
 
 {--------------------------------------------------------------------
   Helpers

containers/src/Data/IntSet/Internal.hs

@@ -1641,16 +1641,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 #-}
@@ -379,7 +379,9 @@ module Data.Map.Internal (
 
 import Data.Functor.Identity (Identity (..))
 import Control.Applicative (liftA3)
+#ifdef __GLASGOW_HASKELL__
 import Data.Functor.Classes
+#endif
 import Data.Semigroup (stimesIdempotentMonoid)
 import Data.Semigroup (Arg(..), Semigroup(stimes))
 #if !(MIN_VERSION_base(4,11,0))
@@ -389,7 +391,9 @@ import Control.Applicative (Const (..))
 import Control.DeepSeq (NFData(rnf))
 import Data.Bits (shiftL, shiftR)
 import qualified Data.Foldable as Foldable
+#ifdef __GLASGOW_HASKELL__
 import Data.Bifoldable
+#endif
 import Utils.Containers.Internal.Prelude hiding
   (lookup, map, filter, foldr, foldl, foldl', null, splitAt, take, drop)
 import Prelude ()
@@ -416,10 +420,9 @@ import GHC.Exts (Proxy#, proxy# )
 import qualified GHC.Exts as GHCExts
 import Text.Read hiding (lift)
 import Data.Data
-import qualified Control.Category as Category
 import Data.Coerce
 #endif
-
+import qualified Control.Category as Category
 
 {--------------------------------------------------------------------
   Operators
@@ -2340,6 +2343,7 @@ instance Functor f => Functor (WhenMatched f k x y) where
   fmap = mapWhenMatched
   {-# INLINE fmap #-}
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where
   id = zipWithMatched (\_ _ y -> y)
@@ -2351,6 +2355,7 @@ instance (Monad f, Applicative f) => Category.Category (WhenMatched f k x) where
                 Just r -> runWhenMatched f k x r
   {-# INLINE id #-}
   {-# INLINE (.) #-}
+#endif
 
 -- | Equivalent to @ ReaderT k (ReaderT x (ReaderT y (MaybeT f))) @
 --
@@ -4303,6 +4308,7 @@ bin k x l r
   Eq
 --------------------------------------------------------------------}
 
+#ifdef __GLASGOW_HASKELL__
 instance (Eq k,Eq a) => Eq (Map k a) where
   m1 == m2 = liftEq2 (==) (==) m1 m2
   {-# INLINABLE (==) #-}
@@ -4327,11 +4333,16 @@ sameSizeLiftEq2 keq eq m1 m2 =
       Nothing -> False :*: it
       Just (KeyValue ky y :*: it') -> (keq kx ky && eq x y) :*: it'
 {-# INLINE sameSizeLiftEq2 #-}
+#else
+instance (Eq k,Eq a) => Eq (Map k a) where
+  t1 == t2  = (size t1 == size t2) && (toAscList t1 == toAscList t2)
+#endif
 
 {--------------------------------------------------------------------
   Ord
 --------------------------------------------------------------------}
 
+#ifdef __GLASGOW_HASKELL__
 instance (Ord k, Ord v) => Ord (Map k v) where
   compare m1 m2 = liftCmp2 compare compare m1 m2
   {-# INLINABLE compare #-}
@@ -4359,11 +4370,16 @@ liftCmp2 kcmp cmp m1 m2 = case runOrdM (foldMapWithKey f m1) (iterator m2) of
       Nothing -> GT :*: it
       Just (KeyValue ky y :*: it') -> (kcmp kx ky <> cmp x y) :*: it'
 {-# INLINE liftCmp2 #-}
+#else
+instance (Ord k, Ord v) => Ord (Map k v) where
+    compare m1 m2 = compare (toAscList m1) (toAscList m2)
+#endif
 
 {--------------------------------------------------------------------
   Lifted instances
 --------------------------------------------------------------------}
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.5.9
 instance Show2 Map where
     liftShowsPrec2 spk slk spv slv d m =
@@ -4383,6 +4399,7 @@ instance (Ord k, Read k) => Read1 (Map k) where
       where
         rp' = liftReadsPrec rp rl
         rl' = liftReadList rp rl
+#endif
 
 {--------------------------------------------------------------------
   Functor
@@ -4448,6 +4465,7 @@ instance Foldable.Foldable (Map k) where
   product = foldl' (*) 1
   {-# INLINABLE product #-}
 
+#ifdef __GLASGOW_HASKELL__
 -- | @since 0.6.3.1
 instance Bifoldable Map where
   bifold = go
@@ -4468,6 +4486,7 @@ instance Bifoldable Map where
           go (Bin 1 k v _ _) = f k `mappend` g v
           go (Bin _ k v l r) = go l `mappend` (f k `mappend` (g v `mappend` go r))
   {-# INLINE bifoldMap #-}
+#endif
 
 instance (NFData k, NFData a) => NFData (Map k a) where
     rnf Tip = ()

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