Build with MicroHs (#45)

* Mostly ifdefs and changes to imports
* Use a list to store the Alt branches on non-GHC, where we use
  SmallArray on GHC
* Implement a finishHex that does not depend on GHC's representation
  of Natural
* Add MicroHs CI

Author: meooow25

.github/workflows/mhs-ci.yml

@@ -0,0 +1,43 @@
+name: MicroHs CI
+
+# Adapted from haskell-ci.yml and
+# https://github.com/haskell/containers/blob/027ea3c6878e53efe70d3dd28fc9070dc0d989b7/.github/workflows/mhs-ci.yml
+
+on:
+  push:
+    branches:
+      - master
+  pull_request:
+    branches:
+      - master
+
+jobs:
+  linux:
+    name: MicroHs CI - Linux
+    runs-on: ubuntu-24.04
+    timeout-minutes:
+      60
+    steps:
+      - name: checkout
+        uses: actions/checkout@v4
+        with:
+          path: source
+      - name: checkout mhs
+        uses: actions/checkout@v4
+        with:
+          repository: augustss/MicroHs
+          # Update ref to a proper version later
+          ref: cb8bc5d609771014dcc32f3052a59066ee13e3ab
+          path: mhs
+      - name: make and install mhs
+        run: |
+          cd mhs
+          make minstall
+      - name: compile and install
+        run: |
+          PATH="$HOME/.mcabal/bin:$PATH"
+          cd source
+          mcabal -r install
+      - name: cleanup
+        run: |
+          rm -rf "$HOME/.mcabal"

parser-regex.cabal

@@ -65,14 +65,29 @@ library
         base >= 4.15 && < 5.0
       , containers >= 0.6.4 && < 0.9
       , deepseq >= 1.4.5 && < 1.6
-      , ghc-bignum >= 1.1 && < 1.4
-      , primitive >= 0.7.3 && < 0.10
       , text >= 2.0.1 && < 2.2
       , transformers >= 0.5.6 && < 0.7
 
     hs-source-dirs:   src
     default-language: Haskell2010
 
+    other-extensions:
+        BangPatterns
+        CPP
+        GADTs
+        RankNTypes
+        ScopedTypeVariables
+
+    if impl(ghc)
+        build-depends:
+            ghc-bignum >= 1.1 && < 1.4
+          , primitive >= 0.7.3 && < 0.10
+
+    if impl(mhs)
+        build-depends:
+            containers >= 0.8
+          , transformers >= 0.6.1.2
+
 test-suite test
     import:           warnings
 

src/Regex/Internal/CharSet.hs

@@ -1,5 +1,8 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
+#ifdef __GLASGOW_HASKELL__
 {-# LANGUAGE MagicHash #-}
+#endif
 {-# OPTIONS_HADDOCK not-home #-}
 
 -- | This is an internal module. You probably don't need to import this. Import
@@ -40,7 +43,9 @@ import Data.String (IsString(..))
 import qualified Data.Foldable as F
 import qualified Data.IntMap.Strict as IM
 import Data.Semigroup (Semigroup(..), stimesIdempotentMonoid)
+#ifdef __GLASGOW_HASKELL__
 import GHC.Exts (Int(..), Char(..), chr#)
+#endif
 
 -- TODO: Evaluate other set libraries.
 -- Possible candidates: charset, rangeset
@@ -222,7 +227,11 @@ complementRanges = go
     unsafePred c = unsafeChr (ord c - 1)
 
 unsafeChr :: Int -> Char
+#ifdef __GLASGOW_HASKELL__
 unsafeChr (I# i#) = C# (chr# i#)
+#else
+unsafeChr = toEnum
+#endif
 
 ------------
 -- Testing

src/Regex/Internal/List.hs

@@ -328,7 +328,7 @@ parseSure p = fromMaybe parseSureError . parse p
 {-# INLINE parseSure #-}
 
 parseSureError :: a
-parseSureError = errorWithoutStackTrace
+parseSureError = error
   "Regex.List.parseSure: parse failed; if parsing can fail use 'parse' instead"
 
 reParseSure :: RE c a -> [c] -> a

src/Regex/Internal/Num.hs

@@ -17,11 +17,13 @@ module Regex.Internal.Num
 import Control.Applicative ((<|>), empty)
 import qualified Control.Applicative as Ap
 import Control.Monad (replicateM_, void)
-import Data.Primitive.PrimArray
-  (PrimArray(..), newPrimArray, runPrimArray, writePrimArray)
 import Data.Bits ((.&.), countLeadingZeros, unsafeShiftL, unsafeShiftR)
 import Numeric.Natural (Natural)
+#ifdef __GLASGOW_HASKELL__
+import Data.Primitive.PrimArray
+  (PrimArray(..), newPrimArray, runPrimArray, writePrimArray)
 import qualified GHC.Num.Natural as Nat
+#endif
 
 import Regex.Internal.Regex (RE)
 import qualified Regex.Internal.Regex as R
@@ -221,10 +223,14 @@ mkWordRangeBase base quotRemPowBase powBase baseLen d low high
 -- Parsing hexadecimal is simple, there is no base conversion involved.
 --
 -- Step 1: Accumulate the hex digits, packed into Words
--- Step 2: Initialize a ByteArray and fill it with the Words
---
--- Because we create a Nat directly, this makes us depend on ghc-bignum and
--- GHC>=9.0.
+-- Step 2:
+--   * GHC: Initialize a ByteArray and fill it with the Words. This takes
+--     O(n) time. Because we create a Nat directly, this makes us depend on
+--     ghc-bignum and GHC>=9.0.
+--   * Not GHC: Do it like we do for decimal, without being aware of the
+--     representation of Naturals, but replace the base multiplications with
+--     shifts. If it is a binary representation, this takes O(n log n) time
+--     instead of O(n^2).
 
 stepHex :: NatParseState -> Word -> NatParseState
 stepHex (NatParseState acc len ns) d
@@ -235,6 +241,7 @@ finishHex
   :: Word          -- ^ Leading digit
   -> NatParseState -- ^ Everything else
   -> Natural
+#ifdef __GLASGOW_HASKELL__
 finishHex !ld (NatParseState acc0 len0 ns0) = case ns0 of
   WNil -> Nat.naturalFromWord (ld `unsafeShiftL` (4*(len0-1)) + acc0)
   WCons n ns1 ->
@@ -268,6 +275,37 @@ finishHex !ld (NatParseState acc0 len0 ns0) = case ns0 of
 -- * Natural invariants:
 --   * If the value fits in a word, it must be NS (via naturalFromWord here).
 --   * Otherwise, use a ByteArray# with NB. The highest Word must not be 0.
+#else
+finishHex !ld (NatParseState acc0 len0 ns0) = combine acc0 len0 ns0
+  where
+    combine !acc !len ns = case ns of
+      WNil -> mul16Pow (w2n ld) (len-1) + w2n acc
+      WCons n ns1 ->
+        mul16Pow (combine1 maxBoundWordHexLen (go n ns1)) len + w2n acc
+      where
+        go n WNil =
+          let !n' = mul16Pow (w2n ld) (maxBoundWordHexLen - 1) + w2n n
+          in [n']
+        go n (WCons m WNil) =
+          let !n' = mul16Pow (w2n ld) (2 * maxBoundWordHexLen - 1) +
+                    mul16Pow (w2n m) maxBoundWordHexLen +
+                    w2n n
+          in [n']
+        go n (WCons m (WCons n1 ns1)) =
+          let !n' = mul16Pow (w2n m) maxBoundWordHexLen + w2n n
+          in n' : go n1 ns1
+
+    combine1 :: Int -> [Natural] -> Natural
+    combine1 !_ [n] = n
+    combine1 !numDigs ns1 = combine1 numDigs1 (go ns1)
+      where
+        numDigs1 = 2 * numDigs
+        go (n:m:ns) = let !n' = mul16Pow m numDigs1 + n in n' : go ns
+        go ns = ns
+
+    mul16Pow :: Natural -> Int -> Natural
+    mul16Pow x p = unsafeShiftL x (4 * p)
+#endif
 
 -----------------------------
 -- Parsing decimal Naturals
@@ -282,9 +320,10 @@ finishHex !ld (NatParseState acc0 len0 ns0) = case ns0 of
 --
 -- The obvious foldl approach is O(n^2) for n digits. The combine approach
 -- performs O(n/2^i) multiplications of size O(2^i), for i in [0..log_2(n)].
--- If multiplication is O(n^k), this is also O(n^k). We have k < 2,
--- thanks to subquadratic multiplication of GMP-backed Naturals:
--- https://gmplib.org/manual/Multiplication-Algorithms.
+-- If multiplication is O(n^k), this is also O(n^k).
+--
+-- On GHC, we have k < 2, thanks to subquadratic multiplication of GMP-backed
+-- Naturals: https://gmplib.org/manual/Multiplication-Algorithms.
 --
 -- For reference, here's how GMP converts any base (including 10) to a natural
 -- using broadly the same approach.
@@ -311,6 +350,7 @@ finishDec !ld (NatParseState acc0 len0 ns0) = combine acc0 len0 ns0
         go n (WCons m (WCons n1 ns1)) =
           let !n' = w2n m * safeBaseDec + w2n n in n' : go n1 ns1
 
+    combine1 :: Natural -> [Natural] -> Natural
     combine1 _ [n] = n
     combine1 base ns1 = combine1 base1 (go ns1)
       where
@@ -412,7 +452,7 @@ pow10 p = case p of
   18 -> 1000000000000000000
   19 -> 10000000000000000000
 #endif
-  _ -> errorWithoutStackTrace "Regex.Internal.Int.pow10: p too large"
+  _ -> error "Regex.Internal.Int.pow10: p too large"
 #else
 #error "unsupported word size"
 #endif

src/Regex/Internal/Parser.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE GADTs #-}
 {-# LANGUAGE RankNTypes #-}
@@ -32,10 +33,13 @@ import Control.Monad.Trans.State.Strict
   ( State, StateT, evalState, evalStateT, execState, gets, modify', state)
 import Control.Monad.Fix (mfix)
 import Data.Maybe (isJust)
+import qualified Data.Foldable as F
+import qualified Data.Traversable as T
+#ifdef __GLASGOW_HASKELL__
 import Data.Primitive.SmallArray
   (SmallArray, emptySmallArray, smallArrayFromList)
-import qualified Data.Foldable as F
 import qualified GHC.Exts as X
+#endif
 
 import Regex.Internal.Regex (RE(..), Strictness(..), Greediness(..))
 import Regex.Internal.Unique (Unique(..), UniqueSet)
@@ -98,7 +102,7 @@ compileToParser re = case re of
     let (re1,re2,res) = gatherAlts re01 re02
     p1 <- compileToParser re1
     p2 <- compileToParser re2
-    ps <- traverse compileToParser res
+    ps <- T.traverse compileToParser res
     pure $ PAlt u p1 p2 (smallArrayFromList ps)
   RFold st gr f z re1 -> do
     u <- nxtU
@@ -128,7 +132,7 @@ compileToNode a re0 = go re0 (NAccept a)
             (re1,re2,res) = gatherAlts re01 re02
         n1 <- go re1 nxt1
         n2 <- go re2 nxt1
-        ns <- traverse (flip go nxt1) res
+        ns <- T.traverse (flip go nxt1) res
         pure $ NAlt n1 n2 (smallArrayFromList ns)
       RFold _ gr _ _ re1 -> goMany gr re1 nxt
       RMany _ _ _ _ re1 -> goMany Greedy re1 nxt
@@ -145,10 +149,10 @@ compileToNode a re0 = go re0 (NAccept a)
 gatherAlts :: RE c a -> RE c a -> (RE c a, RE c a, [RE c a])
 gatherAlts re01 re02 = case go re01 (go re02 []) of
   re11:re12:res -> (re11, re12, res)
-  _ -> errorWithoutStackTrace "Regex.Internal.Parser.gatherAlts: impossible"
+  _ -> error "Regex.Internal.Parser.gatherAlts: impossible"
   where
-    go (RAlt re1 re2) = go re1 . go re2
-    go re = (re:)
+    go (RAlt re1 re2) acc = go re1 (go re2 acc)
+    go re acc = re:acc
 
 --------------------
 -- Compile bounded
@@ -414,7 +418,11 @@ type Foldr f a = forall b. (a -> b -> b) -> b -> f -> b
 parseFoldr :: Foldr f c -> Parser c a -> f -> Maybe a
 parseFoldr fr = \p xs -> prepareParser p >>= fr f finishParser xs
   where
-    f c k = X.oneShot (\ !ps -> stepParser ps c >>= k)
+    f c k =
+#ifdef __GLASGOW_HASKELL__
+      X.oneShot
+#endif
+        (\ !ps -> stepParser ps c >>= k)
 {-# INLINE parseFoldr #-}
 
 -- | \(O(mn \log m)\). Run a parser given a \"@next@\" action.
@@ -481,6 +489,20 @@ unlessM mb mx = do
   b <- mb
   if b then pure () else mx
 
+-----------------
+-- Array compat
+-----------------
+
+#ifndef __GLASGOW_HASKELL__
+type SmallArray = []
+
+emptySmallArray :: SmallArray a
+emptySmallArray = []
+
+smallArrayFromList :: [a] -> SmallArray a
+smallArrayFromList = id
+#endif
+
 ----------
 -- Notes
 ----------

src/Regex/Internal/Regex.hs

@@ -51,6 +51,7 @@ import Control.Monad (void)
 import Data.Functor.Classes (Eq1(..), Ord1(..), Show1(..), showsUnaryWith)
 import Data.Semigroup (Semigroup(..))
 import qualified Data.Foldable as F
+import qualified Data.Traversable as T
 
 ---------------------------------
 -- RE and constructor functions
@@ -96,7 +97,7 @@ data RE c a where
   RPure   :: a -> RE c a
   RLiftA2 :: !Strictness -> !(a1 -> a2 -> a) -> !(RE c a1) -> !(RE c a2) -> RE c a
   REmpty  :: RE c a
-  RAlt    :: !(RE c a) -> !(RE c a) -> (RE c a)
+  RAlt    :: !(RE c a) -> !(RE c a) -> RE c a
   RFold   :: !Strictness -> !Greediness -> !(a -> a1 -> a) -> a -> !(RE c a1) -> RE c a
   RMany   :: !(a1 -> a) -> !(a2 -> a) -> !(a2 -> a1 -> a2) -> !a2 -> !(RE c a1) -> RE c a -- Strict and greedy implicitly
 
@@ -128,13 +129,13 @@ instance Alternative (RE c) where
 -- | @(<>)@ = @liftA2 (<>)@
 instance Semigroup a => Semigroup (RE c a) where
   (<>) = Ap.liftA2 (<>)
-  sconcat = fmap sconcat . sequenceA
+  sconcat = fmap sconcat . T.sequenceA
   {-# INLINE sconcat #-}
 
 -- | @mempty@ = @pure mempty@
 instance Monoid a => Monoid (RE c a) where
   mempty = pure mempty
-  mconcat = fmap mconcat . sequenceA
+  mconcat = fmap mconcat . T.sequenceA
   {-# INLINE mconcat #-}
 -- Use the underlying type's sconcat/mconcat because it may be more efficient
 -- than the default right-associative definition.
@@ -217,7 +218,7 @@ instance Functor Many where
     Repeat x -> Repeat (f x)
     Finite xs -> Finite (map f xs)
 
-instance Foldable Many where
+instance F.Foldable Many where
   foldr f z m = case m of
     Repeat x -> let r = f x r in r
     Finite xs -> foldr f z xs