ref: 52fd5c4a6c2e7a95ddfbec5506d9b97a1afa33da
parent: 41eca634788b43a01fa0b2690516fc38e7e86743
author: Lennart Augustsson <lennart.augustsson@epicgames.com>
date: Thu Aug 31 06:30:11 EDT 2023
Location information in every identifier. This slows down compilation a lot. :(
--- a/Makefile
+++ b/Makefile
@@ -56,7 +56,6 @@
$(GHCC) -c lib/Data/Integer.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/Expr.hs
$(GHCC) -c src/MicroHs/Lex.hs
$(GHCC) -c src/MicroHs/Parse.hs
--- a/comb/mhs.comb
+++ b/comb/mhs.comb
@@ -1,3 +1,3 @@
v3.2
-732
-(($A :0 ((_542 _496) ((($S' ($C ((($C' ($S' _542)) (($B ($C _2)) _418)) (($B ($B (_542 _570))) ((($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')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _543)) ((($C' $B) (($B _631) (($B _560) ((($C' _669) _8) 0)))) (($B (_631 _563)) (($B (_576 "top level defns: ")) _524)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _543)) ((($C' $B) (($B _631) (($B _560) ((($C' _669) _8) 1)))) (_559 ($T (($B ($B (_631 _563))) ((($C' $B) (($B _576) _479)) (($B (_576 " = ")) _389))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _543))) ((($C' $B) ($B' (($B _631) (($B _565) _11)))) (($B ($B (_576 _1))) (($B (($C' _576) _524)) (_576 (($O 10) $K))))))) (($B ($B (_542 _570))) ((($C' $B) ($B' (($B _631) (($B _560) ((($C' _669) _8) 0))))) (($B ($B (_631 _563))) (($B ($B (_576 "final pass "))) ((($C' ($C' _576)) (($B ($B (_537 6))) (($B ($B _524)) _663))) "ms")))))))) _3)))) _521))) (($B (($C' $C) (($B ($C _581)) _389))) (($C _594) (_611 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_576 "(($A :"))))) (($B ($B (($C' $B) (($B _576) _524)))) (($B ($B ($B (_576 (($O 32) $K))))) ((($C' $B) (($B ($C' _576)) ($B _389))) (($B (_576 ") ")) (($C _576) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _366)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _631) (($B _628) (($B (_631 _678)) (($B (_576 "main: findIdent: ")) _479))))) (($C' _514) _419)))) (($B ($B _518)) (($B (($C' _578) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _419))) $K)))))) (($C _594) (_611 0)))))) (($B (_631 _365)) (($B (_631 _418)) (($B (_576 (($O 95) $K))) _524)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _593) (_580 (_535 "-v")))) ((_610 _535) "-r"))) (($B (_574 (($O 46) $K))) (($B _630) (_579 ((_598 _654) "-i")))))) (($B (_631 _605)) ((($C' _576) (($B _630) (_579 ((_598 _654) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _665) _593) 1)) (_678 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _605)) (_580 ((_632 _674) ((_632 (_535 (($O 45) $K))) (_591 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _542)) _16) (($B ($B ($B (_542 _570)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _543) (($B (_631 _561)) (($B (_631 (_592 1000000))) _190)))))) (($B ($B ($B ($B (_542 _570))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _543))) ((($C' $B) ($B' (($B _631) (($B _560) ((($C' _669) _8) 0))))) (($B ($B (_631 _563))) (($B ($B (_576 "combinator conversion "))) ((($C' ($C' _576)) (($B ($B (_537 6))) (($B ($B _524)) _663))) "ms"))))))) (($B ($B _544)) (($B $P) (($C _421) (_418 "main")))))))) (_578 ($T ((($C' ($C' $O)) ((($C' $B) $P) _392)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_631 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _359))) (($C' ($C' _578)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _631) (($B _628) (($B (_631 _678)) (($B (_576 "not found ")) _479))))) ($C _360))))) (($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) _391))) (($B (_631 (_628 (_678 "primlookup")))) (($C (_614 _535)) _5))))) (_678 "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
\ No newline at end of file
+738
+(($A :0 ((_548 _502) ((($S' ($C ((($C' ($S' _548)) (($B ($C _2)) _418)) (($B ($B (_548 _576))) ((($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')))) ((($C' ($C' ($C' ($C' $B)))) ((($S' $B) ($B' ($B' (($B $C') (($B ($S' _549)) ((($C' $B) (($B _637) (($B _566) ((($C' _675) _8) 0)))) (($B (_637 _569)) (($B (_582 "top level defns: ")) _530)))))))) ((($S' $B) ($B' (($B ($C' $B)) (($B $B') (($B ($B _549)) ((($C' $B) (($B _637) (($B _566) ((($C' _675) _8) 1)))) (_565 ($T (($B ($B (_637 _569))) ((($C' $B) (($B _582) _485)) (($B (_582 " = ")) _392))))))))))) ((($C' $B) ((($S' $C') (($B $C') (($B $C') _9))) ((($S' $B) (($B ($C' ($C' _549))) ((($C' $B) ($B' (($B _637) (($B _571) _11)))) (($B ($B (_582 _1))) (($B (($C' _582) _530)) (_582 (($O 10) $K))))))) (($B ($B (_548 _576))) ((($C' $B) ($B' (($B _637) (($B _566) ((($C' _675) _8) 0))))) (($B ($B (_637 _569))) (($B ($B (_582 "final pass "))) ((($C' ($C' _582)) (($B ($B (_543 6))) (($B ($B _530)) _669))) "ms")))))))) _3)))) _527))) (($B (($C' $C) (($B ($C _587)) _392))) (($C _600) (_617 0))))) (($B ($C $B)) (($B ($B ($C $B))) (($B ($B $BK)) (($B ($B ($B ($B (_582 "(($A :"))))) (($B ($B (($C' $B) (($B _582) _530)))) (($B ($B ($B (_582 (($O 32) $K))))) ((($C' $B) (($B ($C' _582)) ($B _392))) (($B (_582 ") ")) (($C _582) (($O 41) $K))))))))))))) (($B $Y) ((($C' ($C' $S)) ((($C' ($C' $S)) ((($C' $B) $P) ((($S' ($C' $B)) ($B _369)) $I))) ($BK $K))) $K))))) $T)) (($B (($S' _637) (($B _634) (($B (_637 _684)) (($B (_582 "main: findIdent: ")) _485))))) (($C' _520) _420)))) (($B ($B _524)) (($B (($C' _584) (($B $T) (($B ($C $B)) (($B ($B $BK)) ((($C' ($C' ($C' $O))) ($B (($C' $P) _420))) $K)))))) (($C _600) (_617 0)))))) (($B (_637 _368)) (($B (_637 _418)) (($B (_582 (($O 95) $K))) _530)))))) ($T $A))) ($T $K))) (($B $Y) $K)))))) (($S (($S ((($S' _7) (($B _599) (_586 (_541 "-v")))) ((_616 _541) "-r"))) (($B (_580 (($O 46) $K))) (($B _636) (_585 ((_604 _660) "-i")))))) (($B (_637 _611)) ((($C' _582) (($B _636) (_585 ((_604 _660) "-o")))) (($O "out.comb") $K))))) (($B (($S (($C ((($C' _671) _599) 1)) (_684 "Usage: uhs [-v] [-r] [-iPATH] [-oFILE] ModuleName"))) _611)) (_586 ((_638 _680) ((_638 (_541 (($O 45) $K))) (_597 1)))))))) (($A :1 "v3.2\10&") (($A :2 ((($S' ($S' _548)) _16) (($B ($B ($B (_548 _576)))) ((($C' ($C' $B)) (($B ($B ($C' (($S' _549) (($B (_637 _567)) (($B (_637 (_598 1000000))) _193)))))) (($B ($B ($B ($B (_548 _576))))) ((($C' $B) (($B ($C' $B)) (($B ($B ($C' _549))) ((($C' $B) ($B' (($B _637) (($B _566) ((($C' _675) _8) 0))))) (($B ($B (_637 _569))) (($B ($B (_582 "combinator conversion "))) ((($C' ($C' _582)) (($B ($B (_543 6))) (($B ($B _530)) _669))) "ms"))))))) (($B ($B _550)) (($B $P) (($C _427) (_418 "main")))))))) (_584 ($T ((($C' ($C' $O)) ((($C' $B) $P) _395)) $K))))))) (($A :3 ($T (($C ((($C' $C') (($B ($S' ($B (_637 _6)))) ($C $C))) (($B ($B $Y)) (($B ($B ($B _362))) (($C' ($C' _584)) (($B ($B $T)) ((($C' ($C' ($C' ($C' $O)))) (($B ($B (($C' $B) $P))) ($B _4))) $K))))))) (($B (($S' _637) (($B _634) (($B (_637 _684)) (($B (_582 "not found ")) _485))))) ($C _363))))) (($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) _394))) (($B (_637 (_634 (_684 "primlookup")))) (($C (_620 _541)) _5))))) (_684 "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
\ No newline at end of file
--- a/src/MicroHs/Expr.hs
+++ b/src/MicroHs/Expr.hs
@@ -1,5 +1,7 @@
module MicroHs.Expr(
- Ident, mkIdent, unIdent, eqIdent, qual, showIdent,
+ Ident, mkIdent, mkIdentLoc, unIdent, eqIdent, qual, showIdent,
+ SLoc(..),
+ Line, Col, Loc,
IdentModule,
EModule(..),
ExportSpec(..),
@@ -32,37 +34,56 @@
--Ximport Compat
--Ximport GHC.Stack
-data EModule = EModule IdentModule [ExportSpec] [EDef]
- --Xderiving (Show, Eq)
+type Line = Int
+type Col = Int
+type Loc = (Line, Col)
+--type SLoc = (FilePath, Loc)
-data ExportSpec
- = ExpModule IdentModule
- | ExpTypeCon Ident
- | ExpType Ident
- | ExpValue Ident
+data SLoc = SLoc FilePath Line Col
--Xderiving (Show, Eq)
-newtype Ident = Ident String
+noSLoc :: SLoc
+noSLoc = SLoc "" 0 0
+
+--noLoc :: Loc
+--noLoc = (0,0)
+
+data Ident = Ident SLoc String
--Xderiving (Show, Eq)
type IdentModule = Ident
mkIdent :: String -> Ident
-mkIdent = Ident
+mkIdent = Ident noSLoc
+mkIdentLoc :: FilePath -> Loc -> String -> Ident
+mkIdentLoc fn (l, c) s = Ident (SLoc fn l c) s
+
unIdent :: Ident -> String
-unIdent (Ident s) = s
+unIdent (Ident _ s) = s
eqIdent :: Ident -> Ident -> Bool
-eqIdent (Ident i) (Ident j) = eqString i j
+eqIdent (Ident _ i) (Ident _ j) = eqString i j
+----------------------
+
+data EModule = EModule IdentModule [ExportSpec] [EDef]
+ --Xderiving (Show, Eq)
+
+data ExportSpec
+ = ExpModule IdentModule
+ | ExpTypeCon Ident
+ | ExpType Ident
+ | ExpValue Ident
+ --Xderiving (Show, Eq)
+
qual :: Ident -> Ident -> Ident
-qual (Ident qi) (Ident i) = Ident (qi ++ "." ++ i)
+qual (Ident loc qi) (Ident _ i) = Ident loc (qi ++ "." ++ i)
isConIdent :: Ident -> Bool
-isConIdent (Ident i) =
+isConIdent (Ident _ i) =
let
c = head i
- in isUpper c || eqChar c ':' || eqChar c ',' || eqString i "[]"
+ in isUpper c || eqChar c ':' || eqChar c ',' || eqString i "[]" || eqString i "()"
data EDef
= Data LHS [Constr]
@@ -201,10 +222,10 @@
-}
tupleConstr :: Int -> Ident
-tupleConstr n = Ident (replicate (n - 1) ',')
+tupleConstr n = mkIdent (replicate (n - 1) ',')
untupleConstr :: Ident -> Int
-untupleConstr (Ident s) = length s + 1
+untupleConstr i = length (unIdent i) + 1
---------------------------------
@@ -291,7 +312,7 @@
-}
showIdent :: Ident -> String
-showIdent (Ident i) = i
+showIdent (Ident _ i) = i
showEDef :: EDef -> String
showEDef def =
@@ -328,11 +349,11 @@
showExpr :: Expr -> String
showExpr ae =
case ae of
---X EVar (Ident "Primitives.Char") -> "Char"
---X EVar (Ident "Primitives.->") -> "(->)"
---X EApp (EApp (EVar (Ident "Primitives.->")) a) b -> "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"---X EApp (EVar (Ident "Data.List.[]")) a -> "[" ++ showExpr a ++ "]"
---X EApp (EApp (EVar (Ident ",")) a) b -> showExpr (ETuple [a,b])
+--X EVar (Ident _ "Primitives.Char") -> "Char"
+--X EVar (Ident _ "Primitives.->") -> "(->)"
+--X EApp (EApp (EVar (Ident _ "Primitives.->")) a) b -> "(" ++ showExpr a ++ " -> " ++ showExpr b ++ ")"+--X EApp (EVar (Ident _ "Data.List.[]")) a -> "[" ++ showExpr a ++ "]"
+--X EApp (EApp (EVar (Ident _ ",")) a) b -> showExpr (ETuple [a,b])
EVar v -> showIdent v
EApp f a -> "(" ++ showExpr f ++ " " ++ showExpr a ++ ")"ELam ps e -> "(\\" ++ unwords (map showExpr ps) ++ " -> " ++ showExpr e ++ ")"
--- a/src/MicroHs/Lex.hs
+++ b/src/MicroHs/Lex.hs
@@ -8,6 +8,7 @@
import Data.Char
--Ximport Compat
--import Debug.Trace
+import MicroHs.Expr --X(Line, Col, Loc)
data Token
= TIdent Loc [String] String
@@ -19,11 +20,6 @@
| TBrace Loc
| TIndent Loc
--Xderiving (Show)
-
-type Line = Int
-type Col = Int
-
-type Loc = (Line, Col)
incrLine :: Loc -> Loc
incrLine (l, _) = (l+1, 1)
--- a/src/MicroHs/Parse.hs
+++ b/src/MicroHs/Parse.hs
@@ -16,19 +16,27 @@
--Ximport Compat
-type P a = Prsr () Token a
+type P a = Prsr FilePath Token a
+getFileName :: P FilePath
+getFileName = get
+
parseDie :: forall a . --X (Show a) =>
- P a -> String -> String -> a
+ P a -> FilePath -> String -> a
parseDie p fn file =
let { ts = lexTop file } in-- trace (show ts) $
- case runPrsr () p ts of
+ case runPrsr fn p ts of
Left lf -> error $ formatFailed fn ts lf
Right [(a, _)] -> a
Right as -> error $ "Ambiguous:"
--X ++ unlines (map (show . fst) as)
+getLoc :: P Loc
+getLoc = P.do
+ t <- nextToken
+ P.pure (tokensLoc [t])
+
pTop :: P EModule
pTop = pModule <* eof
@@ -38,16 +46,20 @@
(pKeyword "where" *> pBlock pDef)
pQIdent :: P Ident
-pQIdent = satisfyM "QIdent" is
- where
- is (TIdent _ qs s) | isAlpha_ (head s) = Just (qualName qs s)
+pQIdent = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs s) | isAlpha_ (head s) = Just (qualName fn loc qs s)
is _ = Nothing
+ satisfyM "QIdent" is
pUIdentA :: P Ident
-pUIdentA = satisfyM "UIdent" is
- where
- is (TIdent _ [] s) | isUpper (head s) = Just (mkIdent s)
+pUIdentA = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc [] s) | isUpper (head s) = Just (mkIdentLoc fn loc s)
is _ = Nothing
+ satisfyM "UIdent" is
pUIdent :: P Ident
pUIdent =
@@ -58,16 +70,23 @@
pUIdentSym = pUIdent <|< pParens pUSymOper
pUIdentSpecial :: P Ident
-pUIdentSpecial =
- (mkIdent . map (const ',') <$> (pSpec '(' *> some (pSpec ',') <* pSpec ')'))- <|> (mkIdent "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name- <|> (mkIdent "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
+pUIdentSpecial = P.do
+ fn <- getFileName
+ loc <- getLoc
+ let
+ mk = mkIdentLoc fn loc
+
+ (mk . map (const ',') <$> (pSpec '(' *> some (pSpec ',') <* pSpec ')'))+ <|> (mk "()" <$ (pSpec '(' *> pSpec ')')) -- Allow () as a constructor name+ <|> (mk "[]" <$ (pSpec '[' *> pSpec ']')) -- Allow [] as a constructor name
pUQIdentA :: P Ident
-pUQIdentA = satisfyM "UQIdent" is
- where
- is (TIdent _ qs s) | isUpper (head s) = Just (qualName qs s)
+pUQIdentA = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs s) | isUpper (head s) = Just (qualName fn loc qs s)
is _ = Nothing
+ satisfyM "UQIdent" is
pUQIdent :: P Ident
pUQIdent =
@@ -75,16 +94,20 @@
<|> pUIdentSpecial
pLIdent :: P Ident
-pLIdent = satisfyM "LIdent" is
- where
- is (TIdent _ [] s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (mkIdent s)
+pLIdent = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc [] s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (mkIdentLoc fn loc s)
is _ = Nothing
+ satisfyM "LIdent" is
pLQIdent :: P Ident
-pLQIdent = satisfyM "LQIdent" is
- where
- is (TIdent _ qs s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (qualName qs s)
+pLQIdent = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs s) | isLower_ (head s) && not (elemBy eqString s keywords) = Just (qualName fn loc qs s)
is _ = Nothing
+ satisfyM "LQIdent" is
keywords :: [String]
keywords = ["case", "data", "do", "else", "forall", "if", "import",
@@ -106,16 +129,20 @@
pOper = pQSymOper <|< (pSpec '`' *> pQIdent <* pSpec '`')
pQSymOper :: P Ident
-pQSymOper = satisfyM "QSymOper" is
- where
- is (TIdent _ qs s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (qualName qs s)
+pQSymOper = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (qualName fn loc qs s)
is _ = Nothing
+ satisfyM "QSymOper" is
pSymOper :: P Ident
-pSymOper = satisfyM "SymOper" is
- where
- is (TIdent _ [] s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (mkIdent s)
+pSymOper = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc [] s) | not (isAlpha_ (head s)) && not (elemBy eqString s reservedOps) = Just (mkIdentLoc fn loc s)
is _ = Nothing
+ satisfyM "SymOper" is
pUQSymOper :: P Ident
pUQSymOper = P.do
@@ -396,10 +423,12 @@
pIf = EIf <$> (pKeyword "if" *> pExpr) <*> (pKeyword "then" *> pExpr) <*> (pKeyword "else" *> pExpr)
pQualDo :: P Ident
-pQualDo = satisfyM "QualDo" is
- where
- is (TIdent _ qs@(_:_) "do") = Just (mkIdent (intercalate "." qs))
+pQualDo = P.do
+ fn <- getFileName
+ let
+ is (TIdent loc qs@(_:_) "do") = Just (mkIdentLoc fn loc (intercalate "." qs))
is _ = Nothing
+ satisfyM "QualDo" is
pAExpr :: P Expr
pAExpr =
@@ -489,8 +518,8 @@
isAlpha_ :: Char -> Bool
isAlpha_ c = isLower_ c || isUpper c
-qualName :: [String] -> String -> Ident
-qualName qs s = mkIdent (intercalate "." (qs ++ [s]))
+qualName :: FilePath -> Loc -> [String] -> String -> Ident
+qualName fn loc qs s = mkIdentLoc fn loc (intercalate "." (qs ++ [s]))
-------------
--- a/src/Text/ParserComb.hs
+++ b/src/Text/ParserComb.hs
@@ -15,7 +15,7 @@
esepBy, sepBy1, esepBy1,
(<?>), (<|<),
notFollowedBy, lookAhead,
- inject,
+ inject, nextToken,
LastFail(..)
) where
--Ximport Prelude()
@@ -203,6 +203,12 @@
case runP p t of
Many [] (LastFail l ts xs) -> Many [] (LastFail l (take 1 ts) [("lookAhead-" ++ m, es) | (m, es) <- xs ])_ -> Many [((), t)] noFail
+
+nextToken :: forall s t . Prsr s t t
+nextToken = P $ \ t@(cs, _) ->
+ case cs of
+ [] -> Many [] (LastFail (length cs) [] [("nextToken", [])])+ c:_ -> Many [(c, t)] noFail
inject :: forall s t . [t] -> Prsr s t ()
inject s = P $ \ (cs, st) -> Many [((), (s ++ cs, st))] noFail
--
⑨