Skip to content

Commit

Permalink
Various changes to make it compile with MicroHs (#1043)
Browse files Browse the repository at this point in the history
* Mostly #ifdefs and some type signatures.
* Add CI for MicroHs compilation.
  • Loading branch information
augustss authored Oct 4, 2024
1 parent a669855 commit 24b0b3a
Show file tree
Hide file tree
Showing 15 changed files with 106 additions and 34 deletions.
32 changes: 32 additions & 0 deletions .github/workflows/mhs-ci.yml
Original file line number Diff line number Diff line change
@@ -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
2 changes: 2 additions & 0 deletions containers/changelog.md
Original file line number Diff line number Diff line change
Expand Up @@ -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)

Expand Down
4 changes: 3 additions & 1 deletion containers/containers.cabal
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
4 changes: 2 additions & 2 deletions containers/include/containers.h
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
6 changes: 4 additions & 2 deletions containers/src/Data/Graph.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
9 changes: 7 additions & 2 deletions containers/src/Data/IntMap/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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


Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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 #-}

Expand Down Expand Up @@ -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
Expand Down
8 changes: 4 additions & 4 deletions containers/src/Data/IntSet/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
11 changes: 6 additions & 5 deletions containers/src/Data/Map/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -7,8 +7,8 @@
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE Trustworthy #-}
{-# LANGUAGE TypeFamilies #-}
#endif
#define USE_MAGIC_PROXY 1
#endif

#ifdef USE_MAGIC_PROXY
{-# LANGUAGE MagicHash #-}
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
2 changes: 2 additions & 0 deletions containers/src/Data/Map/Strict/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -342,7 +342,9 @@ import Data.Map.Internal
, argSet
, assocs
, atKeyImpl
#ifdef __GLASGOW_HASKELL__
, atKeyPlain
#endif
, balance
, balanceL
, balanceR
Expand Down
29 changes: 16 additions & 13 deletions containers/src/Data/Sequence/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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(..))

Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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)
Expand Down Expand Up @@ -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 =
Expand All @@ -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)
Expand Down Expand Up @@ -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 =
Expand Down
10 changes: 6 additions & 4 deletions containers/src/Data/Set/Internal.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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 ]
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion containers/src/Data/Tree.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
12 changes: 12 additions & 0 deletions containers/src/Utils/Containers/Internal/Prelude.hs
Original file line number Diff line number Diff line change
@@ -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))
3 changes: 3 additions & 0 deletions containers/src/Utils/Containers/Internal/StrictMaybe.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down
5 changes: 5 additions & 0 deletions containers/src/Utils/Containers/Internal/TypeError.hs
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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

0 comments on commit 24b0b3a

Please sign in to comment.