ref: 06bf930a5d03a8b164bf0f3707dbf35a830ea507
parent: b5a3c38d9a2bc8e61960d0eff46391c69f3ed112
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Sat Apr 13 14:41:13 EDT 2024
Reorganize for packages.
--- a/Makefile
+++ b/Makefile
@@ -10,7 +10,7 @@
#
GHC= ghc
GHCINCS= -ighc -isrc
-GHCWARNS= -Wall -Wno-unrecognised-warning-flags -Wno-x-partial
+GHCWARNS= -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -Wno-deprecations
GHCOPTS= -O
GHCEXTS= -DNOTCABAL -XScopedTypeVariables -XPatternGuards -XTupleSections -XTypeSynonymInstances -XFlexibleInstances -XOverloadedRecordDot -XDisambiguateRecordFields -XOverloadedStrings
# -XOverloadedRecordUpdate
@@ -21,6 +21,8 @@
GHCPROF= # -prof -fprof-late #-prof -fprof-auto
GHCFLAGS= $(GHCEXTS) $(GHCINCS) $(GHCWARNS) $(GHCOPTS) $(GHCTOOL) $(GHCPKGS) $(GHCOUT) $(GHCPROF)
#
+MHSINC= -i -isrc -ilib -ilib/simple-readline
+#
.PHONY: clean bootstrap install ghcgen newmhs cachelib timecompile exampletest cachetest runtest runtestmhs everytest everytestmhs nfibtest info
all: bin/mhs bin/cpphs
@@ -67,10 +69,10 @@
# Generate distribution C file
generated/mhs.c: bin/mhs src/*/*.hs
@mkdir -p generated
- bin/mhs -z -isrc MicroHs.Main -ogenerated/mhs.c
+ bin/mhs -z $(MHSINC) MicroHs.Main -ogenerated/mhs.c
ghcgen: bin/gmhs src/*/*.hs lib/*.hs lib/*/*.hs lib/*/*/*.hs
- bin/gmhs -isrc MicroHs.Main -ogenerated/mhs.c
+ bin/gmhs $(MHSINC) MicroHs.Main -ogenerated/mhs.c
# Make sure boottrapping works
bootstrap: bin/mhs-stage2
@@ -82,7 +84,7 @@
bin/mhs-stage1: bin/mhs src/*/*.hs
@mkdir -p generated
@echo "*** Build stage1 compiler, using bin/mhs"
- bin/mhs -z -isrc MicroHs.Main -ogenerated/mhs-stage1.c
+ bin/mhs -z $(MHSINC) MicroHs.Main -ogenerated/mhs-stage1.c
$(CCEVAL) generated/mhs-stage1.c -o bin/mhs-stage1
# Build stage2 compiler with stage1 compiler, and compare
@@ -89,7 +91,7 @@
bin/mhs-stage2: bin/mhs-stage1 src/*/*.hs
@mkdir -p generated
@echo "*** Build stage2 compiler, with stage1 compiler"
- bin/mhs-stage1 -z -isrc MicroHs.Main -ogenerated/mhs-stage2.c
+ bin/mhs-stage1 -z $(MHSINC) MicroHs.Main -ogenerated/mhs-stage2.c
cmp generated/mhs-stage1.c generated/mhs-stage2.c
@echo "*** stage2 equal to stage1"
$(CCEVAL) generated/mhs-stage2.c -o bin/mhs-stage2
@@ -112,13 +114,13 @@
#
timecompile: bin/mhs
- time bin/mhs +RTS -v -RTS -isrc MicroHs.Main
+ time bin/mhs +RTS -v -RTS $(MHSINC) MicroHs.Main
#
timecachecompile: bin/mhs
@-rm -f .mhscache
time bin/mhs +RTS -v -RTS -CW AllOfLib
- time bin/mhs +RTS -v -RTS -CR -isrc MicroHs.Main
+ time bin/mhs +RTS -v -RTS -CR $(MHSINC) MicroHs.Main
#
cachelib:
@@ -127,7 +129,7 @@
#
clean:
- rm -rf src/*/*.hi src/*/*.o *.comb *.tmp *~ bin/* a.out $(GHCOUTDIR) tmp/* Tools/*.o Tools/*.hi dist-newstyle generated/*-stage* .mhscache targets.conf
+ rm -rf src/*/*.hi src/*/*.o *.comb *.tmp *~ bin/* a.out $(GHCOUTDIR) tmp/* Tools/*.o Tools/*.hi dist-newstyle generated/*-stage* .mhscache targets.conf .mhscache
make clean -f Makefile.emscripten
cd tests; make clean
@@ -152,8 +154,8 @@
cd tests; make MHS=../bin/mhs cache; make MHS="../bin/mhs +RTS -H4M -RTS -CR" info test
bootcombtest: bin/gmhs bin/mhseval
- bin/gmhs -isrc -ogmhs.comb MicroHs.Main
- bin/mhseval +RTS -v -rgmhs.comb -RTS -isrc -omhs.comb MicroHs.Main
+ bin/gmhs $(MHSINC) -ogmhs.comb MicroHs.Main
+ bin/mhseval +RTS -v -rgmhs.comb -RTS $(MHSINC) -omhs.comb MicroHs.Main
cmp gmhs.comb mhs.comb
exampletest: bin/mhs bin/mhseval Example.hs
@@ -168,7 +170,7 @@
rm -f .mhscache
bin/mhs -CW AllOfLib
bin/mhs -CR Example && bin/mhseval
- bin/mhs +RTS -v -RTS -isrc -CR MicroHs.Main
+ bin/mhs +RTS -v -RTS $(MHSINC) -CR MicroHs.Main
rm -f .mhscache
nfibtest: bin/mhs bin/mhseval
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -39,9 +39,8 @@
executable mhs
default-language: Haskell98
- hs-source-dirs: ghc src
ghc-options: -Wall -Wno-unrecognised-warning-flags -Wno-x-partial -main-is MicroHs.Main
- -fwrite-ide-info
+ -fwrite-ide-info -Wno-deprecated
main-is: MicroHs/Main.hs
default-extensions: ScopedTypeVariables PatternGuards TypeSynonymInstances MultiParamTypeClasses
FlexibleInstances BangPatterns
@@ -86,6 +85,7 @@
Paths_MicroHs
autogen-modules: Paths_MicroHs
if impl(ghc)
+ hs-source-dirs: ghc src
build-depends: base >= 4.10 && < 4.20,
containers >= 0.5 && < 0.8,
deepseq >= 1.1 && < 1.6,
@@ -95,4 +95,6 @@
time >= 1.1 && < 1.15,
pretty >= 1.0 && < 1.2,
process >= 1.6 && < 1.8,
- directory >= 1.2 && < 1.5
+ directory >= 1.2 && < 1.5,
+ if impl(mhs)
+ hs-source-dirs: src lib lib/simple-readline
--- a/README.md
+++ b/README.md
@@ -134,7 +134,8 @@
### Compiler flags
* `--version` show version number
-* `-iDIR` add `DIR` to search path for modules
+* `-i` set module search path to empty
+* `-iDIR` append `DIR` to module search path
* `-oFILE` output file. If the `FILE` ends in `.comb` it will produce a textual combinator file. If `FILE` ends in `.c` it will produce a C file with the combinators. For all other `FILE` it will compile the combinators together with the runtime system to produce a regular executable.
* `-r` run directly
* `-v` be more verbose, flag can be repeated
@@ -146,6 +147,11 @@
* `-XCPP` run `cpphs` on source files
* `-Dxxx` passed to `cpphs`
* `-tTARGET` select target
+* `-a` set package to empty
+* `-aDIR` prepend `DIR` to package search path
+* `-PPKG` create package `PKG`
+* `-LFILE` list all modules in a package
+* `-Q FILE DIR` install package
With the `-v` flag the processing time for each module is reported.
E.g.
--- a/lib/System/Console/SimpleReadline.hs
+++ /dev/null
@@ -1,210 +1,0 @@
--- Copyright 2023 Lennart Augustsson
--- See LICENSE file for full license.
--- Simple readline with line editing and history.
--- Only assumes the terminal is capable of (sane) backspace.
-module System.Console.SimpleReadline(
- getInputLine,
- getInputLineHist,
- getInputLineHistComp,
- ) where
-import Prelude
-import Control.Monad
-import Data.Char
-import System.IO
-
-foreign import ccall "GETRAW" c_getRaw :: IO Int
-
-
--- Get an input line with editing.
--- Return Nothing if the input is ^D, otherwise the typed string.
-getInputLine :: String -> IO (Maybe String)
-getInputLine prompt = do
- (_, r) <- loop (\ _ -> return []) ([],[]) "" ""
- return r
-
-getInputLineHist :: FilePath -> String -> IO (Maybe String)
-getInputLineHist = getInputLineHistComp (\ _ -> return [])
-
-type CompleteFn = (String, String) -> IO [String]
-
--- Get an input line with editing.
--- Return Nothing if the input is ^D, otherwise the typed string.
--- The FilePath gives the name of a file that stores the history.
-getInputLineHistComp :: CompleteFn -> FilePath -> String -> IO (Maybe String)
-getInputLineHistComp comp hfn prompt = do
- mhdl <- openFileM hfn ReadMode
- hist <-
- case mhdl of
- Nothing -> return []
- Just hdl -> do
- file <- hGetContents hdl
- let h = lines file
- seq (length h) (return h) -- force file to be read
- putStr prompt
- (hist', r) <- loop comp (reverse hist, []) "" ""
--- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
- writeFile hfn $ unlines hist'
- return r -- XXX no type error
-
-getRaw :: IO Char
-getRaw = do
- i <- c_getRaw
- when (i < 0) $
- error "getRaw failed"
- return (chr i)
-
-type Hist = ([String], [String])
-
-loop :: CompleteFn -> Hist -> String -> String -> IO ([String], Maybe String)
-loop comp hist before after = do
- hFlush stdout
- i <- getRaw
- loop' comp hist before after i
-
-loop' :: CompleteFn -> Hist -> String -> String -> Char -> IO ([String], Maybe String)
-loop' comp hist before after cmd = do
- let
- cur = reverse before ++ after
- back n = putStr (replicate n '\b')
- bsSpBs n = concat $ replicate n "\b \b"
-
- ins c = do
- putChar c
- putStr after
- back (length after)
- add c = do
- ins c
- loop comp hist (c:before) after
- backward =
- case before of
- [] -> noop
- c:cs -> do
- back 1
- loop comp hist cs (c:after)
- forward =
- case after of
- [] -> noop
- c:cs -> do
- putChar c
- loop comp hist (c:before) cs
- bol = do
- back (length before)
- loop comp hist [] cur
- eol = do
- putStr after
- loop comp hist (reverse after ++ before) []
- bs = do
- case before of
- [] -> noop
- _:cs -> do
- back 1
- putStr after
- putChar ' '
- back (length after + 1)
- loop comp hist cs after
- del = do
- case after of
- [] -> noop
- _:cs -> do
- putStr cs
- putChar ' '
- back (length cs + 1)
- loop comp hist before cs
- send =
- ret (Just cur)
- ret ms = do
- putChar '\n'
- hFlush stdout
- let
- o = reverse (fst hist) ++ snd hist
- l =
- case ms of
- Nothing -> []
- Just [] -> []
- Just s | not (null o) && s == last o -> []
- | otherwise -> [s]
- h = o ++ l
- return (h, ms)
- erase = do
- eraseLine
- loop comp hist [] []
- noop = loop comp hist before after
- kill = do
- putStr after
- putStr $ bsSpBs $ length after
- loop comp hist before []
-
- next =
- case hist of
- (_, []) -> noop
- (p, l:n) -> setLine (l:p, n) l
- previous =
- case hist of
- ([], _) -> noop
- (l:p, n) -> setLine (p, l:n) l
- setLine h s = do
- eraseLine
- putStr s
- loop comp h (reverse s) ""
-
- eraseLine = do
- putStr after
- putStr $ bsSpBs $ length before + length after
-
- complete = do
- alts <- comp (before, after)
- case alts of
- [] -> loop comp hist before after
- [s] -> do mapM_ ins s; loop comp hist (reverse s ++ before) after
- ss -> tabLoop ss
-
- tabLoop (s:ss) = do
- mapM_ ins s -- show first alternative
- hFlush stdout
- c <- getRaw
- if c /= '\t' then
- loop' comp hist (reverse s ++ before) after c
- else do
- let n = length s
- back n -- back up this alternative
- putStr after -- put back old text
- putStr $ replicate n ' ' -- erase extra
- back (n + length after) -- put cursor back
- tabLoop (ss ++ [s]) -- try next alternative
-
- exec i =
- case i of
- '\^D' -> -- CTL-D, EOF
- if null before && null after then
- ret Nothing
- else
- del
- '\^B' -> backward -- CTL-B, backwards
- '\^F' -> forward -- CTL-F, forwards
- '\^A' -> bol -- CTL-A, beginning of line
- '\^E' -> eol -- CTL-E, end of line
- '\b' -> bs -- BS, backspace
- '\DEL' -> bs -- DEL, backspace
- '\r' -> send -- CR, return
- '\n' -> send -- LF, return
- '\^N' -> next -- CTL-N, next line
- '\^P' -> previous -- CTL-P, previous line
- '\^U' -> erase -- CTL-U, erase line
- '\^K' -> kill -- CTL-K, kill to eol
- '\t' -> complete -- TAB, complete word
- '\ESC' -> do -- ESC
- b <- getRaw
- if b /= '[' then
- noop
- else do
- c <- getRaw
- case c of
- 'A' -> previous
- 'B' -> next
- 'C' -> forward
- 'D' -> backward
- _ -> noop
- _ -> if i >= ' ' && i < '\DEL' then add i else noop
-
- exec cmd
--- a/lib/System/Exit.hs
+++ b/lib/System/Exit.hs
@@ -10,7 +10,7 @@
import System.IO
data ExitCode = ExitSuccess | ExitFailure Int
- deriving (Typeable, Show)
+ deriving (Eq, Typeable, Show)
instance Exception ExitCode
--- a/lib/System/Info.hs
+++ b/lib/System/Info.hs
@@ -1,9 +1,10 @@
module System.Info(os, arch, compilerName, compilerVersion, fullCompilerVersion) where
import Data.Char
import Data.Version(Version(..))
+import System.Cmd
import System.Directory
+import System.Exit
import System.IO
-import System.Process
import System.IO.Unsafe
os :: String
@@ -26,7 +27,9 @@
uname flag = unsafePerformIO $ do
(fn, h) <- openTmpFile "uname"
hClose h
- callCommand $ "uname " ++ flag ++ " >" ++ fn
+ rc <- cmd $ "uname " ++ flag ++ " >" ++ fn
res <- readFile fn
removeFile fn
+ when (rc /= ExitSuccess)
+ error $ "System.Into: uname failed"
return $ map toLower $ filter (not . isSpace) res
--- a/lib/libs.cabal
+++ b/lib/libs.cabal
@@ -64,6 +64,7 @@
Data.String
Data.Traversable
Data.Tuple
+ Data.Type.Equality
Data.Typeable
Data.TypeLits
Data.Version
@@ -85,18 +86,25 @@
Numeric.FormatFloat
Numeric.Natural
Prelude
+ System.Cmd
+ System.Directory
System.Environment
System.Exit
System.IO
+ System.IO.MD5
+ System.IO.Unsafe
System.Info
System.Process
Text.Printf
Text.Read
+ Text.Read.Lex
+ Text.Read.Numeric
Text.Show
Unsafe.Coerce
other-modules:
Control.Exception.Internal
+ Control.Monad.ST_Type
Data.Bool_Type
Data.Char_Type
Data.Integer_Type
@@ -107,28 +115,41 @@
Primitives
System.IO_Handle
-library directory
- exposed-modules:
- System.Directory
+ build-depends:
+--library directory
+-- exposed-modules:
+-- System.Directory
+-- build-depends:
+-- base
+
library simple-readline
+ hs-source-dirs: simple-readline
exposed-modules:
System.Console.SimpleReadline
+ build-depends:
+ base
-library pretty
- exposed-modules:
- Text.PrettyPrint.HughesPJ
- Text.PrettyPrint.HughesPJClass
-
-library mhs
- exposed-modules:
- System.IO.MD5
- System.IO.PrintOrRun
- System.IO.Serialize
- System.IO.TimeMilli
-
-library containers
- exposed-modules:
- Data.IntMap
- Data.IntSet
- Data.Map
+--library pretty
+-- exposed-modules:
+-- Text.PrettyPrint.HughesPJ
+-- Text.PrettyPrint.HughesPJClass
+-- build-depends:
+-- base
+--
+--library mhs
+-- exposed-modules:
+-- System.IO.PrintOrRun
+-- System.IO.Serialize
+-- System.IO.TimeMilli
+-- build-depends:
+-- base
+--
+--library containers
+-- exposed-modules:
+-- Data.IntMap
+-- Data.IntSet
+-- Data.Map
+-- build-depends:
+-- base
+--
--- a/src/MicroHs/Flags.hs
+++ b/src/MicroHs/Flags.hs
@@ -14,6 +14,7 @@
cppArgs :: [String], -- flags for CPP
compress :: Bool, -- compress generated combinators
buildPkg :: Maybe FilePath, -- build a package
+ listPkg :: Maybe FilePath, -- list package contents
pkgPath :: [FilePath], -- package search path
installPkg :: Bool, -- install a package
target :: String -- Compile target defined in target.conf
@@ -38,6 +39,7 @@
cppArgs = [],
compress = False,
buildPkg = Nothing,
+ listPkg = Nothing,
pkgPath = [],
installPkg = False,
target = "default"
--- a/src/MicroHs/Main.hs
+++ b/src/MicroHs/Main.hs
@@ -23,11 +23,12 @@
import MicroHs.TypeCheck(tModuleName)
import MicroHs.Interactive
import MicroHs.MakeCArray
+import System.Cmd
+import System.Exit
import System.Directory
import System.IO
import System.IO.Serialize
import System.IO.TimeMilli
-import System.Process
import Compat
import MicroHs.Instances(getMhsDir) -- for GHC
import MicroHs.TargetConfig
@@ -46,18 +47,21 @@
_ -> do
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
+ case listPkg flags of
+ Just p -> mainListPkg flags p
Nothing ->
- if installPkg flags then mainInstallPackage flags mdls else
- 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 ->
+ if installPkg flags then mainInstallPackage flags mdls else
+ 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] [--numeric-version] [-v] [-q] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-T] [-z] [-iPATH] [-oFILE] [-PPKG] [-Q PKG] [-tTARGET] [ModuleName...]"
+usage = "Usage: mhs [--version] [--numeric-version] [-v] [-q] [-l] [-r] [-C[R|W]] [-XCPP] [-Ddef] [-T] [-z] [-iPATH] [-oFILE] [-a[PATH]] [-LPATH] [-PPKG] [-Q PKG] [-tTARGET] [ModuleName...]"
decodeArgs :: Flags -> [String] -> [String] -> (Flags, [String], [String])
decodeArgs f mdls [] = (f, mdls, [])
@@ -75,6 +79,7 @@
"-XCPP" -> decodeArgs f{doCPP = True} mdls args "-z" -> decodeArgs f{compress = True} mdls args "-Q" -> decodeArgs f{installPkg = True} mdls args+ '-':'i':[] -> decodeArgs f{paths = []} mdls args '-':'i':s -> decodeArgs f{paths = paths f ++ [s]} mdls args '-':'o':s -> decodeArgs f{output = s} mdls args '-':'t':s -> decodeArgs f{target = s} mdls args@@ -81,6 +86,9 @@
'-':'D':_ -> decodeArgs f{cppArgs = cppArgs f ++ [arg]} mdls args '-':'I':_ -> decodeArgs f{cppArgs = cppArgs f ++ [arg]} mdls args '-':'P':s -> decodeArgs f{buildPkg = Just s} mdls args+ '-':'a':[] -> decodeArgs f{pkgPath = []} mdls args+ '-':'a':s -> decodeArgs f{pkgPath = s : pkgPath f} mdls args+ '-':'L':s -> decodeArgs f{listPkg = Just s} mdls args'-':_ -> error $ "Unknown flag: " ++ arg ++ "\n" ++ usage
_ -> decodeArgs f (mdls ++ [arg]) args
@@ -153,6 +161,13 @@
_ -> error $ "package name not of the form name-version:" ++ show s
where readVersion = map read . words . map (\ c -> if c == '.' then ' ' else c)
+mainListPkg :: Flags -> FilePath -> IO ()
+mainListPkg _flags pkgfn = do
+ pkg <- readSerialized pkgfn
+ let list = mapM_ (putStrLn . showIdent . tModuleName)
+ list (pkgExported pkg)
+ list (pkgOther pkg)
+
mainCompile :: Flags -> Ident -> IO ()
mainCompile flags mn = do
(rmn, allDefs) <- do
@@ -207,8 +222,10 @@
cmd = substString "$IN" fn $ substString "$OUT" outFile cc
when (verbosityGT flags 0) $
putStrLn $ "Execute: " ++ show cmd
- callCommand cmd
+ ec <- system cmd
removeFile fn
+ when (ec /= ExitSuccess) $
+ error $ "command failed: " ++ cmd
ct2 <- getTimeMilli
when (verbosityGT flags 0) $
putStrLn $ "C compilation " ++ padLeft 6 (show (ct2-ct1)) ++ "ms"
--
⑨