ref: faba2aba722927e446627096648b34420619279d
parent: a7c4958176ee0042ac9e88cf8add22aa67ffe706
author: Lennart Augustsson <lennart@augustsson.net>
date: Wed Apr 3 08:16:37 EDT 2024
Refactor so compilation returns the last symbol table. Also refactor the interactive system a little.
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -33,6 +33,7 @@
import MicroHs.Package
import MicroHs.Parse
import MicroHs.StateIO
+import MicroHs.SymTab
import MicroHs.TypeCheck
import Compat
import MicroHs.Instances() -- for ghc
@@ -46,9 +47,9 @@
-- Compile the module with the given name, starting with the given cache.
-- Return the "compiled module" and the resulting cache.
-compileCacheTop :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [(Ident, Exp)]), Cache)
+compileCacheTop :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [(Ident, Exp)]), Symbols, Cache)
compileCacheTop flags mn ch = do
- res@((_, ds), _) <- compile flags mn ch
+ res@((_, ds), _, _) <- compile flags mn ch
when (verbosityGT flags 4) $
putStrLn $ "combinators:\n" ++ showLDefs ds
return res
@@ -68,7 +69,7 @@
putStrLn $ "Loading saved cache " ++ show mhsCacheName
validateCache flags cash
-compile :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [LDef]), Cache)
+compile :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [LDef]), Symbols, Cache)
compile flags nm ach = do
let comp = do
--XXX modify $ addBoot $ mkIdent "Control.Exception.Internal" -- the compiler generates references to this module
@@ -85,16 +86,16 @@
loadBoots
loadDependencies flags
return r
- ((cm, t), ch) <- runStateIO comp ach
+ ((cm, syms, t), ch) <- runStateIO comp ach
when (verbosityGT flags 0) $
putStrLn $ "total import time " ++ padLeft 6 (show t) ++ "ms"
- return ((tModuleName cm, concatMap bindingsOf $ cachedModules ch), ch)
+ return ((tModuleName cm, concatMap bindingsOf $ cachedModules ch), syms, ch)
-- Compile a module with the given name.
-- If the module has already been compiled, return the cached result.
-- If the module has not been compiled, first try to find a source file.
-- If there is no source file, try loading a package.
-compileModuleCached :: Flags -> ImpType -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+compileModuleCached :: Flags -> ImpType -> IdentModule -> StateIO Cache (TModule [LDef], Symbols, Time)
compileModuleCached flags impt mn = do
cash <- get
case lookupCache mn cash of
@@ -113,9 +114,12 @@
Just tm -> do
when (verbosityGT flags 1) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
- return (tm, 0)
+ return (tm, noSymbols, 0)
-compileBootModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+noSymbols :: Symbols
+noSymbols = (stEmpty, stEmpty)
+
+compileBootModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Symbols, Time)
compileBootModule flags mn = do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing boot " ++ showIdent mn
@@ -126,7 +130,7 @@
modify $ addBoot mn
compileModule flags ImpBoot mn pathfn file
-compileModule :: Flags -> ImpType -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Time)
+compileModule :: Flags -> ImpType -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Symbols, 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.
@@ -146,11 +150,11 @@
specs = [ s | Import s <- defs ]
imported = [ (boot, m) | ImportSpec boot _ m _ _ <- specs ]
t2 <- liftIO getTimeMilli
- (impMdls, tImps) <- fmap unzip $ mapM (uncurry $ compileModuleCached flags) imported
+ (impMdls, _, tImps) <- fmap unzip3 $ mapM (uncurry $ compileModuleCached flags) imported
t3 <- liftIO getTimeMilli
let
- tmdl = typeCheck impt (zip specs impMdls) mdl
+ (tmdl, syms) = typeCheck impt (zip specs impMdls) mdl
when (verbosityGT flags 3) $
liftIO $ putStrLn $ "type checked:\n" ++ showTModule showEDefs tmdl ++ "-----\n"
let
@@ -181,7 +185,7 @@
ImpNormal -> modify $ workToDone (cmdl, map snd imported, chksum)
ImpBoot -> return ()
- return (cmdl, tTot + tImp)
+ return (cmdl, syms, tTot + tImp)
addPreludeImport :: EModule -> EModule
addPreludeImport (EModule mn es ds) =
@@ -321,7 +325,7 @@
packageTxtSuffix :: String
packageTxtSuffix = ".txt"
-findPkgModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+findPkgModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Symbols, Time)
findPkgModule flags mn = do
let fn = moduleToFile mn ++ packageTxtSuffix
mres <- liftIO $ openFilePath (pkgPath flags) fn
@@ -334,7 +338,7 @@
cash <- get
case lookupCache mn cash of
Nothing -> error $ "package does not contain module " ++ pkg ++ " " ++ showIdent mn
- Just t -> return (t, 0)
+ Just t -> return (t, noSymbols, 0)
Nothing ->
errorMessage (getSLoc mn) $
"Module not found: " ++ show mn ++
--- a/src/MicroHs/Interactive.hs
+++ b/src/MicroHs/Interactive.hs
@@ -9,14 +9,19 @@
import MicroHs.Ident(mkIdent, Ident)
import MicroHs.Parse
import MicroHs.StateIO
-import MicroHs.SymTab(Entry(..))
+import MicroHs.SymTab(Entry(..), stEmpty)
import MicroHs.Translate
-import MicroHs.TypeCheck(ValueExport(..), TypeExport(..), TModule(..))
+import MicroHs.TypeCheck(ValueExport(..), TypeExport(..), TModule(..), Symbols)
import Unsafe.Coerce
import System.Console.SimpleReadline
import MicroHs.Instances(compiledWithGHC)
-type IState = (String, Flags, Cache)
+data IState = IState {+ isLines :: String,
+ isFlags :: Flags,
+ isCache :: Cache,
+ isSymbols :: Symbols
+ }
type I a = StateIO IState a
@@ -27,9 +32,12 @@
putStrLn "Welcome to interactive MicroHs!"
let flags' = flags{ loading = True }cash <- getCached flags'
- _ <- runStateIO start (preamble, flags', cash)
+ _ <- runStateIO start $ IState preamble flags' cash noSymbols
return ()
+noSymbols :: Symbols
+noSymbols = (stEmpty, stEmpty)
+
preamble :: String
preamble = "module " ++ interactiveName ++ "(module " ++ interactiveName ++
") where\nimport Prelude\nimport System.IO.PrintOrRun\ndefault (Integer, Double, String, ())\n"
@@ -77,13 +85,14 @@
[ ("quit", const $ return False) , ("clear", const $ doupdateLines (const preamble)
- modify $ \ (ls, flgs, _) -> (ls, flgs, emptyCache)
+ modify $ \ is -> is{ isCache = emptyCache, isSymbols = noSymbols }return True
)
, ("reload", const $ do- (ls, flgs, cash) <- get
+ flgs <- gets isFlags
+ cash <- gets isCache
cash' <- liftIO $ validateCache flgs cash
- put (ls, flgs, cash')
+ modify $ \ is -> is{ isCache = cash' }reload
return True
)
@@ -107,7 +116,7 @@
reload :: I ()
reload = do
- (ls, _, _) <- get
+ ls <- gets isLines
rld <- tryCompile ls -- reload modules right away
case rld of
Left msg -> liftIO $ err msg
@@ -128,11 +137,14 @@
\"
updateLines :: (String -> String) -> I ()
-updateLines f = modify $ \ (ls, flgs, cash) -> (f ls, flgs, cash)
+updateLines f = modify $ \ is -> is{ isLines = f (isLines is) }updateCache :: (Cache -> Cache) -> I ()
-updateCache f = modify $ \ (ls, flgs, cash) -> (ls, flgs, f cash)
+updateCache f = modify $ \ is -> is{ isCache = f (isCache is) }+setSyms :: Symbols -> I ()
+setSyms syms = modify $ \ is -> is{ isSymbols = syms }+
interactiveName :: String
interactiveName = "Interactive"
@@ -169,7 +181,7 @@
oneline :: String -> I ()
oneline line = do
- (ls, _, _) <- get
+ ls <- gets isLines
let lls = ls ++ line ++ "\n"
def = do
defTest <- tryCompile lls
@@ -196,13 +208,15 @@
tryCompile :: String -> I (Either SomeException [LDef])
tryCompile file = do
updateCache (deleteFromCache interactiveId)
- (_, flgs, cash) <- get
+ flgs <- gets isFlags
+ cash <- gets isCache
liftIO $ writeFile (interactiveName ++ ".hs") file
res <- liftIO $ try $ compileCacheTop flgs interactiveId cash
case res of
Left e -> return (Left e)
- Right ((_, m), cash') -> do
+ Right ((_, m), syms, cash') -> do
updateCache (const cash')
+ setSyms syms
return (Right m)
evalExpr :: [LDef] -> I ()
@@ -221,11 +235,11 @@
showType :: String -> I ()
showType line = do
- (ls, _, _) <- get
+ ls <- gets isLines
res <- tryCompile (ls ++ "\n" ++ mkIt line)
case res of
Right _ -> do
- (_, _, cash) <- get
+ cash <- gets isCache
let t = getTypeInCache cash (mkIdent itName)
liftIO $ putStrLn $ showEType t
Left e ->
@@ -233,11 +247,11 @@
showKind :: String -> I ()
showKind line = do
- (ls, _, _) <- get
+ ls <- gets isLines
res <- tryCompile (ls ++ "\n" ++ mkTypeIt line)
case res of
Right _ -> do
- (_, _, cash) <- get
+ cash <- gets isCache
let t = getKindInCache cash (mkIdent itTypeName)
liftIO $ putStrLn $ showEType t
Left e ->
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -108,18 +108,15 @@
mainCompile :: Flags -> Ident -> IO ()
mainCompile flags mn = do
- (rmn, allDefs) <-
- if writeCache flags then do
- cash <- getCached flags
- (rds, cash') <- compileCacheTop flags mn cash
+ (rmn, allDefs) <- do
+ cash <- getCached flags
+ (rds, _, cash') <- compileCacheTop flags mn cash
+ when (writeCache flags) $ do
when (verbosityGT flags 0) $
putStrLn $ "Saving cache " ++ show mhsCacheName
() <- seq (rnfNoErr cash) (return ())
saveCache mhsCacheName cash'
- return rds
- else do
- cash <- getCached flags
- fst <$> compileCacheTop flags mn cash
+ return rds
t1 <- getTimeMilli
let
--- a/src/MicroHs/SymTab.hs
+++ b/src/MicroHs/SymTab.hs
@@ -1,6 +1,7 @@
module MicroHs.SymTab(
Entry(..), entryType,
SymTab,
+ stEmpty,
stLookup,
stFromList,
stInsertGlbU,
@@ -7,6 +8,7 @@
stInsertGlbQ,
stElemsLcl,
stKeysLcl,
+ stKeysGlbU,
stInsertLcl,
mapMSymTab,
) where
@@ -72,6 +74,9 @@
qg' <- M.mapM (mapM f) qg
return $ SymTab l' ug' qg'
+stEmpty :: SymTab
+stEmpty = SymTab [] M.empty M.empty
+
stLookup :: String -> Ident -> SymTab -> Either String Entry
stLookup msg i (SymTab l ug qg) =
case lookup i l of
@@ -92,6 +97,9 @@
stKeysLcl :: SymTab -> [Ident]
stKeysLcl (SymTab l _ _) = map fst l
+
+stKeysGlbU :: SymTab -> [Ident]
+stKeysGlbU (SymTab _ m _) = M.keys m
stInsertLcl :: Ident -> Entry -> SymTab -> SymTab
stInsertLcl i a (SymTab l ug qg) = SymTab ((i, a) : l) ug qg
--- a/src/MicroHs/TypeCheck.hs
+++ b/src/MicroHs/TypeCheck.hs
@@ -13,6 +13,7 @@
boolPrefix,
listPrefix,
ValueExport(..), TypeExport(..),
+ Symbols,
) where
import Prelude
import Control.Applicative
@@ -112,6 +113,8 @@
----------------------
+type Symbols = (SymTab, SymTab)
+
data TModule a = TModule
IdentModule -- module names
[FixDef] -- all fixities, exported or not
@@ -156,7 +159,7 @@
--type Tau = EType
type Rho = EType
-typeCheck :: forall a . ImpType -> [(ImportSpec, TModule a)] -> EModule -> TModule [EDef]
+typeCheck :: forall a . ImpType -> [(ImportSpec, TModule a)] -> EModule -> (TModule [EDef], Symbols)
typeCheck impt aimps (EModule mn exps defs) =
-- trace (unlines $ map (showTModuleExps . snd) aimps) $
let
@@ -173,7 +176,9 @@
fexps = [ fe | TModule _ fe _ _ _ _ _ _ <- M.elems impMap ]
sexps = M.toList (synTable tcs)
iexps = M.toList (instTable tcs)
- in tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
+ in ( tModule mn (nubBy ((==) `on` fst) (concat fexps)) (concat texps) sexps (concat cexps) iexps (concat vexps) tds
+ , (typeTable tcs, valueTable tcs)
+ )
-- A hack to force evaluation of errors.
-- This should be redone to all happen in the T monad.
--
⑨