From 12407d22357a436f78269c788442407e5dfa258e Mon Sep 17 00:00:00 2001 From: Lennart Augustsson Date: Sun, 16 Nov 2025 10:54:47 +0100 Subject: [PATCH] Make it compile with MicroHs --- .github/workflows/mhs-ci.yml | 37 +++++++++++++++++++++++++++++++++ Data/HashMap/Internal.hs | 18 +++++++++++++++- Data/HashMap/Internal/Array.hs | 20 ++++++++++++------ Data/HashMap/Internal/Strict.hs | 6 ++++-- Data/HashSet/Internal.hs | 2 ++ unordered-containers.cabal | 6 ++++-- 6 files changed, 78 insertions(+), 11 deletions(-) create mode 100644 .github/workflows/mhs-ci.yml diff --git a/.github/workflows/mhs-ci.yml b/.github/workflows/mhs-ci.yml new file mode 100644 index 00000000..68a55c98 --- /dev/null +++ b/.github/workflows/mhs-ci.yml @@ -0,0 +1,37 @@ +name: mhs-ci + +on: + push: + branches: [ "master" ] + pull_request: + branches: [ "master" ] + +jobs: + build-mhs-pretty: + runs-on: ubuntu-latest + steps: + + - name: checkout mhs repo + uses: actions/checkout@v4 + with: + repository: augustss/MicroHs + ref: v0.14.23.1 + path: mhs + - name: make and install mhs + run: | + cd mhs + make minstall + + - name: checkout unordered-containers repo + uses: actions/checkout@v4 + with: + path: unordered-containers + - name: compile and install unordered-containers package + run: | + PATH="$HOME/.mcabal/bin:$PATH" + cd unordered-containers + mcabal -r install + + - name: cleanup + run: | + rm -rf $HOME/.mcabal diff --git a/Data/HashMap/Internal.hs b/Data/HashMap/Internal.hs index 13d3d0f5..ac5ed3ee 100644 --- a/Data/HashMap/Internal.hs +++ b/Data/HashMap/Internal.hs @@ -149,6 +149,9 @@ module Data.HashMap.Internal , adjust# ) where +import Data.Traversable -- MicroHs needs this since its Prelude does not have Foldable&Traversable. + -- It's harmless for GHC, and putting it first avoid a warning. + import Control.Applicative (Const (..)) import Control.DeepSeq (NFData (..), NFData1 (..), NFData2 (..)) import Control.Monad.ST (ST, runST) @@ -192,9 +195,11 @@ data Leaf k v = L !k v instance (NFData k, NFData v) => NFData (Leaf k v) where rnf (L k v) = rnf k `seq` rnf v +#if defined(__GLASGOW_HASKELL__) -- | @since 0.2.17.0 instance (TH.Lift k, TH.Lift v) => TH.Lift (Leaf k v) where liftTyped (L k v) = [|| L k $! v ||] +#endif -- | @since 0.2.14.0 instance NFData k => NFData1 (Leaf k) where @@ -701,7 +706,11 @@ lookupRecordCollision# h k m = -- this whole thing is always inlined, we don't have to worry about -- any extra CPS overhead. lookupCont :: +#if defined(__GLASGOW_HASKELL__) forall rep (r :: TYPE rep) k v. +#else + forall r k v. +#endif Eq k => ((# #) -> r) -- Absent continuation -> (v -> Int -> r) -- Present continuation @@ -915,10 +924,11 @@ setAtPosition i k x ary = A.update ary i (L k x) -- | In-place update version of insert -unsafeInsert :: (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v +unsafeInsert :: forall k v. (Eq k, Hashable k) => k -> v -> HashMap k v -> HashMap k v unsafeInsert k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 + go :: forall s. Hash -> k -> v -> Int -> HashMap k v -> ST s (HashMap k v) go !h !k x !_ Empty = return $! Leaf h (L k x) go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k @@ -2588,7 +2598,11 @@ fromListWithKey f = List.foldl' (\ m (k, v) -> unsafeInsertWithKey (\k' a b -> ( -- | \(O(n)\) Look up the value associated with the given key in an -- array. lookupInArrayCont :: +#if defined(__GLASGOW_HASKELL__) forall rep (r :: TYPE rep) k v. +#else + forall r k v. +#endif Eq k => ((# #) -> r) -> (v -> Int -> r) -> k -> A.Array (Leaf k v) -> r lookupInArrayCont absent present k0 ary0 = go k0 ary0 0 (A.length ary0) where @@ -2841,9 +2855,11 @@ otherOfOneOrZero :: Int -> Int otherOfOneOrZero i = 1 - i {-# INLINE otherOfOneOrZero #-} +#if defined(__GLASGOW_HASKELL__) ------------------------------------------------------------------------ -- IsList instance instance (Eq k, Hashable k) => Exts.IsList (HashMap k v) where type Item (HashMap k v) = (k, v) fromList = fromList toList = toList +#endif diff --git a/Data/HashMap/Internal/Array.hs b/Data/HashMap/Internal/Array.hs index 3d004c1a..f49064e8 100644 --- a/Data/HashMap/Internal/Array.hs +++ b/Data/HashMap/Internal/Array.hs @@ -465,7 +465,7 @@ deleteM ary idx = do where !count = length ary {-# INLINE deleteM #-} -map :: (a -> b) -> Array a -> Array b +map :: forall a b . (a -> b) -> Array a -> Array b map f = \ ary -> let !n = length ary in run $ do @@ -473,6 +473,7 @@ map f = \ ary -> go ary mary 0 n return mary where + go :: forall s. Array a -> MArray s b -> Int -> Int -> ST s () go ary mary i n | i >= n = return () | otherwise = do @@ -482,7 +483,7 @@ map f = \ ary -> {-# INLINE map #-} -- | Strict version of 'map'. -map' :: (a -> b) -> Array a -> Array b +map' :: forall a b . (a -> b) -> Array a -> Array b map' f = \ ary -> let !n = length ary in run $ do @@ -490,6 +491,7 @@ map' f = \ ary -> go ary mary 0 n return mary where + go :: forall s . Array a -> MArray s b -> Int -> Int -> ST s () go ary mary i n | i >= n = return () | otherwise = do @@ -498,7 +500,7 @@ map' f = \ ary -> go ary mary (i+1) n {-# INLINE map' #-} -filter :: (a -> Bool) -> Array a -> Array a +filter :: forall a . (a -> Bool) -> Array a -> Array a filter f = \ ary -> let !n = length ary in run $ do @@ -509,6 +511,7 @@ filter f = \ ary -> -- Without the @!@ on @ary@ we end up reboxing the array when using -- 'differenceCollisions'. See -- https://gitlab.haskell.org/ghc/ghc/-/issues/26525. + go_filter :: forall s . Array a -> MArray s a -> Int -> Int -> Int -> ST s Int go_filter !ary !mary !iAry !iMary !n | iAry >= n = return iMary | otherwise = do @@ -520,7 +523,7 @@ filter f = \ ary -> else go_filter ary mary (iAry + 1) iMary n {-# INLINE filter #-} -mapMaybe :: (a -> Maybe b) -> Array a -> Array b +mapMaybe :: forall a b . (a -> Maybe b) -> Array a -> Array b mapMaybe f = \ ary -> let !n = length ary in run $ do @@ -528,6 +531,7 @@ mapMaybe f = \ ary -> len <- go_mapMaybe ary mary 0 0 n shrink mary len where + go_mapMaybe :: forall s . Array a -> MArray s b -> Int -> Int -> Int -> ST s Int go_mapMaybe !ary !mary !iAry !iMary !n | iAry >= n = return iMary | otherwise = do @@ -539,7 +543,7 @@ mapMaybe f = \ ary -> go_mapMaybe ary mary (iAry + 1) (iMary + 1) n {-# INLINE mapMaybe #-} -fromList :: Int -> [a] -> Array a +fromList :: forall a . Int -> [a] -> Array a fromList n xs0 = CHECK_EQ("fromList", n, Prelude.length xs0) run $ do @@ -547,11 +551,12 @@ fromList n xs0 = go xs0 mary 0 return mary where + go :: forall s . [a] -> MArray s a -> Int -> ST s () go [] !_ !_ = return () go (x:xs) mary i = do write mary i x go xs mary (i+1) -fromList' :: Int -> [a] -> Array a +fromList' :: forall a . Int -> [a] -> Array a fromList' n xs0 = CHECK_EQ("fromList'", n, Prelude.length xs0) run $ do @@ -559,16 +564,19 @@ fromList' n xs0 = go xs0 mary 0 return mary where + go :: forall s . [a] -> MArray s a -> Int -> ST s () go [] !_ !_ = return () go (!x:xs) mary i = do write mary i x go xs mary (i+1) +#if defined(__GLASGOW_HASKELL__) -- | @since 0.2.17.0 instance TH.Lift a => TH.Lift (Array a) where liftTyped ar = [|| fromList' arlen arlist ||] where arlen = length ar arlist = toList ar +#endif toList :: Array a -> [a] toList = foldr (:) [] diff --git a/Data/HashMap/Internal/Strict.hs b/Data/HashMap/Internal/Strict.hs index 42caac16..d6218688 100644 --- a/Data/HashMap/Internal/Strict.hs +++ b/Data/HashMap/Internal/Strict.hs @@ -3,6 +3,7 @@ {-# LANGUAGE LambdaCase #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE PatternGuards #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE UnboxedTuples #-} {-# OPTIONS_HADDOCK not-home #-} @@ -124,7 +125,7 @@ module Data.HashMap.Internal.Strict ) where import Control.Applicative (Const (..)) -import Control.Monad.ST (runST) +import Control.Monad.ST (runST, ST) import Data.Bits ((.&.), (.|.)) import Data.Coerce (coerce) import Data.Functor.Identity (Identity (..)) @@ -228,11 +229,12 @@ unsafeInsertWith :: (Eq k, Hashable k) => (v -> v -> v) -> k -> v -> HashMap k v unsafeInsertWith f k0 v0 m0 = unsafeInsertWithKey (const f) k0 v0 m0 {-# INLINABLE unsafeInsertWith #-} -unsafeInsertWithKey :: (Eq k, Hashable k) => (k -> v -> v -> v) -> k -> v -> HashMap k v +unsafeInsertWithKey :: forall k v. (Eq k, Hashable k) => (k -> v -> v -> v) -> k -> v -> HashMap k v -> HashMap k v unsafeInsertWithKey f k0 v0 m0 = runST (go h0 k0 v0 0 m0) where h0 = hash k0 + go :: forall s. Hash -> k -> v -> Int -> HashMap k v -> ST s (HashMap k v) go !h !k x !_ Empty = return $! leaf h k x go h k x s t@(Leaf hy l@(L ky y)) | hy == h = if ky == k diff --git a/Data/HashSet/Internal.hs b/Data/HashSet/Internal.hs index 98008fe5..49736cb4 100644 --- a/Data/HashSet/Internal.hs +++ b/Data/HashSet/Internal.hs @@ -450,7 +450,9 @@ fromList :: (Eq a, Hashable a) => [a] -> HashSet a fromList = HashSet . List.foldl' (\ m k -> H.unsafeInsert k () m) H.empty {-# INLINE fromList #-} +#if defined(__GLASGOW_HASKELL__) instance (Eq a, Hashable a) => Exts.IsList (HashSet a) where type Item (HashSet a) = a fromList = fromList toList = toList +#endif diff --git a/unordered-containers.cabal b/unordered-containers.cabal index 228eb53e..6a0948cc 100644 --- a/unordered-containers.cabal +++ b/unordered-containers.cabal @@ -57,8 +57,10 @@ library build-depends: base >= 4.14 && < 5, deepseq >= 1.4.3, - hashable >= 1.4 && < 1.6, - template-haskell >= 2.16 && < 2.24 + hashable >= 1.4 && < 1.6 + if impl(ghc) + build-depends: + template-haskell >= 2.16 && < 2.24 default-language: Haskell2010