ref: b4d456d64a98c16a162384ad878503a0bfc3ec16
parent: 754c2a59b0a78f7aa23cc1166b2cfc18d7209bfe
author: Lennart Augustsson <lennart@augustsson.net>
date: Mon Apr 1 13:44:52 EDT 2024
Some support for recursive module using -boot files.
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -97,19 +97,29 @@
Nothing -> do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing " ++ showIdent mn
- mres <- liftIO (readModulePath flags mn)
+ mres <- liftIO (readModulePath flags ".hs" mn)
case mres of
Nothing -> findPkgModule flags mn
Just (pathfn, file) -> do
modify $ addWorking mn
- compileModule flags mn pathfn file
+ compileModule flags ImpNormal mn pathfn file
Just tm -> do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
return (tm, 0)
-compileModule :: Flags -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Time)
-compileModule flags mn pathfn file = do
+compileBootModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+compileBootModule flags mn = do
+ when (verbosityGT flags 0) $
+ liftIO $ putStrLn $ "importing boot " ++ showIdent mn
+ mres <- liftIO (readModulePath flags ".hs-boot" mn)
+ case mres of
+ Nothing -> error $ "boot module not found: " ++ showIdent mn
+ Just (pathfn, file) -> do
+ compileModule flags ImpBoot mn pathfn file
+
+compileModule :: Flags -> ImpType -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Time)
+compileModule flags impt mn pathfn file = do
t1 <- liftIO getTimeMilli
mchksum <- liftIO (md5File pathfn) -- XXX there is a small gap between reading and computing the checksum.
let chksum :: MD5CheckSum
@@ -116,6 +126,8 @@
chksum = fromMaybe undefined mchksum
let pmdl = parseDie pTop pathfn file
mdl@(EModule mnn _ defs) = addPreludeImport pmdl
+ when (verbosityGT flags 3) $
+ liftIO $ putStrLn $ "parsed:\n" ++ show pmdl
-- liftIO $ putStrLn $ showEModule mdl
-- liftIO $ putStrLn $ showEDefs defs
@@ -124,12 +136,14 @@
error $ "module name does not agree with file name: " ++ showIdent mn ++ " " ++ showIdent mnn
let
specs = [ s | Import s <- defs ]
- imported = [ m | ImportSpec _ m _ _ <- specs ]
+ imported = [ (boot, m) | ImportSpec boot _ m _ _ <- specs ]
+ compileImp (ImpNormal, m) = compileModuleCached flags m
+ compileImp (ImpBoot, m) = compileBootModule flags m
t2 <- liftIO getTimeMilli
- (impMdls, its) <- fmap unzip $ mapM (compileModuleCached flags) imported
+ (impMdls, its) <- fmap unzip $ mapM compileImp imported
t3 <- liftIO getTimeMilli
let
- tmdl = typeCheck (zip specs impMdls) mdl
+ tmdl = typeCheck impt (zip specs impMdls) mdl
when (verbosityGT flags 2) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
@@ -146,7 +160,9 @@
"ms (" ++ show tp ++ " + " ++ show tt ++ ")"when (loading flags && mn /= mkIdent "Interactive") $
liftIO $ putStrLn $ "loaded " ++ showIdent mn
- modify $ workToDone (dmdl, imported, chksum)
+ case impt of
+ ImpNormal -> modify $ workToDone (dmdl, map snd imported, chksum)
+ ImpBoot -> return ()
return (dmdl, tp + tt + ts)
addPreludeImport :: EModule -> EModule
@@ -154,13 +170,13 @@
EModule mn es ds'
where ds' = ps' ++ nps
(ps, nps) = partition isImportPrelude ds
- isImportPrelude (Import (ImportSpec _ i _ _)) = i == idPrelude
+ isImportPrelude (Import (ImportSpec _ _ i _ _)) = i == idPrelude
isImportPrelude _ = False
idPrelude = mkIdent "Prelude"
ps' =
case ps of
- [] -> [Import $ ImportSpec False idPrelude Nothing Nothing] -- no Prelude imports, so add 'import Prelude'
- [Import (ImportSpec False _ Nothing (Just (False, [])))] -> [] -- exactly 'import Prelude()', so import nothing
+ [] -> [Import $ ImportSpec ImpNormal False idPrelude Nothing Nothing] -- no Prelude imports, so add 'import Prelude'
+ [Import (ImportSpec ImpNormal False _ Nothing (Just (False, [])))] -> [] -- exactly 'import Prelude()', so import nothing
_ -> ps -- keep the given Prelude imports
-------------------------------------------
@@ -185,7 +201,7 @@
case lookupCacheChksum mn cash of
Nothing -> return () -- no longer in the cache, so just ignore.
Just chksum -> do
- mhdl <- liftIO $ findModulePath flags mn
+ mhdl <- liftIO $ findModulePath flags ".hs" mn
case mhdl of
Nothing ->
-- Cannot find module, so invalidate it
@@ -213,14 +229,15 @@
| otherwise = Nothing
where s = unIdent m
-readModulePath :: Flags -> IdentModule -> IO (Maybe (FilePath, String))
-readModulePath flags mn | Just fn <- getFileName mn = do
+readModulePath :: Flags -> String -> IdentModule -> IO (Maybe (FilePath, String))
+readModulePath flags suf mn | Just fn <- getFileName mn = do
mh <- openFileM fn ReadMode
case mh of
Nothing -> errorMessage (getSLoc mn) $ "File not found: " ++ show fn
Just h -> readRest fn h
+
| otherwise = do
- mh <- findModulePath flags mn
+ mh <- findModulePath flags suf mn
case mh of
Nothing -> return Nothing
Just (fn, h) -> readRest fn h
@@ -237,10 +254,10 @@
moduleToFile :: IdentModule -> FilePath
moduleToFile mn = map (\ c -> if c == '.' then '/' else c) (unIdent mn)
-findModulePath :: Flags -> IdentModule -> IO (Maybe (FilePath, Handle))
-findModulePath flags mn = do
+findModulePath :: Flags -> String -> IdentModule -> IO (Maybe (FilePath, Handle))
+findModulePath flags suf mn = do
let
- fn = moduleToFile mn ++ ".hs"
+ fn = moduleToFile mn ++ suf
openFilePath (paths flags) fn
openFilePath :: [FilePath] -> FilePath -> IO (Maybe (FilePath, Handle))
--- a/src/MicroHs/CompileCache.hs
+++ b/src/MicroHs/CompileCache.hs
@@ -1,6 +1,6 @@
module MicroHs.CompileCache(
CModule,
- Cache, addWorking, emptyCache, deleteFromCache, workToDone,
+ Cache, addWorking, emptyCache, deleteFromCache, workToDone, workPop,
cachedModules, lookupCache, lookupCacheChksum, getImportDeps,
addPackage, getCompMdls, getPkgs,
saveCache, loadCached,
@@ -60,6 +60,9 @@
workToDone :: CModule -> Cache -> Cache
workToDone (t, i, k) c@(Cache{ working = mn:ws, cache = m }) = c{ working = ws, cache = M.insert mn (CompMdl t i k) m }workToDone _ _ = undefined
+
+workPop :: Cache -> Cache
+workPop c = c{ working = drop 1 (working c) }cachedModules :: Cache -> [TModule [LDef]]
cachedModules = map tModuleOf . M.elems . cache
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -4,6 +4,7 @@
ExportItem(..),
ImportSpec(..),
ImportItem(..),
+ ImpType(..),
EDef(..), showEDefs,
Expr(..), eLam, eEqn, eEqns, showExpr, eqExpr,
Listish(..),
@@ -81,7 +82,10 @@
| Default [EType]
--DEBUG deriving (Show)
-data ImportSpec = ImportSpec Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem])) -- first Bool indicates 'qualified', second 'hiding'
+data ImpType = ImpNormal | ImpBoot
+ deriving (Eq)
+
+data ImportSpec = ImportSpec ImpType Bool Ident (Maybe Ident) (Maybe (Bool, [ImportItem])) -- first Bool indicates 'qualified', second 'hiding'
--DEBUG deriving (Show)
data ImportItem
@@ -586,7 +590,9 @@
Fcn i eqns -> ppEqns (ppIdent i) (text "=") eqns
Sign is t -> hsep (punctuate (text ",") (map ppIdent is)) <+> text "::" <+> ppEType t
KindSign i t -> text "type" <+> ppIdent i <+> text "::" <+> ppEKind t
- Import (ImportSpec q m mm mis) -> text "import" <+> (if q then text "qualified" else empty) <+> ppIdent m <> text (maybe "" ((" as " ++) . unIdent) mm) <>+ Import (ImportSpec b q m mm mis) -> text "import" <+>
+ (if b == ImpBoot then text "{-# SOURCE #-}" else empty) <+>+ (if q then text "qualified" else empty) <+> ppIdent m <> text (maybe "" ((" as " ++) . unIdent) mm) <>case mis of
Nothing -> empty
Just (h, is) -> text (if h then " hiding" else "") <> parens (hsep $ punctuate (text ",") (map ppImportItem is))
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -25,6 +25,7 @@
| TError SLoc String -- lexical error
| TBrace SLoc -- {n} in the Haskell report| TIndent SLoc -- <n> in the Haskell report
+ | TPragma SLoc String -- a {-# PRAGMA #-}| TEnd
| TRaw [Token]
deriving (Show)
@@ -41,6 +42,7 @@
showToken (TError _ s) = s
showToken (TBrace _) = "TBrace"
showToken (TIndent _) = "TIndent"
+showToken (TPragma _ s) = "{-# " ++ s ++ " #-}"showToken TEnd = "EOF"
showToken (TRaw _) = "TRaw"
@@ -67,7 +69,7 @@
lex loc ('\n':cs) = tIndent (lex (incrLine loc) cs) lex loc ('\r':cs) = lex loc cs lex loc ('\t':cs) = lex (tabCol loc) cs -- TABs are a dubious feature, but easy to support-lex loc ('{':'-':cs) = skipNest (addCol loc 2) 1 cs+lex loc ('{':'-':cs) = nested (addCol loc 2) cs lex loc ('-':'-':cs) | isComm rs = skipLine (addCol loc $ 2+length ds) cswhere
(ds, rs) = span (== '-') cs
@@ -100,6 +102,10 @@
lex loc (d:_) = [TError loc $ "Unrecognized input: " ++ show d]
lex _ [] = []
+nested :: SLoc -> [Char] -> [Token]
+nested loc ('#':cs) = pragma loc cs+nested loc cs = skipNest loc 1 cs
+
hexNumber :: SLoc -> String -> [Token]
hexNumber loc cs =
case span isHexDigit cs of
@@ -256,10 +262,20 @@
tokensLoc (TError loc _ :_) = loc
tokensLoc (TBrace loc :_) = loc
tokensLoc (TIndent loc :_) = loc
+tokensLoc (TPragma loc _ :_) = loc
tokensLoc _ = mkLocEOF
readBase :: Integer -> String -> Integer
readBase b = foldl (\ r c -> r * b + toInteger (digitToInt c)) 0
+
+-- XXX This is a pretty hacky recognition of pragmas.
+pragma :: SLoc -> [Char] -> [Token]
+pragma loc cs =
+ let as = map toUpper $ takeWhile isAlpha $ dropWhile isSpace cs
+ skip = skipNest loc 1 ('#':cs)+ in case as of
+ "SOURCE" -> TPragma loc as : skip
+ _ -> skip
-- | This is the magical layout resolver, straight from the Haskell report.
-- https://www.haskell.org/onlinereport/haskell2010/haskellch10.html#x17-17800010.3
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -273,6 +273,12 @@
is (TIdent _ [] s) = kw == s
is _ = False
+pPragma :: String -> P ()
+pPragma kw = () <$ satisfy kw is
+ where
+ is (TPragma _ s) = kw == s
+ is _ = False
+
pBraces :: forall a . P a -> P a
pBraces p =
do
@@ -373,7 +379,8 @@
pImportSpec =
let
pQua = (True <$ pKeyword "qualified") <|< pure False
- in ImportSpec <$> pQua <*> pUQIdentA <*> eoptional (pKeyword "as" *> pUQIdent) <*>
+ pSource = (ImpBoot <$ pPragma "SOURCE") <|< pure ImpNormal
+ in ImportSpec <$> pSource <*> pQua <*> pUQIdentA <*> eoptional (pKeyword "as" *> pUQIdent) <*>
eoptional ((,) <$> ((True <$ pKeyword "hiding") <|> pure False) <*> pParens (esepEndBy pImportItem (pSpec ',')))
pImportItem :: P ImportItem
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -152,17 +152,17 @@
--type Tau = EType
type Rho = EType
-typeCheck :: forall a . [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
-typeCheck aimps (EModule mn exps defs) =
+typeCheck :: forall a . ImpType -> [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
+typeCheck impt aimps (EModule mn exps defs) =
-- trace (unlines $ map (showTModuleExps . snd) aimps) $
let
imps = map filterImports aimps
(fs, ts, ss, cs, is, vs, as) = mkTables imps
- in case tcRun (tcDefs defs) (initTC mn fs ts ss cs is vs as) of
+ in case tcRun (tcDefs impt defs) (initTC mn fs ts ss cs is vs as) of
(tds, tcs) ->
let
thisMdl = (mn, mkTModule tds tcs)
- impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ m mm _, tm) <- imps]
+ impMdls = [(fromMaybe m mm, tm) | (ImportSpec _ _ m mm _, tm) <- imps]
impMap = M.fromList [(i, m) | (i, m) <- thisMdl : impMdls]
(texps, cexps, vexps) =
unzip3 $ map (getTVExps impMap (typeTable tcs) (valueTable tcs) (assocTable tcs) (classTable tcs)) exps
@@ -185,8 +185,8 @@
vseq (ValueExport _ e:xs) = e `seq` vseq xs
filterImports :: forall a . (ImportSpec, TModule a) -> (ImportSpec, TModule a)
-filterImports it@(ImportSpec _ _ _ Nothing, _) = it
-filterImports (imp@(ImportSpec _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
+filterImports it@(ImportSpec _ _ _ _ Nothing, _) = it
+filterImports (imp@(ImportSpec _ _ _ _ (Just (hide, is))), TModule mn fx ts ss cs ins vs a) =
let
keep x xs = elem x xs /= hide
ivs = [ i | ImpValue i <- is ]
@@ -327,11 +327,11 @@
allValues :: ValueTable
allValues =
let
- usyms (ImportSpec qual _ _ _, TModule _ _ tes _ _ _ ves _) =
+ usyms (ImportSpec _ qual _ _ _, TModule _ _ tes _ _ _ ves _) =
if qual then [] else
[ (i, [e]) | ValueExport i e <- ves, not (isInstId i) ] ++
[ (i, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs ]
- qsyms (ImportSpec _ _ mas _, TModule mn _ tes _ cls _ ves _) =
+ qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes _ cls _ ves _) =
let m = fromMaybe mn mas in
[ (v, [e]) | ValueExport i e <- ves, let { v = qualIdent m i } ] ++ [ (v, [e]) | TypeExport _ _ cs <- tes, ValueExport i e <- cs, let { v = qualIdent m i } ] ++@@ -344,9 +344,9 @@
allTypes :: TypeTable
allTypes =
let
- usyms (ImportSpec qual _ _ _, TModule _ _ tes _ _ _ _ _) =
+ usyms (ImportSpec _ qual _ _ _, TModule _ _ tes _ _ _ _ _) =
if qual then [] else [ (i, [e]) | TypeExport i e _ <- tes ]
- qsyms (ImportSpec _ _ mas _, TModule mn _ tes _ _ _ _ _) =
+ qsyms (ImportSpec _ _ _ mas _, TModule mn _ tes _ _ _ _ _) =
let m = fromMaybe mn mas in
[ (qualIdent m i, [e]) | TypeExport i e _ <- tes ]
in stFromList (concatMap usyms mdls) (concatMap qsyms mdls)
@@ -357,7 +357,7 @@
allAssocs :: AssocTable
allAssocs =
let
- assocs (ImportSpec _ _ mas _, TModule mn _ tes _ _ _ _ _) =
+ assocs (ImportSpec _ _ _ mas _, TModule mn _ tes _ _ _ _ _) =
let
m = fromMaybe mn mas
in [ (qualIdent m i, [qualIdent m a | ValueExport a _ <- cs]) | TypeExport i _ cs <- tes ]
@@ -922,8 +922,8 @@
putTypeTable venv
return a
-tcDefs :: [EDef] -> T [EDef]
-tcDefs ds = do
+tcDefs :: ImpType -> [EDef] -> T [EDef]
+tcDefs impt ds = do
-- traceM ("tcDefs 1:\n" ++ showEDefs ds)mapM_ tcAddInfix ds
dst <- tcDefsType ds
@@ -931,8 +931,12 @@
mapM_ addTypeSyn dst
dst' <- tcExpand dst
-- traceM ("tcDefs 3:\n" ++ showEDefs dst')- setDefault dst'
- tcDefsValue dst'
+ case impt of
+ ImpNormal -> do
+ setDefault dst'
+ tcDefsValue dst'
+ ImpBoot ->
+ return dst'
setDefault :: [EDef] -> T ()
setDefault defs = do
--- a/tests/Makefile
+++ b/tests/Makefile
@@ -61,6 +61,7 @@
$(TMHS) ParseInd && $(EVAL) > ParseInd.out && diff ParseInd.ref ParseInd.out
$(TMHS) Infer && $(EVAL) > Infer.out && diff Infer.ref Infer.out
$(TMHS) Enum && $(EVAL) > Enum.out && diff Enum.ref Enum.out
+ $(TMHS) RecMdl && $(EVAL) > RecMdl.out && diff RecMdl.ref RecMdl.out
errtest:
sh errtester.sh < errmsg.test
--- /dev/null
+++ b/tests/RecMdl.hs
@@ -1,0 +1,12 @@
+module RecMdl where
+import RecMdlA
+
+h :: Int -> Int
+h x = x + 100
+
+f :: Int -> Int
+f x = g (x+1)
+
+main :: IO ()
+main = do
+ print (f 10)
--- /dev/null
+++ b/tests/RecMdl.hs-boot
@@ -1,0 +1,2 @@
+module RecMdl where
+h :: Int -> Int
--- /dev/null
+++ b/tests/RecMdl.ref
@@ -1,0 +1,1 @@
+222
--- /dev/null
+++ b/tests/RecMdlA.hs
@@ -1,0 +1,5 @@
+module RecMdlA where
+import {-# SOURCE #-} RecMdl+
+g :: Int -> Int
+g x = h x * 2
--
⑨