path: root/pkgs/development/compilers/microhs/patches/hugs.patch

This patch is based on https://github.com/augustss/MicroHs/pull/429
If you need to update it, rebase the above PR onto the new version's tag.

diff --git a/hugs/Data/Semigroup.hs b/hugs/Data/Semigroup.hs
index b7360013..eab8c48d 100644
--- a/hugs/Data/Semigroup.hs
+++ b/hugs/Data/Semigroup.hs
@@ -18,11 +18,11 @@ class Semigroup a where
     | otherwise = f x0 y0
     where
       f x y
-        | even y == 0 = f (x <> x) (y `quot` 2)
+        | even y = f (x <> x) (y `quot` 2)
         | y == 1 = x
         | otherwise = g (x <> x) (y `quot` 2) x
       g x y z
-        | even y == 0 = g (x <> x) (y `quot` 2) z
+        | even y = g (x <> x) (y `quot` 2) z
         | y == 1 = x <> z
         | otherwise = g (x <> x) (y `quot` 2) (x <> z)
 
diff --git a/hugs/Data/String.hs b/hugs/Data/String.hs
new file mode 100644
index 00000000..1de782d3
--- /dev/null
+++ b/hugs/Data/String.hs
@@ -0,0 +1,17 @@
+module Data.String(
+  IsString(..),
+  String,
+  lines, unlines,
+  words, unwords,
+  ) where
+
+import qualified Data.ByteString.Char8 as BS8
+
+class IsString a where
+  fromString :: String -> a
+
+instance IsString [Char] where
+  fromString s = s
+
+instance IsString BS8.ByteString where
+  fromString = BS8.pack
diff --git a/hugs/Data/Text.hs b/hugs/Data/Text.hs
index fbd1c731..75f8e829 100644
--- a/hugs/Data/Text.hs
+++ b/hugs/Data/Text.hs
@@ -8,6 +8,7 @@ module Data.Text(
   null,
   head,
   tail,
+  cons,
   uncons,
   ) where
 import Prelude hiding(head, tail, null)
@@ -64,6 +65,9 @@ head (T t) = Prelude.head t
 tail :: Text -> Text
 tail (T t) = T (Prelude.tail t)
 
+cons :: Char -> Text -> Text
+cons c (T t) = T (c : t)
+
 uncons :: Text -> Maybe (Char, Text)
 uncons t | null t    = Nothing
          | otherwise = Just (head t, tail t)
diff --git a/hugs/MHSPrelude.hs b/hugs/MHSPrelude.hs
index cb6b36f6..cb47e041 100644
--- a/hugs/MHSPrelude.hs
+++ b/hugs/MHSPrelude.hs
@@ -4,10 +4,11 @@ module MHSPrelude(
   module Prelude,
   module MHSPrelude,
 --  module Control.Monad.Fail,
-  module Control.Arrow,
+  -- Exporting these with 'module Control.Arrow' does not work
+  first, second,
   module Data.Monoid,
   module Data.Semigroup,
-  (<$>), Applicative(..), (*>),
+  (<$>), Applicative(..), (*>), (<*), (>=>), (<=<)
   ) where
 import Hugs.Prelude()
 import Prelude hiding(fail)
@@ -16,6 +17,7 @@ import Control.Arrow(first, second)
 import Control.Applicative
 import Control.Exception(Exception, try)
 --import Control.Monad.Fail
+import Data.Int
 import Data.List
 import Data.Maybe
 import Data.Monoid
@@ -55,6 +57,12 @@ spanEnd p xs = (dropWhileEnd p xs, takeWhileEnd p xs)
 breakEnd :: (a -> Bool) -> [a] -> ([a], [a])
 breakEnd p = spanEnd (not . p)
 
+subsequences :: [a] -> [[a]]
+subsequences xs = [] : sub xs
+  where sub []     = []
+        sub (x:xs) = [x] : foldr f [] (sub xs)
+          where f ys r = ys : (x : ys) : r
+
 ------- Version --------
 
 makeVersion :: [Int] -> Version
@@ -193,6 +201,7 @@ force :: (NFData a) => a -> a
 force x = x `deepseq` x
 
 instance NFData Int
+instance NFData Int64
 instance NFData Word
 instance NFData Float
 instance NFData Double
@@ -229,3 +238,11 @@ instance NFData MD5CheckSum
 
 class HasCallStack
 instance HasCallStack
+
+(<=<) :: forall m a b c . Monad m => (b -> m c) -> (a -> m b) -> (a -> m c)
+f <=< g = \ a -> do
+  b <- g a
+  f b
+
+(>=>) :: forall m a b c . Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)
+(>=>) = flip (<=<)
diff --git a/src/MicroHs/Compile.hs b/src/MicroHs/Compile.hs
index ddec7993..643319aa 100644
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -123,12 +123,17 @@ compile flags nm ach = do
   return ((tModuleName cm, concatMap tBindingsOf $ cachedModules ch), syms, ch)
 
 -- Compile a module for the interactive system
-compileInteractive :: Flags -> EModule -> CM (TModule [LDef], Symbols, TCState)
-compileInteractive flags mdl = do
-  ((dmdl, syms, _, _, _), tcstate) <- compileModuleP flags ImpNormal mdl
+compileInteractive :: Flags -> EModule -> Maybe TCState -> CM (TModule [LDef], Symbols, TCState)
+compileInteractive flags mdl mtcstate = do
+  ((dmdl, syms, _, _, _), tcstate') <- compile
+    flags ImpNormal mdl
   loadBoots flags
   loadDependencies flags
-  return (dmdl, syms, tcstate)
+  return (dmdl, syms, tcstate')
+  where
+    compile = case mtcstate of
+      Nothing -> compileModuleP
+      Just tcstate -> compileModuleP' (\flags _ impt aimps mdl -> typeCheck' flags impt (map filterImports aimps) mdl tcstate)
 
 -- Compile a module with the given name.
 -- If the module has already been compiled, return the cached result.
@@ -233,7 +238,12 @@ compileModule flags impt mn pathfn file = do
   return (cmdl, syms, tThis + tImp)
 
 compileModuleP :: Flags -> ImpType -> EModule -> CM ((TModule [LDef], Symbols, [(ImpType, IdentModule)], Time, Time), TCState)
-compileModuleP flags impt mdl@(EModule _ _ defs) = do
+compileModuleP = compileModuleP' typeCheck
+
+compileModuleP'
+  :: (Flags -> GlobTables -> ImpType -> [(ImportSpec, TModule [LDef])] -> EModule -> (TModule [EDef], GlobTables, Symbols, TCState))
+  -> Flags -> ImpType -> EModule -> CM ((TModule [LDef], Symbols, [(ImpType, IdentModule)], Time, Time), TCState)
+compileModuleP' tc flags impt mdl@(EModule _ _ defs) = do
   -- liftIO $ putStrLn $ showEModule mdl
   -- liftIO $ putStrLn $ showEDefs defs
   let
@@ -244,7 +254,7 @@ compileModuleP flags impt mdl@(EModule _ _ defs) = do
   t3 <- liftIO getTimeMilli
   glob <- gets getCacheTables
   let
-    (tmdl, glob', syms, tcstate) = typeCheck flags glob impt (zip specs impMdls) mdl
+    (tmdl, glob', syms, tcstate) = tc flags glob impt (zip specs impMdls) mdl
   modify $ setCacheTables glob'
   dumpIf flags Dtypecheck $
     liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
@@ -258,9 +268,9 @@ compileModuleP flags impt mdl@(EModule _ _ defs) = do
   return ((dmdl, syms, imported, tThis, tImp), tcstate)
 
 compileToCombinators :: TModule [LDef] -> TModule [LDef]
-compileToCombinators dmdl = do
+compileToCombinators dmdl =
   let cmdl = setBindings dmdl [ (i, compileOpt e) | (i, e) <- tBindingsOf dmdl ]
-  seq (rnf cmdl) cmdl  -- This makes execution slower, but speeds up GC
+  in seq (rnf cmdl) cmdl  -- This makes execution slower, but speeds up GC
 
 -- Add implicit imports:
 --   import Prelude
diff --git a/src/MicroHs/Expr.hs b/src/MicroHs/Expr.hs
index 84578594..bd05f1bc 100644
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -57,11 +57,11 @@ module MicroHs.Expr(
   dropForallContext,
   ) where
 import qualified Prelude(); import MHSPrelude hiding ((<>))
+import Data.Int
 import Data.List
 import Data.Maybe
 import MicroHs.Builtin
 import MicroHs.Ident
-import {-# SOURCE #-} MicroHs.TCMonad(TCState)
 import Text.PrettyPrint.HughesPJLite
 
 type IdentModule = Ident
@@ -96,8 +96,6 @@ data EDef
   | Pattern LHS EPat (Maybe [Eqn])
   | StandDeriving DerStrategy Int EConstraint
   | DfltSign Ident EType                      -- only in class declarations
-  -- Only used by interactive system to load a cached TCState to avoid import processing
-  | SetTCState TCState
 --DEBUG  deriving (Show)
 
 instance NFData EDef where
@@ -118,7 +116,6 @@ instance NFData EDef where
   rnf (Pattern a b c) = rnf a `seq` rnf b `seq` rnf c
   rnf (StandDeriving a b c) = rnf a `seq` rnf b `seq` rnf c
   rnf (DfltSign a b) = rnf a `seq` rnf b
-  rnf (SetTCState a) = seq a ()
 
 data ImpType = ImpNormal | ImpBoot
   deriving (Eq)
@@ -900,7 +897,6 @@ ppEDef def =
     Pattern lhs@(i,_) p meqns -> text "pattern" <+> ppLHS lhs <+> text "=" <+> ppExpr p <+> maybe empty (ppWhere (text ";") . (:[]) . Fcn i) meqns
     StandDeriving _s _narg ct -> text "deriving instance" <+> ppEType ct
     DfltSign i t -> text "default" <+> ppIdent i <+> text "::" <+> ppEType t
-    SetTCState _ -> text "SetTCState ..."
 
 ppDerivings :: [Deriving] -> Doc
 ppDerivings = sep . map ppDeriving
diff --git a/src/MicroHs/Interactive.hs b/src/MicroHs/Interactive.hs
index ebb33b43..7b70064a 100644
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -295,11 +295,11 @@ compile file = do
   let mdl@(EModule mn es _) = parseDie pTopModule "" file
   defs <- updateTCStateCache mdl
   (_, tcstate, _) <- gets isCComp
-  let mdl' = EModule mn es (SetTCState tcstate : defs)
+  let mdl' = EModule mn es defs
   flgs <- gets isFlags
   cash <- gets isCache
 --  putStrLnI $ " tryCompile compile " ++ show mdl'
-  ((dmdl, _, tcstate'), _) <- liftIO $ runStateIO (compileInteractive flgs mdl') cash
+  ((dmdl, _, tcstate'), _) <- liftIO $ runStateIO (compileInteractive flgs mdl' $ Just tcstate) cash
   cmdl <- liftIO $ evaluate $ compileToCombinators dmdl
 --  putStrLnI $ " tryCompile dmdl = " ++ (show $ tBindingsOf dmdl)
   return (tBindingsOf cmdl, tcstate')
@@ -398,7 +398,7 @@ updateTCStateCache (EModule mn es ds) = do
     cash <- gets isCache
 --    putStrLnI "*** update tcstate"
     let mdl' = addPreludeImport mdl
-    ((_, syms, tcstate), ch) <- liftIO $ runStateIO (compileInteractive flgs mdl') cash
+    ((_, syms, tcstate), ch) <- liftIO $ runStateIO (compileInteractive flgs mdl' Nothing) cash
     let idmap = translateMap $ concatMap tBindingsOf $ cachedModules ch
 --    putStrLnI $ "*** update isFast " ++ show nImps
     modify $ \ is -> is{ isCComp = (nImps, tcstate, idmap), isCache = ch, isSymbols = syms }
diff --git a/src/MicroHs/Parse.hs b/src/MicroHs/Parse.hs
index 821718a7..6a68a01a 100644
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -791,7 +791,7 @@ pDo = do
     case last ss of
       SThen e ->
         pure $ EDo q [SRec (init ss), SThen e]
-      _ -> fail "mdo"
+      _ -> Control.Monad.Fail.fail "mdo"
    else
     pure (EDo q ss)
 
diff --git a/src/MicroHs/TCMonad.hs-boot b/src/MicroHs/TCMonad.hs-boot
deleted file mode 100644
index f88ad533..00000000
--- a/src/MicroHs/TCMonad.hs-boot
+++ /dev/null
@@ -1,2 +0,0 @@
-module MicroHs.TCMonad where
-data TCState
diff --git a/src/MicroHs/TypeCheck.hs b/src/MicroHs/TypeCheck.hs
index 47f2b461..db7f3527 100644
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -2,7 +2,7 @@
 -- See LICENSE file for full license.
 {-# OPTIONS_GHC -Wno-incomplete-uni-patterns -Wno-unused-imports -Wno-unused-do-bind #-}
 module MicroHs.TypeCheck(
-  typeCheck,
+  typeCheck, typeCheck', filterImports,
   TModule(..), showTModule,
   GlobTables, emptyGlobTables, mergeGlobTables,
   impossible, impossibleShow,
@@ -102,35 +102,34 @@ type Sigma = EType
 type Rho   = EType
 
 typeCheck :: Flags -> GlobTables -> ImpType -> [(ImportSpec, TModule a)] -> EModule -> (TModule [EDef], GlobTables, Symbols, TCState)
-typeCheck flags globs impt aimps (EModule mn exps defs) =
+typeCheck flags globs impt aimps mdl@(EModule mn exps defs) =
 --  trace (unlines $ map (showTModuleExps . snd) aimps) $
-  let
-    imps = map filterImports aimps
-    tc =
-      case defs of
-        SetTCState tcs : _ -> tcs  -- hack to set the saved TCState
-        _ -> mkTCState mn globs imps
-  in case tcRun (tcDefs flags impt defs) tc of
-       (tds, tcs) ->
-         let
-           thisMdl = (mn, mkTModule tds tcs)
-           impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ _ m mm _, tm) <- imps]
-           allMdls = thisMdl : impMdls
-           (texps, vexps) =
-             unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs)) exps
-             where impMap = M.fromListWith (++) [(i, [m]) | (i, m) <- allMdls]
-           fexps = map (tFixDefs . snd) allMdls
-           sexps = synTable tcs
-           dexps = dataTable tcs
-           iexps = instTable tcs
-           ctbl  = classTable tcs
-           dflts = M.fromList $ filter ((`elem` ds) . fst) $ M.toList $ defaults tcs
-                 where ds = [ tyQIdent $ expLookup ti (typeTable tcs) | ExpDefault ti <- exps ]
-         in  ( tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) (concat vexps) dflts tds
-             , GlobTables { gSynTable = sexps, gDataTable = dexps, gClassTable = ctbl, gInstInfo = iexps }
-             , (typeTable tcs, valueTable tcs)
-             , tcs
-             )
+  let imps = map filterImports aimps
+  in typeCheck' flags impt imps mdl $ mkTCState mn globs imps
+
+typeCheck' :: Flags -> ImpType -> [(ImportSpec, TModule a)] -> EModule -> TCState -> (TModule [EDef], GlobTables, Symbols, TCState)
+typeCheck' flags impt imps (EModule mn exps defs) tc =
+  case tcRun (tcDefs flags impt defs) tc of
+    (tds, tcs) ->
+      let
+        thisMdl = (mn, mkTModule tds tcs)
+        impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ _ m mm _, tm) <- imps]
+        allMdls = thisMdl : impMdls
+        (texps, vexps) =
+          unzip $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs)) exps
+          where impMap = M.fromListWith (++) [(i, [m]) | (i, m) <- allMdls]
+        fexps = map (tFixDefs . snd) allMdls
+        sexps = synTable tcs
+        dexps = dataTable tcs
+        iexps = instTable tcs
+        ctbl  = classTable tcs
+        dflts = M.fromList $ filter ((`elem` ds) . fst) $ M.toList $ defaults tcs
+              where ds = [ tyQIdent $ expLookup ti (typeTable tcs) | ExpDefault ti <- exps ]
+      in  ( tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) (concat vexps) dflts tds
+          , GlobTables { gSynTable = sexps, gDataTable = dexps, gClassTable = ctbl, gInstInfo = iexps }
+          , (typeTable tcs, valueTable tcs)
+          , tcs
+          )
 
 -- A hack to force evaluation of errors.
 -- This should be redone to all happen in the T monad.
diff --git a/src/Text/ParserComb.hs b/src/Text/ParserComb.hs
index 5b0e8753..6efd5a3f 100644
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -115,7 +115,7 @@ instance TokenMachine tm t => Alternative (Prsr tm t) where
       r -> r
 
 instance TokenMachine tm t => MonadPlus (Prsr tm t) where
-  mzero = fail "mzero"
+  mzero = F.fail "mzero"
   mplus = (<|>)
 
 satisfy :: forall tm t . TokenMachine tm t => String -> (t -> Bool) -> Prsr tm t t