ref: 3a32772e9d793da9aa2813989b190c9c662c1980
parent: 46879fde32f83a510e87072fe59a6997f4265e30
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Mar 28 06:09:43 EDT 2024
Handle package installation.
--- a/src/MicroHs/Compile.hs
+++ b/src/MicroHs/Compile.hs
@@ -7,6 +7,7 @@
getCached,
validateCache,
Cache, emptyCache, deleteFromCache,
+ moduleToFile,
) where
import Prelude
import Data.List
--- a/src/MicroHs/Flags.hs
+++ b/src/MicroHs/Flags.hs
@@ -14,9 +14,10 @@
cppArgs :: [String], -- flags for CPP
compress :: Bool, -- compress generated combinators
buildPkg :: Maybe FilePath, -- build a package
- pkgPath :: [FilePath] -- package search path
+ pkgPath :: [FilePath], -- package search path
+ installPkg :: Bool -- install a package
}
- --deriving (Show)
+ -- deriving (Show)
verbosityGT :: Flags -> Int -> Bool
verbosityGT flags v = verbose flags > v
@@ -36,5 +37,6 @@
cppArgs = [],
compress = False,
buildPkg = Nothing,
- pkgPath = []
+ pkgPath = [],
+ installPkg = False
}
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -79,6 +79,8 @@
(ds, rs) -> tIdent loc [] (d:ds) (lex (addCol loc $ 1 + length ds) rs)
lex loc cs@(d:_) | isUpper d = upperIdent loc loc [] cs
lex loc ('0':x:cs) | toLower x == 'x' = hexNumber loc cs+ | toLower x == 'o' = octNumber loc cs
+ | toLower x == 'b' = binNumber loc cs
lex loc cs@(d:_) | isDigit d = number loc cs
lex loc ('.':cs@(d:_)) | isLower_ d =TSpec loc '.' : lex (addCol loc 1) cs
@@ -102,8 +104,19 @@
hexNumber :: SLoc -> String -> [Token]
hexNumber loc cs =
case span isHexDigit cs of
- (ds, rs) -> TInt loc (readHex ds) : lex (addCol loc $ length ds + 2) rs
+ (ds, rs) -> TInt loc (readBase 16 ds) : lex (addCol loc $ length ds + 2) rs
+octNumber :: SLoc -> String -> [Token]
+octNumber loc cs =
+ case span isOctDigit cs of
+ (ds, rs) -> TInt loc (readBase 8 ds) : lex (addCol loc $ length ds + 2) rs
+
+binNumber :: SLoc -> String -> [Token]
+binNumber loc cs =
+ case span isBinDigit cs of
+ (ds, rs) -> TInt loc (readBase 2 ds) : lex (addCol loc $ length ds + 2) rs
+ where isBinDigit c = c == '0' || c == '1'
+
number :: SLoc -> String -> [Token]
number loc cs =
case span isDigit cs of
@@ -246,8 +259,8 @@
tokensLoc (TIndent loc :_) = loc
tokensLoc _ = mkLocEOF
-readHex :: String -> Integer
-readHex = foldl (\ r c -> r * 16 + toInteger (digitToInt c)) 0
+readBase :: Integer -> String -> Integer
+readBase b = foldl (\ r c -> r * b + toInteger (digitToInt c)) 0
-- | 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/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -28,20 +28,23 @@
import MicroHs.Instances(getMhsDir) -- for GHC
mhsVersion :: String
-mhsVersion = "0.9.8.0"
+mhsVersion = "0.9.9.0"
main :: IO ()
main = do
args <- getArgs
dir <- fromMaybe "." <$> getMhsDir
- case take 1 args of
+ home <- getEnv "HOME"
+ case args of
["--version"] -> putStrLn $ "MicroHs, version " ++ mhsVersion ++ ", combinator file version " ++ combVersion
["--numeric-version"] -> putStrLn mhsVersion
_ -> do
- let (flags, mdls, rargs) = decodeArgs (defaultFlags dir) [] args
+ let dflags = (defaultFlags dir){ pkgPath = [home ++ "/.mcabal/mhs-" ++ mhsVersion] }+ (flags, mdls, rargs) = decodeArgs dflags [] args
case buildPkg flags of
Just p -> mainBuildPkg flags p mdls
Nothing ->
+ if installPkg flags then mainInstallPackage flags mdls else
withArgs rargs $
case mdls of
[] -> mainInteractive flags
@@ -49,7 +52,7 @@
_ -> error usage
usage :: String
-usage = "Usage: mhs [--version] [-v] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-T] [-z] [-iPATH] [-oFILE] [ModuleName]"
+usage = "Usage: mhs [--version] [--numeric-version] [-v] [-q] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-T] [-z] [-iPATH] [-oFILE] [-PPKG] [-Q PKG] [ModuleName...]"
decodeArgs :: Flags -> [String] -> [String] -> (Flags, [String], [String])
decodeArgs f mdls [] = (f, mdls, [])
@@ -57,6 +60,7 @@
case arg of
"--" -> (f, mdls, args) -- leave arguments after -- for any program we run
"-v" -> decodeArgs f{verbose = verbose f + 1} mdls args+ "-q" -> decodeArgs f{verbose = -1} mdls args "-r" -> decodeArgs f{runIt = True} mdls args "-l" -> decodeArgs f{loading = True} mdls args "-CR" -> decodeArgs f{readCache = True} mdls args@@ -65,6 +69,7 @@
"-T" -> decodeArgs f{useTicks = True} mdls args "-XCPP" -> decodeArgs f{doCPP = True} mdls args "-z" -> decodeArgs f{compress = True} mdls args+ "-Q" -> decodeArgs f{installPkg = True} mdls args '-':'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@@ -156,3 +161,22 @@
ct2 <- getTimeMilli
when (verbosityGT flags 0) $
putStrLn $ "C compilation " ++ padLeft 6 (show (ct2-ct1)) ++ "ms"
+
+mainInstallPackage :: Flags -> [FilePath] -> IO ()
+mainInstallPackage flags [pkgfn, dir] = do
+ when (verbosityGT flags 0) $
+ putStrLn $ "Installing package " ++ pkgfn ++ " in " ++ dir
+ pkg <- readSerialized pkgfn
+ let pdir = dir ++ "/packages"
+ createDirectoryIfMissing True pdir
+ copyFile pkgfn (pdir ++ "/" ++ pkgfn)
+ let mk tm = do
+ let fn = dir ++ "/" ++ moduleToFile (tModuleName tm)
+ d = dropWhileEnd (/= '/') fn
+ when (verbosityGT flags 1) $
+ putStrLn $ "create " ++ fn
+ createDirectoryIfMissing True d
+ writeFile fn pkgfn
+ mapM_ mk (pkgExported pkg)
+mainInstallPackage flags [pkgfn] = mainInstallPackage flags [pkgfn, head (pkgPath flags)]
+mainInstallPackage _ _ = error usage
--
⑨