shithub: MicroHs

Download patch

ref: 572ded9579e8986158cffe3d7f4d54f53a4adefb
parent: f4e4a0da87186833e0be6b4d89c16625b2a18776
author: Lennart Augustsson <lennart@augustsson.net>
date: Sun Aug 27 07:38:03 EDT 2023 

Make it compile.


--- a/Makefile
+++ b/Makefile
@@ -53,6 +53,7 @@
 	$(GHCC) -c lib/Unsafe/Coerce.hs
 	$(GHCC) -c lib/Control/Monad/State/Strict.hs
 	$(GHCC) -c src/Text/ParserComb.hs
+#	$(GHCC) -c src/MicroHs/Lex.hs
 	$(GHCC) -c src/MicroHs/Parse.hs
 	$(GHCC) -c src/MicroHs/StringMap.hs
 	$(GHCC) -c src/MicroHs/StringMapFast.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
 v3.1
-693
-(($A :0 ((_517 _471) ((($S' ($C ((($C' ($S' _517)) ($C _2)) (($B ($B (_517 _545))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B ($B $B))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) (($B $B) (($B $B) (($B $C') (($B ($S' _518)) ((($C' $B) (($B _605) (($B _535) ((($C' _642) _8) 0)))) (($B (_605 _538)) (($B (_550 "top level defns: ")) _499)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _518)) ((($C' $B) (($B _605) (($B _535) ((($C' _642) _8) 1)))) (_534 ($T (($B ($B (_605 _538))) ((($C' $B) _550) (($B (_550 " = ")) _241))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _518))) ((($C' $B) (($B $B) (($B _605) (($B _540) _11)))) (($B ($B (_550 _1))) (($B (($C' _550) _499)) (_550 (($O 10) $K))))))) (($B ($B (_517 _545))) ((($C' $B) (($B $B) (($B _605) (($B _535) ((($C' _642) _8) 0))))) (($B ($B (_605 _538))) (($B ($B (_550 "final pass            "))) ((($C' ($C' _550)) (($B ($B (_512 6))) (($B ($B _499)) _636))) "ms")))))))) _3)))) _496))) (($B (($C' $C) (($B ($C _555)) _241))) (($C _568) (_585 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_550 "(($A :"))))) (($B ($B (($C' $B) (($B _550) _499)))) (($B ($B ($B (_550 (($O 32) $K))))) ((($C' $B) (($B ($C' _550)) ($B _241))) (($B (_550 ") ")) (($C _550) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _218)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _605) (($B _602) (($B (_605 _651)) (($B (_550 "main: findIdent: ")) _316))))) ($C _489)))) (($B ($B _493)) (($B (($C' _552) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _568) (_585 0)))))) (($B (_605 _217)) (($B (_550 (($O 95) $K))) _499))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _567) (_554 (_510 "-v")))) ((_584 _510) "-r"))) (($B (_548 (($O 46) $K))) (($B _604) (_553 ((_572 _627) "-i")))))) (($B (_605 _579)) ((($C' _550) (($B _604) (_553 ((_572 _627) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _638) _567) 1)) (_651 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _579)) (_554 ((_606 _647) ((_606 (_510 (($O 45) $K))) (_565 1)))))))) (($A :1 "v3.1\10&") (($A :2 ((($S' ($S' _517)) _16) (($B ($B ($B (_517 _545)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _518) (($B (_605 _536)) (($B (_605 (_566 1000000))) _44)))))) (($B ($B ($B ($B (_517 _545))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _518))) ((($C' $B) (($B $B) (($B _605) (($B _535) ((($C' _642) _8) 0))))) (($B ($B (_605 _538))) (($B ($B (_550 "combinator conversion "))) ((($C' ($C' _550)) (($B ($B (_512 6))) (($B ($B _499)) _636))) "ms"))))))) (($B ($B _519)) (($B $P) (($C _319) "main"))))))) (_552 ($T ((($C' ($C' $O)) ((($C' $B) $P) _244)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_605 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _211))) (($C' ($C' _552)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _605) (($B _602) (($B (_605 _651)) (_550 "not found "))))) ($C _212))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _243))) (($B (_605 (_602 (_651 "primlookup")))) (($C (_588 _510)) _5))))) (_651 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K)
\ No newline at end of file
+694
+(($A :0 ((_517 _471) ((($S' ($C ((($C' ($S' _517)) ($C _2)) (($B ($B (_517 _545))) ((($C' ($S' $C)) ((($C' ($C' $C)) ((($C' ($C' ($C' $S'))) (($B ($B ($B $C))) ((($C' ($C' ($C' ($C' $C)))) ((($C' ($C' ($C' ($C' ($S' $B))))) ((($C' ($C' ($C' ($C' ($C' $S))))) ((($C' ($C' ($C' $B))) (($B ($B ($B ($C' $C)))) ((($C' ($C' ($C' ($C' ($C' $S'))))) (($B ($B ($B ($B ($B $C))))) ((($C' ($C' ($C' ($C' ($C' ($C' $B)))))) ((($C' ($C' ($C' ($S' ($C' $B))))) (($B ($B ($B ($B ($B $B))))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) (($B $B) (($B $B) (($B $C') (($B ($S' _518)) ((($C' $B) (($B _605) (($B _535) ((($C' _643) _8) 0)))) (($B (_605 _538)) (($B (_550 "top level defns: ")) _499)))))))) ((($S' $B) (($B $B) (($B ($C' $B)) (($B ($B $B)) (($B ($B _518)) ((($C' $B) (($B _605) (($B _535) ((($C' _643) _8) 1)))) (_534 ($T (($B ($B (_605 _538))) ((($C' $B) _550) (($B (_550 " = ")) _241))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _518))) ((($C' $B) (($B $B) (($B _605) (($B _540) _11)))) (($B ($B (_550 _1))) (($B (($C' _550) _499)) (_550 (($O 10) $K))))))) (($B ($B (_517 _545))) ((($C' $B) (($B $B) (($B _605) (($B _535) ((($C' _643) _8) 0))))) (($B ($B (_605 _538))) (($B ($B (_550 "final pass            "))) ((($C' ($C' _550)) (($B ($B (_512 6))) (($B ($B _499)) _637))) "ms")))))))) _3)))) _496))) (($B (($C' $C) (($B ($C _555)) _241))) (($C _568) (_585 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_550 "(($A :"))))) (($B ($B (($C' $B) (($B _550) _499)))) (($B ($B ($B (_550 (($O 32) $K))))) ((($C' $B) (($B ($C' _550)) ($B _241))) (($B (_550 ") ")) (($C _550) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _218)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _605) (($B _602) (($B (_605 _652)) (($B (_550 "main: findIdent: ")) _316))))) ($C _489)))) (($B ($B _493)) (($B (($C' _552) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B ($C $P))) $K)))))) (($C _568) (_585 0)))))) (($B (_605 _217)) (($B (_550 (($O 95) $K))) _499))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _567) (_554 (_510 "-v")))) ((_584 _510) "-r"))) (($B (_548 (($O 46) $K))) (($B _604) (_553 ((_572 _628) "-i")))))) (($B (_605 _579)) ((($C' _550) (($B _604) (_553 ((_572 _628) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _639) _567) 1)) (_652 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _579)) (_554 ((_606 _648) ((_606 (_510 (($O 45) $K))) (_565 1)))))))) (($A :1 "v3.1\10&") (($A :2 ((($S' ($S' _517)) _16) (($B ($B ($B (_517 _545)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _518) (($B (_605 _536)) (($B (_605 (_566 1000000))) _44)))))) (($B ($B ($B ($B (_517 _545))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _518))) ((($C' $B) (($B $B) (($B _605) (($B _535) ((($C' _643) _8) 0))))) (($B ($B (_605 _538))) (($B ($B (_550 "combinator conversion "))) ((($C' ($C' _550)) (($B ($B (_512 6))) (($B ($B _499)) _637))) "ms"))))))) (($B ($B _519)) (($B $P) (($C _319) "main"))))))) (_552 ($T ((($C' ($C' $O)) ((($C' $B) $P) _244)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_605 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _211))) (($C' ($C' _552)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _605) (($B _602) (($B (_605 _652)) (_550 "not found "))))) ($C _212))))) (($A :4 ((($C' $C) ((($S' $C) ((($C' ($C' $S')) (($S $P) ((($S' ($C' $B)) (($B ($B _6)) _4)) _4))) ($BK $K))) ((($C' ($C' $C)) (($B (($C' $C) (($B ($P _6)) $K))) ((($C' $B) _4) _243))) (($B (_605 (_602 (_652 "primlookup")))) (($C (_588 _510)) _5))))) (_652 "trans: impossible"))) (($A :5 (($O (($P (($O 66) $K)) $B)) (($O (($P (($O 79) $K)) $O)) (($O (($P (($O 75) $K)) $K)) (($O (($P "C'") $C')) (($O (($P (($O 67) $K)) $C)) (($O (($P (($O 65) $K)) $A)) (($O (($P "S'") $S')) (($O (($P (($O 80) $K)) $P)) (($O (($P (($O 73) $K)) $I)) (($O (($P (($O 83) $K)) $S)) (($O (($P (($O 84) $K)) $T)) (($O (($P (($O 89) $K)) $Y)) (($O (($P "B'") $B')) (($O (($P "BK") $BK)) (($O (($P (($O 43) $K)) $+)) (($O (($P (($O 45) $K)
\ No newline at end of file
--- a/lib/Data/Char.hs
+++ b/lib/Data/Char.hs
@@ -28,7 +28,7 @@
 isDigit c = (P.primCharLE '0' c) && (P.primCharLE c '9')
 
 isPrint :: Char -> Bool
-isPrint c = P.primCharGE ' ' c && P.primCharLE c '~'
+isPrint c = P.primCharLE ' ' c && P.primCharLE c '~'
 
 eqChar :: Char -> Char -> Bool
 eqChar = P.primCharEQ
--- a/lib/Text/String.hs
+++ b/lib/Text/String.hs
@@ -11,11 +11,13 @@
 
 showChar :: Char -> String
 showChar c =
-  case lookupBy eqChar c spec of
-    Nothing -> if isPrint c then ['\'', c, '\''] else "'\\" ++ showInt (ord c) ++ "'"
-    Just s  -> s
-  where
-    spec = [('\n', "'\\n'"), ('\r', "'\\r'"), ('\t', "'\\t'")]
+  let
+    spec = [('\n', "'\\n'"), ('\r', "'\\r'"), ('\t', "'\\t'"),
+            ('\\', "'\\\\'"), ('\'', "'\\''")]
+  in
+    case lookupBy eqChar c spec of
+      Nothing -> if isPrint c then ['\'', c, '\''] else "'\\" ++ showInt (ord c) ++ "'"
+      Just s  -> s
 
 showString :: String -> String
 showString s =
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -1,12 +1,14 @@
-module MicroHs.Lex where
+module MicroHs.Lex(lexTop) where
 import Prelude --Xhiding(lex, showChar)
 import Data.Char
 --Ximport Compat
-import Debug.Trace
+--import Debug.Trace
 
+{-
 foo fn = do
   s <- readFile fn
   print (lexTop s)
+-}
 
 data Token
   = TIdent  Loc [String] String
@@ -43,28 +45,32 @@
   where
     (ds, rs) = span isIdent cs
 lex l c cs@(d:_) | isUpper d = upperIdent l c [] cs
-lex l c ('-':d:cs) | isDigit d = TInt (l, c) (readInt ('-':d:ds)) : lex l (c + 2 + length ds) rs
-  where
-    (ds, rs) = span isDigit cs
-lex l c (d:cs) | isDigit d = TInt (l, c) (readInt (d:ds)) : lex l (c + 1 + length ds) rs
-  where
-    (ds, rs) = span isDigit cs
-lex l c (d:cs) | isOper d  = TIdent (l, c) [] (d:ds) : lex l (c + 1 + length ds) rs
-  where
-    (ds, rs) = span isOper cs
+lex l c ('-':d:cs) | isDigit d =
+  case span isDigit cs of
+    (ds, rs) -> TInt (l, c) (readInt ('-':d:ds)) : lex l (c + 2 + length ds) rs
+lex l c (d:cs) | isDigit d =
+  case span isDigit cs of
+    (ds, rs) -> TInt (l, c) (readInt (d:ds)) : lex l (c + 1 + length ds) rs
+lex l c (d:cs) | isOper d  =
+  case span isOper cs of
+    (ds, rs) -> TIdent (l, c) [] (d:ds) : lex l (c + 1 + length ds) rs
 lex l c (d:cs) | isSpec d  = TSpec (l, c) d : lex l (c+1) cs
-lex l c ('"':cs) = t : lex l (c + 2 + n) rs
-  where
+lex l c ('"':cs) =
+  let
     loc = (l, c)
-    (t, n, rs) = takeChars loc (TString loc) '"' 0 [] cs
-lex l c ('\'':cs) = t : lex l (c + 2 + n) rs
-  where
+  in 
+    case takeChars loc (TString loc) '"' 0 [] cs of
+      (t, n, rs) -> t : lex l (c + 2 + n) rs
+lex l c ('\'':cs) =
+  let
     loc = (l, c)
-    (t, n, rs) = takeChars loc (TChar loc . head) '\'' 0 [] cs  -- XXX head
+  in
+    case takeChars loc (TChar loc . head) '\'' 0 [] cs  -- XXX head of
+      (t, n, rs) -> t : lex l (c + 2 + n) rs
 lex l c (d:_) = [TError (l, c) $ "Unrecognized input: " ++ showChar d]
 lex _ _ [] = []
 
--- Skip a {- -} style comment
+-- Skip a { - - } style comment
 skipNest :: Line -> Col -> Int -> String -> [Token]
 skipNest l c 0 cs = lex l c cs
 skipNest l c n ('{':'-':cs) = skipNest l (c+2) (n+1) cs
@@ -72,7 +78,7 @@
 skipNest l _ n ('\n':cs)    = skipNest (l+1) 1 n     cs
 skipNest l c n ('\r':cs)    = skipNest l     c n     cs
 skipNest l c n (_:cs)       = skipNest l (c+1) n     cs
-skipNest l c _ []           = [TError (l, c) "Unclosed {- comment"]
+skipNest l c _ []           = [TError (l, c) "Unclosed {\- comment"]
 
 -- Skip a -- style comment
 skipLine :: Line -> Col -> String -> [Token]
@@ -103,10 +109,10 @@
 decodeChar n []       = ('X',  n,   [])
 
 isOper :: Char -> Bool
-isOper c = elem c "@\\=+-:<>.!#$%^&*/|~?"
+isOper c = elemBy eqChar c "@\\=+-:<>.!#$%^&*/|~?"
 
 isSpec :: Char -> Bool
-isSpec c = elem c "()[],{}`;"
+isSpec c = elemBy eqChar c "()[],{}`;"
 
 isIdent :: Char -> Bool
 isIdent c = isLower_ c || isUpper c || isDigit c || eqChar c '\''
@@ -130,7 +136,7 @@
       _ -> TIdent (l, c) (reverse qs) ds : lex l (c + length ds) rs
 
 tIdent :: Loc -> [String] -> String -> [Token] -> [Token]
-tIdent loc qs kw ts | elem kw ["let", "where", "do", "of"]
+tIdent loc qs kw ts | elemBy eqString kw ["let", "where", "do", "of"]
                     , Just n <- ins ts = ti : TBrace n : drp ts
                     | otherwise = ti : ts
   where
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -40,7 +40,7 @@
 --import Debug.Trace
 --Ximport Compat
 --Ximport GHC.Stack
-import MicroHs.Lex
+--import MicroHs.Lex
 
 data EModule = EModule IdentModule [ExportSpec] [EDef]
   --Xderiving (Show, Eq)
@@ -474,6 +474,8 @@
     '\''
   else if eqChar c '"' then
     '"'
+  else if eqChar c '\'' then
+    '\''
   else
     error $ "decodeChar: " ++ showChar c
 
-- 
⑨