ref: 7aebc6565dd17ce5bb678ceb0e51655383a4a842
parent: d0d713aa32b0b202e3f876fd304c0491b9d1d6bc
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Wed Mar 27 20:55:00 EDT 2024
Stuff to create a package.
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -2,6 +2,7 @@
-- See LICENSE file for full license.
module MicroHs.Compile(
compileCacheTop,
+ compileMany,
mhsCacheName,
getCached,
validateCache,
@@ -14,6 +15,7 @@
import System.Environment
import System.IO
import System.IO.MD5
+import System.IO.Serialize
import System.Process
import Control.DeepSeq
import MicroHs.Abstract
@@ -42,6 +44,9 @@
compileCacheTop :: Flags -> IdentModule -> Cache -> IO ((IdentModule, [(Ident, Exp)]), Cache)
compileCacheTop flags mn ch = do
((rmn, ds), ch') <- compile flags mn ch
+ -- get loaded packages
+ -- recursively load all dependencies
+ -- add everything to ds
t1 <- getTimeMilli
let
dsn = [ (n, compileOpt e) | (n, e) <- ds ]
@@ -53,6 +58,9 @@
putStrLn $ "combinators:\n" ++ showLDefs dsn
return ((rmn, dsn), ch')
+compileMany :: Flags -> [IdentModule] -> Cache -> IO Cache
+compileMany flags mns ach = snd <$> runStateIO (mapM_ (compileModuleCached flags) mns) ach
+
getCached :: Flags -> IO Cache
getCached flags | not (readCache flags) = return emptyCache
getCached flags = do
@@ -74,6 +82,8 @@
-- 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 -> IdentModule -> StateIO Cache (TModule [LDef], Time)
compileModuleCached flags mn = do
cash <- get
@@ -82,41 +92,34 @@
modify $ addWorking mn
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing " ++ showIdent mn
- (cm@(tm,_,_), tp, tt, ts) <- compileModule flags mn
- when (verbosityGT flags 0) $
- liftIO $ putStrLn $ "importing done " ++ showIdent mn ++ ", " ++ show (tp + tt) ++
- "ms (" ++ show tp ++ " + " ++ show tt ++ ")"- when (loading flags && mn /= mkIdent "Interactive") $
- liftIO $ putStrLn $ "loaded " ++ showIdent mn
- modify $ workToDone cm
- return (tm, tp + tt + ts)
+ mres <- liftIO (readModulePath flags mn)
+ case mres of
+ Nothing -> findPkgModule flags mn
+ Just (pathfn, file) -> compileModule flags mn pathfn file
Just tm -> do
when (verbosityGT flags 0) $
liftIO $ putStrLn $ "importing cached " ++ showIdent mn
return (tm, 0)
--- Find and compile a module with the given name.
--- The times are (parsing, typecheck+desugar, imported modules)
-compileModule :: Flags -> IdentModule -> StateIO Cache (CModule, Time, Time, Time)
-compileModule flags nm = do
+compileModule :: Flags -> IdentModule -> FilePath -> String -> StateIO Cache (TModule [LDef], Time)
+compileModule flags mn pathfn file = do
t1 <- liftIO getTimeMilli
- (pathfn, file) <- liftIO (readModulePath flags nm)
mchksum <- liftIO (md5File pathfn) -- XXX there is a small gap between reading and computing the checksum.
let chksum :: MD5CheckSum
chksum = fromMaybe undefined mchksum
let pmdl = parseDie pTop pathfn file
- mdl@(EModule nmn _ defs) = addPreludeImport pmdl
+ mdl@(EModule mnn _ defs) = addPreludeImport pmdl
-- liftIO $ putStrLn $ showEModule mdl
-- liftIO $ putStrLn $ showEDefs defs
- -- TODO: skip test when nm is a file name
- when (isNothing (getFileName nm) && nm /= nmn) $
- error $ "module name does not agree with file name: " ++ showIdent nm ++ " " ++ showIdent nmn
+ -- TODO: skip test when mn is a file name
+ when (isNothing (getFileName mn) && mn /= mnn) $
+ error $ "module name does not agree with file name: " ++ showIdent mn ++ " " ++ showIdent mnn
let
specs = [ s | Import s <- defs ]
imported = [ m | ImportSpec _ m _ _ <- specs ]
t2 <- liftIO getTimeMilli
- (impMdls, ts) <- fmap unzip $ mapM (compileModuleCached flags) imported
+ (impMdls, its) <- fmap unzip $ mapM (compileModuleCached flags) imported
t3 <- liftIO getTimeMilli
let
tmdl = typeCheck (zip specs impMdls) mdl
@@ -126,10 +129,18 @@
dmdl = desugar flags tmdl
() <- return $ rnf $ bindingsOf dmdl
t4 <- liftIO getTimeMilli
+ let tp = t2 - t1
+ tt = t4 - t3
+ ts = sum its
when (verbosityGT flags 3) $
(liftIO $ putStrLn $ "desugared:\n" ++ showTModule showLDefs dmdl)
- let cmdl = (dmdl, imported, chksum)
- return (cmdl, t2-t1, t4-t3, sum ts)
+ when (verbosityGT flags 0) $
+ liftIO $ putStrLn $ "importing done " ++ showIdent mn ++ ", " ++ show (tp + tt) ++
+ "ms (" ++ show tp ++ " + " ++ show tt ++ ")"+ when (loading flags && mn /= mkIdent "Interactive") $
+ liftIO $ putStrLn $ "loaded " ++ showIdent mn
+ modify $ workToDone (dmdl, imported, chksum)
+ return (dmdl, tp + tt + ts)
addPreludeImport :: EModule -> EModule
addPreludeImport (EModule mn es ds) =
@@ -195,9 +206,7 @@
| otherwise = Nothing
where s = unIdent m
--- TODO:
--- * with the CPP flag, run the prepocessor on the file
-readModulePath :: Flags -> IdentModule -> IO (FilePath, String)
+readModulePath :: Flags -> IdentModule -> IO (Maybe (FilePath, String))
readModulePath flags mn | Just fn <- getFileName mn = do
mh <- openFileM fn ReadMode
case mh of
@@ -206,7 +215,7 @@
| otherwise = do
mh <- findModulePath flags mn
case mh of
- Nothing -> errorMessage (getSLoc mn) $ "Module not found: " ++ show mn ++ "\nsearch path=" ++ show (paths flags)
+ Nothing -> return Nothing
Just (fn, h) -> readRest fn h
where readRest fn h = do
file <-
@@ -215,13 +224,16 @@
runCPPTmp flags fn
else
hGetContents h
- return (fn, file)
+ return (Just (fn, file))
+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
let
- fn = map (\ c -> if c == '.' then '/' else c) (unIdent mn) ++ ".hs"
+ fn = moduleToFile mn ++ ".hs"
openFilePath (paths flags) fn
openFilePath :: [FilePath] -> FilePath -> IO (Maybe (FilePath, Handle))
@@ -259,3 +271,30 @@
when (verbosityGT flags 0) $
putStrLn $ "Execute: " ++ show cmd
callCommand cmd
+
+findPkgModule :: Flags -> IdentModule -> StateIO Cache (TModule [LDef], Time)
+findPkgModule flags mn = do
+ let fn = moduleToFile mn
+ mres <- liftIO $ openFilePath (pkgPath flags) fn
+ case mres of
+ Just (pfn, hdl) -> do
+ pkg <- liftIO $ hGetContents hdl
+ liftIO $ hClose hdl
+ let dir = take (length pfn - length fn) pfn -- directory where the file was found
+ loadPkg flags dir pkg
+ cash <- get
+ case lookupCache mn cash of
+ Nothing -> error $ "package does not contain module " ++ pkg ++ " " ++ showIdent mn
+ Just t -> return (t, 0)
+ Nothing ->
+ errorMessage (getSLoc mn) $
+ "Module not found: " ++ show mn ++
+ "\nsearch path=" ++ show (paths flags) ++
+ "\npackage path=" ++ show (pkgPath flags)
+
+loadPkg :: Flags -> FilePath -> FilePath -> StateIO Cache ()
+loadPkg _flags dir fn = do
+ pkg <- liftIO $ readSerialized (dir ++ "/packages/" ++ fn)
+ modify $ addPackage pkg
+
+-- XXX add function to find&load package from package name
--- a/src/MicroHs/CompileCache.hs
+++ b/src/MicroHs/CompileCache.hs
@@ -2,7 +2,7 @@
CModule,
Cache, addWorking, emptyCache, deleteFromCache, workToDone,
cachedModules, lookupCache, lookupCacheChksum, getImportDeps,
- addPackage,
+ addPackage, getCompMdls, getPkgs,
saveCache, loadCached,
) where
import Prelude
@@ -72,6 +72,12 @@
getImportDeps :: Cache -> [(IdentModule, [IdentModule])]
getImportDeps cash = [ (tModuleName tm, imps) | CompMdl tm imps _ <- M.elems (cache cash) ]
+
+getCompMdls :: Cache -> [TModule [LDef]]
+getCompMdls cash = [ tm | CompMdl tm _ _ <- M.elems (cache cash) ]
+
+getPkgs :: Cache -> [Package]
+getPkgs = pkgs
addPackage :: Package -> Cache -> Cache
addPackage p c = c{ pkgs = p : pkgs c, cache = foldr ins (cache c) (pkgExported p) }--- a/src/MicroHs/Flags.hs
+++ b/src/MicroHs/Flags.hs
@@ -12,7 +12,9 @@
useTicks :: Bool, -- emit ticks
doCPP :: Bool, -- run ccphs on input files
cppArgs :: [String], -- flags for CPP
- compress :: Bool -- compress generated combinators
+ compress :: Bool, -- compress generated combinators
+ buildPkg :: Maybe FilePath, -- build a package
+ pkgPath :: [FilePath] -- package search path
}
--deriving (Show)
@@ -32,5 +34,7 @@
useTicks = False,
doCPP = False,
cppArgs = [],
- compress = False
+ compress = False,
+ buildPkg = Nothing,
+ pkgPath = []
}
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -7,6 +7,7 @@
import Control.DeepSeq
import Control.Monad
import Data.Maybe
+import Data.Version
import System.Environment
import MicroHs.Compile
import MicroHs.CompileCache
@@ -14,11 +15,14 @@
import MicroHs.FFI
import MicroHs.Flags
import MicroHs.Ident
+import MicroHs.Package
import MicroHs.Translate
+import MicroHs.TypeCheck(tModuleName)
import MicroHs.Interactive
import MicroHs.MakeCArray
import System.Directory
import System.IO
+import System.IO.Serialize
import System.Process
import Compat
import MicroHs.Instances(getMhsDir) -- for GHC
@@ -35,11 +39,14 @@
["--numeric-version"] -> putStrLn mhsVersion
_ -> do
let (flags, mdls, rargs) = decodeArgs (defaultFlags dir) [] args
- withArgs rargs $
- case mdls of
- [] -> mainInteractive flags
- [s] -> mainCompile flags (mkIdentSLoc (SLoc "command-line" 0 0) s)
- _ -> error usage
+ case buildPkg flags of
+ Just p -> mainBuildPkg flags p mdls
+ Nothing ->
+ withArgs rargs $
+ case mdls of
+ [] -> mainInteractive flags
+ [s] -> mainCompile flags (mkIdentSLoc (SLoc "command-line" 0 0) s)
+ _ -> error usage
usage :: String
usage = "Usage: mhs [--version] [-v] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-T] [-z] [-iPATH] [-oFILE] [ModuleName]"
@@ -61,8 +68,26 @@
'-':'i':s -> decodeArgs f{paths = paths f ++ [s]} mdls args '-':'o':s -> decodeArgs f{output = s} mdls args '-':'D':s -> decodeArgs f{cppArgs = cppArgs f ++ [s]} mdls args+ '-':'P':s -> decodeArgs f{buildPkg = Just s} mdls args'-':_ -> error $ "Unknown flag: " ++ arg ++ "\n" ++ usage
_ -> decodeArgs f (mdls ++ [arg]) args
+
+mainBuildPkg :: Flags -> String -> [String] -> IO ()
+mainBuildPkg flags pkgn amns = do
+ when (verbose flags > 0) $
+ putStrLn $ "Building package " ++ pkgn
+ let mns = map mkIdent amns
+ cash <- compileMany flags mns emptyCache
+ let mdls = getCompMdls cash
+ (exported, other) = partition ((`elem` mns) . tModuleName) mdls
+ pkgDeps = map pkgName $ getPkgs cash
+ pkg = Package { pkgName = mkIdent pkgn, pkgVersion = makeVersion [0]+ , pkgExported = exported, pkgOther = other
+ , pkgDepends = map (,makeVersion [0]) pkgDeps }
+ print (map tModuleName $ pkgOther pkg)
+ when (verbose flags > 0) $
+ putStrLn $ "Writing package " ++ pkgn ++ " to " ++ output flags
+ writeSerializedCompressed (output flags) pkg
mainCompile :: Flags -> Ident -> IO ()
mainCompile flags mn = do
--
⑨