ref: 0589439c8aaa85712b7a51e64bd46c2e5d2baf6d
parent: b35ddc07d56145c4d6f524093eb568d497dbe14c
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Sep 21 20:19:06 EDT 2023
Make it compile with cabal.
--- a/Makefile
+++ b/Makefile
@@ -34,7 +34,7 @@
### Build the compiler with ghc, using standard libraries (Prelude, Data.List, etc)
###
$(BIN)/$(MHS): src/*.hs src/*/*.hs $(TOOLS)/convertX.sh
- $(GHCE) -isrc -ighc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
+ $(GHCE) -ighc -isrc -Wall -O src/MicroHs/Main.hs -main-is MicroHs.Main -o $(BIN)/$(MHS)
###
### Build the compiler with ghc, using MicroHs libraries (Prelude, Data.List, etc)
@@ -69,8 +69,8 @@
$(GHCC) -c lib/Data/Integer.hs
$(GHCC) -c lib/Control/Monad/State/Strict.hs
# $(GHCC) -c lib/Debug/Trace.hs
- $(GHCC) -c lib/System/Console/SimpleReadline.hs
$(GHCC) -c lib/Control/Exception.hs
+ $(GHCC) -c src/System/Console/SimpleReadline.hs
$(GHCC) -c src/Text/ParserComb.hs
$(GHCC) -c src/MicroHs/Ident.hs
$(GHCC) -c src/MicroHs/Expr.hs
@@ -78,9 +78,6 @@
$(GHCC) -c src/MicroHs/Lex.hs
$(GHCC) -c src/MicroHs/Parse.hs
$(GHCC) -c src/MicroHs/IdentMap.hs
-# $(GHCC) -c src/MicroHs/BBMap.hs
- $(GHCC) -c src/MicroHs/StringMapFast.hs
-# $(GHCC) -c -package containers -package base src/MicroHs/StringMap.hs
$(GHCC) -c src/MicroHs/Exp.hs
$(GHCC) -c src/MicroHs/TCMonad.hs
$(GHCC) -c src/MicroHs/TypeCheck.hs
--- a/MicroHs.cabal
+++ b/MicroHs.cabal
@@ -1,6 +1,6 @@
cabal-version: 3.6
name: MicroHs
-version: 0.1
+version: 0.2
synopsis: A compiler for a small subset of Haskell
license: Apache-2.0
license-file: LICENSE
@@ -36,10 +36,10 @@
executable mhs
default-language: Haskell98
- hs-source-dirs: src
+ hs-source-dirs: src ghc
ghc-options: -Wall -F -pgmF ./Tools/convertX.sh -main-is MicroHs.Main
main-is: MicroHs/Main.hs
- default-extensions: ScopedTypeVariables QualifiedDo PatternGuards
+ default-extensions: ScopedTypeVariables QualifiedDo PatternGuards TupleSections
other-modules: MicroHs.Compile
MicroHs.Desugar
MicroHs.Exp
@@ -50,15 +50,17 @@
MicroHs.Parse
MicroHs.StateIO
MicroHs.IdentMap
- MicroHs.StringMapFast
+ MicroHs.Interactive
MicroHs.TCMonad
MicroHs.Translate
MicroHs.TypeCheck
PreludeNoIO
Text.ParserComb
+ System.Console.SimpleReadline
Compat
CompatIO
PrimTable
+ Primitives
build-depends: base >= 4.10 && < 4.20,
containers >= 0.5 && < 0.8,
ghc-prim >= 0.5 && < 0.11,
--- a/lib/System/Console/SimpleReadline.hs
+++ /dev/null
@@ -1,161 +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
- ) where
-import Primitives
-import Prelude
-
--- 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
- putStr prompt
- (_, r) <- loop ([],[]) "" ""
- return r
-
-
--- 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.
-getInputLineHist :: FilePath -> String -> IO (Maybe String)
-getInputLineHist 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 (reverse hist, []) "" ""
--- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
- writeFile hfn $ unlines hist'
- return r -- XXX no type error
-
-getRaw :: IO Int
-getRaw = do
- i <- primGetRaw
- when (i < 0) $
- error "getRaw failed"
- return i
-
-type Hist = ([String], [String])
-
-loop :: Hist -> String -> String -> IO ([String], Maybe String)
-loop hist before after = do
- hFlush stdout
- i <- getRaw
- let
- cur = reverse before ++ after
- back n = putStr (replicate n '\b')
-
- add c = do
- putChar c
- putStr after
- back (length after)
- loop hist (c:before) after
- backward =
- case before of
- [] -> noop
- c:cs -> do
- back 1
- loop hist cs (c:after)
- forward =
- case after of
- [] -> noop
- c:cs -> do
- putChar c
- loop hist (c:before) cs
- bol = do
- back (length before)
- loop hist "" (reverse before ++ after)
- eol = do
- putStr after
- loop hist (before ++ reverse after) ""
- bs = do
- case before of
- [] -> noop
- _:cs -> do
- back 1
- putStr after
- putChar ' '
- back (length after + 1)
- loop hist cs after
- 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) && eqString s (last o) -> []
- | otherwise -> [s]
- h = o ++ l
- return (h, ms)
- erase = do
- eraseLine
- loop hist "" ""
- noop = loop hist before after
- kill = do
- putStr after
- putStr $ concat $ replicate (length after) "\b \b"
- loop 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 h (reverse s) ""
-
- eraseLine = do
- putStr after
- putStr $ concat $ replicate (length before + length after) "\b \b"
-
- case i of
- 4 -> -- CTL-D, EOF
- if null before && null after then
- ret Nothing
- else
- send
- 2 -> backward -- CTL-B, backwards
- 6 -> forward -- CTL-F, forwards
- 1 -> bol -- CTL-A, beginning of line
- 5 -> eol -- CTL-E, end of line
- 8 -> bs -- BS, backspace
- 127 -> bs -- DEL, backspace
- 13 -> send -- CR, return
- 10 -> send -- LF, return
- 14 -> next -- CTL-N, next line
- 15 -> previous -- CTL-P, previous line
- 21 -> erase -- CTL-U, erase line
- 11 -> kill -- CTL-K, kill to eol
- 27 -> do -- ESC
- b <- getRaw
- if b /= ord '[' then
- noop
- else do
- c <- getRaw
- case chr c of
- 'A' -> previous
- 'B' -> next
- 'C' -> forward
- 'D' -> backward
- _ -> noop
- _ -> if i >= 32 && i < 127 then add (chr i) else noop
--- a/src/MicroHs/StringMapFast.hs
+++ /dev/null
@@ -1,186 +1,0 @@
--- Copyright 2023 Lennart Augustsson
--- See LICENSE file for full license.
--- Inspired by https://sortingsearching.com/2020/05/23/2-3-trees.html
-module MicroHs.StringMapFast(module MicroHs.StringMapFast) where
-import Prelude --Xhiding(lookup)
---Ximport Compat
-
-data Map v
- = Empty
- | Leaf String v
- | Node2 Int String (Map v) (Map v)
- | Node3 Int String (Map v) (Map v) (Map v)
- --Xderiving (Show)
-
-data OneOrTwo a
- = OOT1 a
- | OOT2 a a
- --Xderiving (Show)
-
-height :: forall v . Map v -> Int
-height m =
- case m of
- Empty -> undefined
- Leaf _ _ -> 0
- Node2 h _ _ _ -> h
- Node3 h _ _ _ _ -> h
-
-smallest :: forall v . Map v -> String
-smallest m =
- case m of
- Empty -> undefined
- Leaf k _ -> k
- Node2 _ k _ _ -> k
- Node3 _ k _ _ _ -> k
-
-replSmallest :: forall v . (v -> v) -> Map v -> Map v
-replSmallest f m =
- case m of
- Empty -> undefined
- Leaf k v -> Leaf k (f v)
- Node2 h s a b -> Node2 h s (replSmallest f a) b
- Node3 h s a b c -> Node3 h s (replSmallest f a) b c
-
-node2 :: forall v . Map v -> Map v -> Map v
-node2 a b = Node2 (height a + 1) (smallest a) a b
-
-node3 :: forall v . Map v -> Map v -> Map v -> Map v
-node3 a b c = Node3 (height a + 1) (smallest a) a b c
-
-meld :: forall v . OneOrTwo (Map v) -> OneOrTwo (Map v) -> OneOrTwo (Map v)
-meld m1 m2 =
- case m1 of
- OOT1 a ->
- case m2 of
- OOT1 b -> OOT1 $ node2 a b
- OOT2 b c -> OOT1 $ node3 a b c
- OOT2 a b ->
- case m2 of
- OOT1 c -> OOT1 $ node3 a b c
- OOT2 c d -> OOT2 (node2 a b) (node2 c d)
-
-mergeToSameHeight :: forall v . Map v -> Map v -> OneOrTwo (Map v)
-mergeToSameHeight a b =
- if height a < height b then
- case b of
- Node2 _ _ b1 b2 -> meld (mergeToSameHeight a b1) (OOT1 b2)
- Node3 _ _ b1 b2 b3 -> meld (mergeToSameHeight a b1) (OOT2 b2 b3)
- _ -> undefined
- else if height a > height b then
- case a of
- Node2 _ _ a1 a2 -> meld (OOT1 a1) (mergeToSameHeight a2 b)
- Node3 _ _ a1 a2 a3 -> meld (OOT2 a1 a2) (mergeToSameHeight a3 b)
- _ -> undefined
- else
- OOT2 a b
-
--- All elements in aa smaller than elements in ab
-merge :: forall v . Map v -> Map v -> Map v
-merge aa ab =
- case aa of
- Empty -> ab
- _ ->
- case ab of
- Empty -> aa
- _ ->
- case mergeToSameHeight aa ab of
- OOT1 t -> t
- OOT2 t u -> node2 t u
-
-split :: forall v . (String -> Bool) -> Map v -> (Map v, Map v)
-split f am =
- case am of
- Empty -> (Empty, Empty)
- Leaf k _ ->
- if f k then
- (Empty, am)
- else
- (am, Empty)
- Node2 _ _ a b ->
- if f (smallest b) then
- case split f a of
- (a1,a2) -> (a1, merge a2 b)
- else
- case split f b of
- (b1,b2) -> (merge a b1, b2)
- Node3 _ _ a b c ->
- if f (smallest b) then
- case split f a of
- (a1,a2) -> (a1, merge a2 (node2 b c))
- else if f (smallest c) then
- case split f b of
- (b1,b2) -> (merge a b1, merge b2 c)
- else
- case split f c of
- (c1,c2) -> (merge (node2 a b) c1, c2)
-
------------------------------------------
-
-insertWith :: forall v . (v -> v -> v) -> String -> v -> Map v -> Map v
-insertWith f k v a =
- case split (leString k) a of
- (a1, a2) ->
- case a2 of
- Empty -> merge a1 (Leaf k v)
- _ ->
- if leString (smallest a2) k then
- merge a1 (replSmallest (f v) a2)
- else
- merge (merge a1 (Leaf k v)) a2
-
-insert :: forall v . String -> v -> Map v -> Map v
-insert = insertWith const
-
-lookup :: forall v . String -> Map v -> Maybe v
-lookup x am =
- case am of
- Empty -> Nothing
- Leaf k v -> if leString k x && leString x k then Just v else Nothing
- Node2 _ _ a b ->
- if leString (smallest b) x then
- lookup x b
- else
- lookup x a
- Node3 _ _ a b c ->
- if leString (smallest c) x then
- lookup x c
- else if leString (smallest b) x then
- lookup x b
- else
- lookup x a
-
-union :: forall v . Map v -> Map v -> Map v
-union m1 m2 = foldr (uncurry insert) m2 (toList m1)
-
-fromListWith :: forall v . (v -> v -> v) -> [(String, v)] -> Map v
-fromListWith f = foldr (uncurry (insertWith f)) Empty
-
-toList :: forall v . Map v -> [(String, v)]
-toList m =
- let
- pre aa xs =
- case aa of
- Empty -> xs
- Leaf k v -> (k, v) : xs
- Node2 _ _ a b -> pre a (pre b xs)
- Node3 _ _ a b c -> pre a (pre b (pre c xs))
- in pre m []
-
-fromList :: forall v . [(String, v)] -> Map v
-fromList = fromListWith const
-
-empty :: forall v . Map v
-empty = Empty
-
-elems :: forall v . Map v -> [v]
-elems = map snd . toList
-
-size :: forall v . Map v -> Int
-size m =
- case m of
- Empty -> 0
- Leaf _ _ -> 1
- Node2 _ _ m1 m2 -> size m1 + size m2
- Node3 _ _ m1 m2 m3 -> size m1 + size m2 + size m3
--- /dev/null
+++ b/src/System/Console/SimpleReadline.hs
@@ -1,0 +1,164 @@
+-- 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
+ ) where
+import Primitives
+import Prelude
+import Data.Char
+import System.IO
+--Ximport Compat
+
+-- 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
+ putStr prompt
+ (_, r) <- loop ([],[]) "" ""
+ return r
+
+
+-- 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.
+getInputLineHist :: FilePath -> String -> IO (Maybe String)
+getInputLineHist 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 (reverse hist, []) "" ""
+-- putStrLn $ "done: " ++ hfn ++ "\n" ++ unlines hist'
+ writeFile hfn $ unlines hist'
+ return r -- XXX no type error
+
+getRaw :: IO Int
+getRaw = do
+ i <- primGetRaw
+ when (i < 0) $
+ error "getRaw failed"
+ return i
+
+type Hist = ([String], [String])
+
+loop :: Hist -> String -> String -> IO ([String], Maybe String)
+loop hist before after = do
+ hFlush stdout
+ i <- getRaw
+ let
+ cur = reverse before ++ after
+ back n = putStr (replicate n '\b')
+
+ add c = do
+ putChar c
+ putStr after
+ back (length after)
+ loop hist (c:before) after
+ backward =
+ case before of
+ [] -> noop
+ c:cs -> do
+ back 1
+ loop hist cs (c:after)
+ forward =
+ case after of
+ [] -> noop
+ c:cs -> do
+ putChar c
+ loop hist (c:before) cs
+ bol = do
+ back (length before)
+ loop hist "" (reverse before ++ after)
+ eol = do
+ putStr after
+ loop hist (before ++ reverse after) ""
+ bs = do
+ case before of
+ [] -> noop
+ _:cs -> do
+ back 1
+ putStr after
+ putChar ' '
+ back (length after + 1)
+ loop hist cs after
+ 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) && eqString s (last o) -> []
+ | otherwise -> [s]
+ h = o ++ l
+ return (h, ms)
+ erase = do
+ eraseLine
+ loop hist "" ""
+ noop = loop hist before after
+ kill = do
+ putStr after
+ putStr $ concat $ replicate (length after) "\b \b"
+ loop 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 h (reverse s) ""
+
+ eraseLine = do
+ putStr after
+ putStr $ concat $ replicate (length before + length after) "\b \b"
+
+ case i of
+ 4 -> -- CTL-D, EOF
+ if null before && null after then
+ ret Nothing
+ else
+ send
+ 2 -> backward -- CTL-B, backwards
+ 6 -> forward -- CTL-F, forwards
+ 1 -> bol -- CTL-A, beginning of line
+ 5 -> eol -- CTL-E, end of line
+ 8 -> bs -- BS, backspace
+ 127 -> bs -- DEL, backspace
+ 13 -> send -- CR, return
+ 10 -> send -- LF, return
+ 14 -> next -- CTL-N, next line
+ 15 -> previous -- CTL-P, previous line
+ 21 -> erase -- CTL-U, erase line
+ 11 -> kill -- CTL-K, kill to eol
+ 27 -> do -- ESC
+ b <- getRaw
+ if b /= ord '[' then
+ noop
+ else do
+ c <- getRaw
+ case chr c of
+ 'A' -> previous
+ 'B' -> next
+ 'C' -> forward
+ 'D' -> backward
+ _ -> noop
+ _ -> if i >= 32 && i < 127 then add (chr i) else noop
--
⑨