shithub: MicroHs

Info  •  Files  •  Log  •  Branches

Fix some bugs.

--- a/Makefile

+++ b/Makefile

@@ -53,7 +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/Lex.hs

 	$(GHCC) -c src/MicroHs/Expr.hs

 	$(GHCC) -c src/MicroHs/Parse.hs

 	$(GHCC) -c src/MicroHs/StringMap.hs

--- a/src/MicroHs/Desugar.hs

+++ b/src/MicroHs/Desugar.hs

@@ -415,10 +415,13 @@

   let

     isConPat (p:_, _, _) = not (isPVar p)

     isConPat _ = impossible

-    isVarPat (p:_, _, g) = isPVar p && not g  -- only group variable patterns that cannot fail

-    isVarPat _ = False

     (ps, nps) = span isConPat am

-    (ds, rs)  = spanUntil isVarPat nps

+    loop xs [] = (reverse xs, [])

+    loop xs pps@(pg@(p:_, _, g) : rps) | not (isPVar p) = (reverse xs, pps)

+                                       | otherwise = if g then (reverse (pg:xs), rps)

+                                                         else loop (pg:xs) rps

+    loop _ _ = impossible

+    (ds, rs)  = loop [] nps

   in (ps, ds, rs)

 -- Change from x to y inside e.

--- a/src/MicroHs/Lex.hs

+++ b/src/MicroHs/Lex.hs

@@ -37,13 +37,14 @@

 --lex l c ('\r':cs) = lex     l c cs

 lex l c ('{':'-':cs) = skipNest l (c+2) 1 cs

 lex l c ('-':'-':cs) | isComm rs = skipLine l (c+2+length ds) cs

-  where

-    (ds, rs) = span (eqChar '-') cs

-    isComm [] = True

+  where {

+    (ds, rs) = span (eqChar '-') cs;

+    isComm [] = True;

     isComm (d:_) = not (isOper d)

-lex l c (d:cs) | isLower_ d = tIdent (l, c) [] (d:ds) (lex l (c + 1 + length ds) rs)

-  where

-    (ds, rs) = span isIdent cs

+    }

+lex l c (d:cs) | isLower_ d =

+  case span isIdent cs of

+    (ds, rs) -> tIdent (l, c) [] (d:ds) (lex l (c + 1 + length ds) rs)

 lex l c cs@(d:_) | isUpper d = upperIdent l c [] cs

 lex l c ('-':d:cs) | isDigit d =

   case span isDigit cs of

@@ -65,7 +66,7 @@

   let

     loc = (l, c)

   in

-    case takeChars loc (TChar loc . head) '\'' 0 [] cs  -- XXX head of

+    case takeChars loc (TChar loc . head) '\'' 0 [] cs of  -- 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 _ _ [] = []

@@ -78,7 +79,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]

@@ -129,10 +130,11 @@

       '.':cs@(d:_) | isUpper d -> upperIdent l (c + 1 + length ds) (ds:qs) cs

                    | isLower d -> ident isIdent

                    | isOper  d -> ident isOper

-         where

+         where {

            ident p =

              case span p cs of

                (xs, ys) -> tIdent (l, c) (reverse (ds:qs)) xs (lex l (c + 1 + length ds + length xs) ys)

+           }

       _ -> TIdent (l, c) (reverse qs) ds : lex l (c + length ds) rs

 tIdent :: Loc -> [String] -> String -> [Token] -> [Token]

@@ -139,15 +141,16 @@

 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

-    ti = TIdent loc qs kw

+  where {

+    ti = TIdent loc qs kw;

-    ins (TSpec _ '{' : _) = Nothing

-    ins tts = Just (snd (tokensLoc tts))

+    ins (TSpec _ '{' : _) = Nothing;

+    ins tts = Just (snd (tokensLoc tts));

     -- Since we inserted a {n} we don't want the <n> that follows.

-    drp (TIndent _ : tts) = tts

+    drp (TIndent _ : tts) = tts;

     drp tts = tts

+    }

 tokensLoc :: [Token] -> Loc

 tokensLoc (TIdent  loc _ _:_) = loc

@@ -171,4 +174,4 @@

 layout          ms      (t               : ts)    =                        t : layout     ms  ts

 layout     (_ : ms)     []                        = TSpec (0,0) '}'          : layout     ms  []

 layout          []      []                        =                            []

---layout           _      _                         = TError (0,0) "layout error"  : []

\ No newline at end of file

+--layout           _      _                         = TError (0,0) "layout error"  : []

-- 

⑨