-- ==========================================================-- -- === Raw lexical analysis (tokenisation) of source ===-- -- === Lexer.hs ===-- -- ==========================================================-- {-# OPTIONS_COMPILE +RTS -H48M -A8M -RTS #-} {-# OPTIONS_COMPILE -H8M #-} module Main where import Char -- 1.3 ---------------------------------------------------------- -- Lexemes -- ---------------------------------------------------------- type Token = (Int, Int, Lex, String) -- (line, column, lexeme type, value) data Lex = Lcon -- constructor used as prefix: -- normal prefix constructor, -- or bracketed infix constructor | Lconop -- constructor used as infix: -- normal prefix constructor in backquotes, -- or infix constructor (starting with ":") | Lvar -- variable used as prefix: -- normal prefix variable, -- or bracketed infix var (operator) | Lvarop -- variable used as infix: -- normal prefix variable in backquotes, -- or infix variable (operator) -- | Ltycon -- constructor starting with A-Z -- subcase of Lcon -- | Ltyvar -- variable starting with a-z -- subcase of Lvar | Lintlit -- integer literal | Lcharlit -- character literal | Lstringlit -- string literal | Llbrace -- { | Lrbrace -- } | Lsemi -- ; | Lequals -- = | Lbar -- | | Larrow -- -> | Llparen -- ( | Lrparen -- ) | Lcomma -- , | Llbrack -- [ | Lrbrack -- ] | Lunder -- _ | Lminus -- - | Lslash -- \ | Lmodule | Linfixl | Linfixr | Linfix | Lext | Ldata | Lif | Lthen | Lelse | Llet | Lin | Lcase | Lof | Lwhere | Leof deriving (Eq, Show{-was:Text-}) {- Lexing rules: case ( if next is \, -> Llparen if next is symbol, take symbols and expect closing ) -> Lvar if next is :, take tail-ident-chars, expect closing ) -> Lcon otherwise -> Llparen case ` if next A-Z, take tail-ident-chars, expect ` -> Lconop if next a-z, take tail-ident-chars, expect ` -> Lvarop otherwise -> error case A-Z take tail-ident-chars -> Lcon case a-z take tail-ident-chars -> Lvar case 0-9 take 0-9s -> Lintlit case ' expect a lit-char, then ' -> charlit case " expect lit-chars, then " -> stringlit case { case - -> run_comment otherwise -> Llbrace case } -> Lrbrace case ) -> Lrparen case [ -> Llbrack case ] -> Lrbrack case ; -> Lsemi case , -> Lcomma case _ -> Lunder case - case - -> line_comment case > -> Larrow otherwise -> Lminus case # in column 1: this is a preprocessor line case :!#$%&*+./<=>?@\^|~ take symbols, then case resulting "=" -> Lequals "|" -> Lbar "\" -> Lslash otherwise if starts with : -> Lconop else -> lvarop -} -- ==========================================================-- -- leLex :: Int -> Int -> String -> [Token] leLex l n [] = repeat (99997, 99997, Leof, "") leLex l n ('(':[]) = [(l, n, Llparen, ")")] leLex l n ('(':c:cs) | c == ':' = case leChunk (n+1) leIsTailChar cs of (restSym, nn, restInput) -> case restInput of [] -> leFail l nn " ) expected" (')':as) -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as (_:_) -> leFail l nn " ) expected" | c == '\\' = (l, n, Llparen, "(") : leLex l (n+1) (c:cs) | leIsSymbol c = case leChunk (n+1) leIsSymbol cs of (restSym, nn, restInput) -> case restInput of [] -> leFail l nn " ) expected" (')':as) -> (l, n, Lvar, c:restSym) : leLex l (nn+1) as (_:_) -> leFail l nn " ) expected" | otherwise = (l, n, Llparen, "(") : leLex l (n+1) (c:cs) leLex l n ('`':c:cs) | isAlpha c = case leChunk (n+1) isAlpha cs of (restSym, nn, restInput) -> case restInput of [] -> leFail l nn " ` expected" ('`':as) -> (l, n, if isUpper c then Lconop else Lvarop, c:restSym) : leLex l (nn+1) as (_:_) -> leFail l nn " ` expected" | otherwise = leFail l n "Bad infix operator" leLex l n ('"':cs) = case leTakeLitChars True l (n+1) cs of (restSym, nn, restInput) -> case restInput of [] -> leFail l nn " \" expected" ('"':as) -> (l, n, Lstringlit, restSym) : leLex l (nn+1) as (_:_) -> leFail l nn " \" expected" leLex l n ('\'':cs) = case leTakeLitChars False l (n+1) cs of (restSym, nn, restInput) -> case restInput of [] -> leFail l nn " ' expected" ('\'':as) -> case restSym of [_] -> (l, n, Lcharlit, restSym) : leLex l (nn+1) as _ -> leFail l (n+1) "Bad character literal" (_:_) -> leFail l nn " ' expected" leLex l n ('}':cs) = (l, n, Lrbrace, "}") : leLex l (n+1) cs leLex l n (')':cs) = (l, n, Lrparen, ")") : leLex l (n+1) cs leLex l n ('[':cs) = (l, n, Llbrack, "[") : leLex l (n+1) cs leLex l n (']':cs) = (l, n, Lrbrack, "]") : leLex l (n+1) cs leLex l n (';':cs) = (l, n, Lsemi, ";") : leLex l (n+1) cs leLex l n (',':cs) = (l, n, Lcomma, ",") : leLex l (n+1) cs leLex l n ('_':cs) = (l, n, Lunder, "_") : leLex l (n+1) cs leLex l n ('{':cs) = case cs of [] -> [(l, n, Llbrace, "}")] ('-':cs2) -> leLexRComment l (n+2) cs2 (_:_) -> (l, n, Llbrace, "}") : leLex l (n+1) cs leLex l n ('-':cs) = case cs of [] -> [(l, n, Lminus, "-")] ('-':cs2) -> leLexLComment l (n+2) cs2 ('>':cs3) -> (l, n, Larrow, "->") : leLex l (n+2) cs3 ('}':cs3) -> leFail l n "Misplaced -}" (_:_) -> (l, n, Lminus, "-") : leLex l (n+1) cs leLex l n (' ':cs) = leLex l (n+1) cs leLex l n ('\n':cs) = leLex (l+1) 1 cs leLex l n ('\t':cs) = leLex l (n - (n `mod` 8) + 9) cs leLex l n (c:cs) = if c == '#' then if n == 1 then {- This is a CPP line number thingy -} let lineNoText = takeWhile isDigit (tail cs) lineNo = leStringToInt lineNoText nextLine = drop 1 (dropWhile ((/=) '\n') cs) in leLex lineNo 1 nextLine else {- it's a symbol starting with # -} case leChunk (n+1) leIsSymbol cs of (restSym, nn, restText) -> (l, n, Lvarop, c:restSym) : leLex l nn restText else if isAlpha c then case leChunk (n+1) leIsTailChar cs of (restSym, nn, restText) -> (l, n, if isUpper c then Lcon else Lvar, c:restSym) : leLex l nn restText else if isDigit c then case leChunk (n+1) isDigit cs of (restSym, nn, restText) -> (l, n, Lintlit, c:restSym) : leLex l nn restText else if leIsSymbol c then case leChunk (n+1) leIsSymbol cs of (restSym, nn, restText) -> (l, n, if c == ':' then Lconop else Lvarop, c:restSym) : leLex l nn restText else leFail l n ("Illegal character " ++ [c]) -- ==========================================================-- -- leChunk :: Int -> (Char -> Bool) -> String -> (String, Int, String) leChunk n proper [] = ([], n, []) leChunk n proper (c:cs) | proper c = case leChunk (n+1) proper cs of (restId, col, restInput) -> (c:restId, col, restInput) | otherwise = ([], n, c:cs) -- ==========================================================-- -- leTakeLitChars :: Bool -> Int -> Int -> String -> (String, Int, String) leTakeLitChars d l n [] = leFail l n "End of file inside literal" leTakeLitChars d l n ('\\':'\\':cs) = case leTakeLitChars d l (n+2) cs of (rest, col, left) -> ('\\':rest, col, left) leTakeLitChars d l n ('\\':'n':cs) = case leTakeLitChars d l (n+2) cs of (rest, col, left) -> ('\n':rest, col, left) leTakeLitChars d l n ('\\':'t':cs) = case leTakeLitChars d l (n+2) cs of (rest, col, left) -> ('\t':rest, col, left) leTakeLitChars d l n ('\\':'"':cs) = case leTakeLitChars d l (n+2) cs of (rest, col, left) -> ('"':rest, col, left) leTakeLitChars d l n ('\\':'\'':cs) = case leTakeLitChars d l (n+2) cs of (rest, col, left) -> ('\'':rest, col, left) leTakeLitChars d l n ('"':cs) | d = ([], n, ('"':cs)) | not d = case leTakeLitChars d l (n+1) cs of (rest, col, left) -> ('"':rest, col, left) leTakeLitChars d l n ('\'':cs) | not d = ([], n, ('\'':cs)) | d = case leTakeLitChars d l (n+1) cs of (rest, col, left) -> ('\'':rest, col, left) leTakeLitChars d l n ('\n':cs) = leFail l n "Literal exceeds line" leTakeLitChars d l n ('\t':cs) = leFail l n "Literal contains tab" leTakeLitChars d l n (c:cs) = case leTakeLitChars d l (n+1) cs of (rest, col, left) -> (c:rest, col, left) -- ==========================================================-- -- leLexLComment :: Int -> Int -> String -> [Token] leLexLComment l n cs = leLex (l+1) 1 (drop 1 (dropWhile ((/=) '\n') cs)) -- ==========================================================-- -- leLexRComment :: Int -> Int -> String -> [Token] leLexRComment l n [] = leFail l n "End of file inside {- ... -} comment" leLexRComment l n ('-':'}':cs) = leLex l (n+2) cs leLexRComment l n ('\n':cs) = leLexRComment (l+1) 1 cs leLexRComment l n ('\t':cs) = leLexRComment l (n - (n `mod` 8) + 9) cs leLexRComment l n (c:cs) = leLexRComment l (n+1) cs -- ==========================================================-- -- leIsSymbol :: Char -> Bool leIsSymbol c = c `elem` leSymbols leSymbols = ":!#$%&*+./<=>?\\@^|~" -- ==========================================================-- -- leIsTailChar :: Char -> Bool leIsTailChar c = isLower c || isUpper c || isDigit c || c == '\'' || c == '_' || c == '\'' -- ==========================================================-- -- leIsLitChar :: Char -> Bool leIsLitChar c = c /= '\n' && c /= '\t' && c /= '\'' && c /= '"' -- ==========================================================-- -- leStringToInt :: String -> Int leStringToInt = let s2i [] = 0 s2i (d:ds) = (fromEnum d - fromEnum '0') + 10 *s2i ds in s2i . reverse -- ==========================================================-- -- leFail l n m = faiL ("Lexical error, line " ++ show l ++ ", col " ++ show n ++ ":\n " ++ m ) faiL m = error ( "\n\n" ++ m ++ "\n" ) -- ==========================================================-- -- === end Lexer.hs ===-- -- ==========================================================-- -- ==========================================================-- -- === Keyword spotting, and offside rule implementation ===-- -- === Layout.hs ===-- -- ==========================================================-- --module Layout -- ==========================================================-- -- laKeyword :: Token -> Token laKeyword (l, n, what, text) = let f Lvarop "=" = Lequals f Lvarop "|" = Lbar f Lvarop "\\" = Lslash f Lvar "module" = Lmodule f Lvar "infix" = Linfix f Lvar "infixl" = Linfixl f Lvar "infixr" = Linfixr f Lvar "ext" = Lext f Lvar "data" = Ldata f Lvar "if" = Lif f Lvar "then" = Lthen f Lvar "else" = Lelse f Lvar "let" = Llet f Lvar "in" = Lin f Lvar "case" = Lcase f Lvar "of" = Lof f Lvar "where" = Lwhere f item words = item in (l, n, f what text, text) -- ==========================================================-- -- laLayout :: Int -> [Int] -> [Token] -> [Token] laLayout l s [] = laRbrace (length s - 1) 99999 99999 laLayout l s (t1:[]) = t1 : laRbrace (length s - 1) 99998 99998 laLayout l (s:ss) (t1@(l1, n1, w1, c1) : t2@(l2, n2, w2, c2) : ts) | w1 `elem` [Lof, Llet, Lwhere] && w2 /= Llbrace = t1 : (l1, n1, Llbrace, "{") : t2 : laLayout l2 (n2:s:ss) ts | l1 == l = t1 : laLayout l (s:ss) (t2:ts) | n1 > s = t1 : laLayout l1 (s:ss) (t2:ts) | n1 == s = (l1, n1, Lsemi, ";") : t1 : laLayout l1 (s:ss) (t2:ts) | n1 < s = (l1, n1, Lrbrace, "}") : laLayout l ss (t1:t2:ts) -- ==========================================================-- -- laRbrace c l n = take c (repeat (l, n, Lrbrace, "}")) -- ==========================================================-- -- laMain :: String -> [Token] laMain = laLayout 1 [0] . map laKeyword . leLex 1 1 -- ==========================================================-- -- === end Layout.hs ===-- -- ==========================================================-- -- ==========================================================-- -- === Abstract syntax for modules ===-- -- === AbsSyntax.hs ===-- -- ==========================================================-- --module AbsSyntax where --1.3:data Maybe a = Nothing -- | Just a type AList a b = [(a, b)] type Id = String data Module = MkModule Id [TopDecl] deriving (Show{-was:Text-}) data FixityDecl = MkFixDecl Id (Fixity, Int) deriving (Show{-was:Text-}) data DataDecl = MkDataDecl Id ([Id], [ConstrAltDecl]) deriving (Show{-was:Text-}) data TopDecl = MkTopF FixityDecl | MkTopD DataDecl | MkTopV ValBind deriving (Show{-was:Text-}) data Fixity = InfixL | InfixR | InfixN deriving (Eq,Show{-was:Text-}) type ConstrAltDecl = (Id, [TypeExpr]) data TypeExpr = TypeVar Id | TypeArr TypeExpr TypeExpr | TypeCon Id [TypeExpr] | TypeList TypeExpr | TypeTuple [TypeExpr] deriving (Show{-was:Text-}) data ValBind = MkValBind Int Lhs Expr deriving (Show{-was:Text-}) data Lhs = LhsPat Pat | LhsVar Id [Pat] deriving (Show{-was:Text-}) data Pat = PatVar Id | PatCon Id [Pat] | PatWild | PatList [Pat] | PatTuple [Pat] deriving (Show{-was:Text-}) data Expr = ExprVar Id | ExprCon Id | ExprApp Expr Expr | ExprLam [Pat] Expr | ExprCase Expr [ExprCaseAlt] | ExprLetrec [ValBind] Expr | ExprWhere Expr [ValBind] | ExprGuards [(Expr, Expr)] | ExprLiteral Literal | ExprList [Expr] | ExprTuple [Expr] | ExprIf Expr Expr Expr | ExprBar | ExprFail deriving (Show{-was:Text-}) data ExprCaseAlt = MkExprCaseAlt Pat Expr deriving (Show{-was:Text-}) data Literal = LiteralInt Int | LiteralChar Char | LiteralString String deriving (Show{-was:Text-}) -- ==========================================================-- -- === end AbsSyntax.hs ===-- -- ==========================================================-- -- ==========================================================-- -- === Parser generics ===-- -- === ParserGeneric.hs ===-- -- ==========================================================-- --module ParserGeneric type PEnv = AList String (Fixity, Int) data PResult a = POk PEnv [Token] a | PFail Token type Parser a = PEnv -> [Token] -> PResult a type PEntry = (Bool, Expr, Id) -- ==========================================================-- -- pgItem :: Lex -> Parser String pgItem x env [] = PFail pgEOF pgItem x env ((l, n, w, t):toks) | x == w = POk env toks t | otherwise = PFail (l, n, w, t) -- ==========================================================-- -- pgAlts :: [Parser a] -> Parser a pgAlts ps env toks = let useAlts [] bestErrTok = PFail bestErrTok useAlts (p:ps) bestErrTok = case p env toks of PFail someErrTok -> useAlts ps (further someErrTok bestErrTok) successful_parse -> successful_parse further x1@(l1, n1, w1, t1) x2@(l2, n2, w2, t2) = if l2 > l1 then x2 else if l1 > l2 then x1 else if n1 > n2 then x1 else x2 in useAlts ps (head (toks ++ [pgEOF])) -- ==========================================================-- -- pgThen2 :: (a -> b -> c) -> Parser a -> Parser b -> Parser c pgThen2 combine p1 p2 env toks = case p1 env toks of { PFail tok1 -> PFail tok1 ; POk env1 toks1 item1 -> case p2 env1 toks1 of { PFail tok2 -> PFail tok2 ; POk env2 toks2 item2 -> POk env2 toks2 (combine item1 item2) } } -- ==========================================================-- -- pgThen3 :: (a -> b -> c -> d) -> Parser a -> Parser b -> Parser c -> Parser d pgThen3 combine p1 p2 p3 env toks = case p1 env toks of { PFail tok1 -> PFail tok1 ; POk env1 toks1 item1 -> case p2 env1 toks1 of { PFail tok2 -> PFail tok2 ; POk env2 toks2 item2 -> case p3 env2 toks2 of { PFail tok3 -> PFail tok3 ; POk env3 toks3 item3 -> POk env3 toks3 (combine item1 item2 item3) } } } -- ==========================================================-- -- pgThen4 :: (a -> b -> c -> d -> e) -> Parser a -> Parser b -> Parser c -> Parser d -> Parser e pgThen4 combine p1 p2 p3 p4 env toks = case p1 env toks of { PFail tok1 -> PFail tok1 ; POk env1 toks1 item1 -> case p2 env1 toks1 of { PFail tok2 -> PFail tok2 ; POk env2 toks2 item2 -> case p3 env2 toks2 of { PFail tok3 -> PFail tok3 ; POk env3 toks3 item3 -> case p4 env3 toks3 of { PFail tok4 -> PFail tok4 ; POk env4 toks4 item4 -> POk env4 toks4 (combine item1 item2 item3 item4) } } } } -- ==========================================================-- -- pgZeroOrMore :: Parser a -> Parser [a] pgZeroOrMore p env toks = case p env toks of { PFail tok1 -> POk env toks [] ; POk env1 toks1 item1 -> case pgZeroOrMore p env1 toks1 of { PFail tok2 -> POk env1 toks1 [item1] ; POk env2 toks2 item2_list -> POk env2 toks2 (item1 : item2_list) } } -- ==========================================================-- -- pgOneOrMore :: Parser a -> Parser [a] pgOneOrMore p = pgThen2 (:) p (pgZeroOrMore p) -- ==========================================================-- -- pgApply :: (a -> b) -> Parser a -> Parser b pgApply f p env toks = case p env toks of { PFail tok1 -> PFail tok1 ; POk env1 toks1 item1 -> POk env1 toks1 (f item1) } -- ==========================================================-- -- pgTwoOrMoreWithSep :: Parser a -> Parser b -> Parser [a] pgTwoOrMoreWithSep p psep = pgThen4 (\i1 s1 i2 rest -> i1:i2:rest) p psep p (pgZeroOrMore (pgThen2 (\sep x -> x) psep p)) -- ==========================================================-- -- pgOneOrMoreWithSep :: Parser a -> Parser b -> Parser [a] pgOneOrMoreWithSep p psep = pgThen2 (:) p (pgZeroOrMore (pgThen2 (\sep x -> x) psep p)) -- ==========================================================-- -- pgZeroOrMoreWithSep :: Parser a -> Parser b -> Parser [a] pgZeroOrMoreWithSep p psep = pgAlts [ pgOneOrMoreWithSep p psep, pgApply (\x -> x:[]) p, pgEmpty [] ] -- ==========================================================-- -- pgOptional :: Parser a -> Parser (Maybe a) pgOptional p env toks = case p env toks of { PFail tok1 -> POk env toks Nothing ; POk env2 toks2 item2 -> POk env2 toks2 (Just item2) } -- ==========================================================-- -- pgGetLineNumber :: Parser a -> Parser (Int, a) pgGetLineNumber p env toks = let lineNo = case (head (toks ++ [pgEOF])) of (l, n, w, t) -> l in case p env toks of { PFail tok1 -> PFail tok1 ; POk env2 toks2 item2 -> POk env2 toks2 (lineNo, item2) } -- ==========================================================-- -- pgEmpty :: a -> Parser a pgEmpty item env toks = POk env toks item -- ==========================================================-- -- pgEOF :: Token pgEOF = (88888, 88888, Lvar, "*** Unexpected end of source! ***") -- ============================================================-- -- === Some kludgey stuff for implementing the offside rule ===-- -- ============================================================-- -- ==========================================================-- -- pgEatEnd :: Parser () pgEatEnd env [] = POk env [] () pgEatEnd env (tok@(l, n, w, t):toks) | w == Lsemi || w == Lrbrace = POk env toks () | otherwise = POk env (tok:toks) () -- ==========================================================-- -- pgDeclList :: Parser a -> Parser [a] pgDeclList p = pgThen3 (\a b c -> b) (pgItem Llbrace) (pgOneOrMoreWithSep p (pgItem Lsemi)) pgEatEnd -- ==========================================================-- -- === end ParserGeneric.hs ===-- -- ==========================================================-- -- ==========================================================-- -- === The parser. ===-- -- === Parser.hs ===-- -- ==========================================================-- --module Parser where {- FIX THESE UP -} utLookupDef env k def = head ( [ vv | (kk,vv) <- env, kk == k] ++ [def] ) panic = error {- END FIXUPS -} paLiteral :: Parser Literal paLiteral = pgAlts [ pgApply (LiteralInt . leStringToInt) (pgItem Lintlit), pgApply (LiteralChar . head) (pgItem Lcharlit), pgApply LiteralString (pgItem Lstringlit) ] paExpr = pgAlts [ paCaseExpr, paLetExpr, paLamExpr, paIfExpr, paUnaryMinusExpr, hsDoExpr [] ] paUnaryMinusExpr = pgThen2 (\minus (_, aexpr, _) -> ExprApp (ExprApp (ExprVar "-") (ExprLiteral (LiteralInt 0))) aexpr) paMinus paAExpr paCaseExpr = pgThen4 (\casee expr off alts -> ExprCase expr alts) (pgItem Lcase) paExpr (pgItem Lof) (pgDeclList paAlt) paAlt = pgAlts [ pgThen4 (\pat arrow expr wheres -> MkExprCaseAlt pat (pa_MakeWhereExpr expr wheres)) paPat (pgItem Larrow) paExpr (pgOptional paWhereClause), pgThen3 (\pat agrdrhss wheres -> MkExprCaseAlt pat (pa_MakeWhereExpr (ExprGuards agrdrhss) wheres)) paPat (pgOneOrMore paGalt) (pgOptional paWhereClause) ] paGalt = pgThen4 (\bar guard arrow expr -> (guard, expr)) (pgItem Lbar) paExpr (pgItem Larrow) paExpr paLamExpr = pgThen4 (\lam patterns arrow rhs -> ExprLam patterns rhs) (pgItem Lslash) (pgZeroOrMore paAPat) (pgItem Larrow) paExpr paLetExpr = pgThen4 (\lett decls inn rhs -> ExprLetrec decls rhs) (pgItem Llet) paValdefs (pgItem Lin) paExpr paValdefs = pgApply pa_MergeValdefs (pgDeclList paValdef) pa_MergeValdefs = id paLhs = pgAlts [ pgThen2 (\v ps -> LhsVar v ps) paVar (pgOneOrMore paPat), pgApply LhsPat paPat ] paValdef = pgAlts [ pgThen4 (\(line, lhs) eq rhs wheres -> MkValBind line lhs (pa_MakeWhereExpr rhs wheres)) (pgGetLineNumber paLhs) (pgItem Lequals) paExpr (pgOptional paWhereClause), pgThen3 (\(line, lhs) grdrhss wheres -> MkValBind line lhs (pa_MakeWhereExpr (ExprGuards grdrhss) wheres)) (pgGetLineNumber paLhs) (pgOneOrMore paGrhs) (pgOptional paWhereClause) ] pa_MakeWhereExpr expr Nothing = expr pa_MakeWhereExpr expr (Just whereClauses) = ExprWhere expr whereClauses paWhereClause = pgThen2 (\x y -> y) (pgItem Lwhere) paValdefs paGrhs = pgThen4 (\bar guard equals expr -> (guard, expr)) (pgItem Lbar) paExpr (pgItem Lequals) paExpr paAPat = pgAlts [ pgApply PatVar paVar, pgApply (\id -> PatCon id []) paCon, pgApply (const PatWild) (pgItem Lunder), pgApply PatTuple (pgThen3 (\l es r -> es) (pgItem Llparen) (pgTwoOrMoreWithSep paPat (pgItem Lcomma)) (pgItem Lrparen)), pgApply PatList (pgThen3 (\l es r -> es) (pgItem Llbrack) (pgZeroOrMoreWithSep paPat (pgItem Lcomma)) (pgItem Lrbrack)), pgThen3 (\l p r -> p) (pgItem Llparen) paPat (pgItem Lrparen) ] paPat = pgAlts [ pgThen2 (\c ps -> PatCon c ps) paCon (pgOneOrMore paAPat), pgThen3 (\ap c pa -> PatCon c [ap,pa]) paAPat paConop paPat, paAPat ] paIfExpr = pgThen4 (\iff c thenn (t,f) -> ExprIf c t f) (pgItem Lif) paExpr (pgItem Lthen) (pgThen3 (\t elsee f -> (t,f)) paExpr (pgItem Lelse) paExpr ) paAExpr = pgApply (\x -> (False, x, [])) (pgAlts [ pgApply ExprVar paVar, pgApply ExprCon paCon, pgApply ExprLiteral paLiteral, pgApply ExprList paListExpr, pgApply ExprTuple paTupleExpr, pgThen3 (\l e r -> e) (pgItem Llparen) paExpr (pgItem Lrparen) ] ) paListExpr = pgThen3 (\l es r -> es) (pgItem Llbrack) (pgZeroOrMoreWithSep paExpr (pgItem Lcomma)) (pgItem Lrbrack) paTupleExpr = pgThen3 (\l es r -> es) (pgItem Llparen) (pgTwoOrMoreWithSep paExpr (pgItem Lcomma)) (pgItem Lrparen) paVar = pgItem Lvar paCon = pgItem Lcon paVarop = pgItem Lvarop paConop = pgItem Lconop paMinus = pgItem Lminus paOp = pgAlts [ pgApply (\x -> (True, ExprVar x, x)) paVarop, pgApply (\x -> (True, ExprCon x, x)) paConop, pgApply (\x -> (True, ExprVar x, x)) paMinus ] paDataDecl = pgThen2 (\dataa useful -> useful) (pgItem Ldata) paDataDecl_main paDataDecl_main = pgThen4 (\name params eq drhs -> MkDataDecl name (params, drhs)) paCon (pgZeroOrMore paVar) (pgItem Lequals) (pgOneOrMoreWithSep paConstrs (pgItem Lbar)) paConstrs = pgThen2 (\con texprs -> (con, texprs)) paCon (pgZeroOrMore paAType) paType = pgAlts [ pgThen3 (\atype arrow typee -> TypeArr atype typee) paAType (pgItem Larrow) paType, pgThen2 TypeCon paCon (pgOneOrMore paAType), paAType ] paAType = pgAlts [ pgApply TypeVar paVar, pgApply (\tycon -> TypeCon tycon []) paCon, pgThen3 (\l t r -> t) (pgItem Llparen) paType (pgItem Lrparen), pgThen3 (\l t r -> TypeList t) (pgItem Llbrack) paType (pgItem Lrbrack), pgThen3 (\l t r -> TypeTuple t) (pgItem Llparen) (pgTwoOrMoreWithSep paType (pgItem Lcomma)) (pgItem Lrparen) ] paInfixDecl env toks = let dump (ExprVar v) = v dump (ExprCon c) = c in pa_UpdateFixityEnv (pgThen3 (\assoc prio name -> MkFixDecl name (assoc, prio)) paInfixWord (pgApply leStringToInt (pgItem Lintlit)) (pgApply (\(_, op, _) -> dump op) paOp) env toks ) paInfixWord = pgAlts [ pgApply (const InfixL) (pgItem Linfixl), pgApply (const InfixR) (pgItem Linfixr), pgApply (const InfixN) (pgItem Linfix) ] pa_UpdateFixityEnv (PFail tok) = PFail tok pa_UpdateFixityEnv (POk env toks (MkFixDecl name assoc_prio)) = let new_env = (name, assoc_prio) : env in POk new_env toks (MkFixDecl name assoc_prio) paTopDecl = pgAlts [ pgApply MkTopF paInfixDecl, pgApply MkTopD paDataDecl, pgApply MkTopV paValdef ] paModule = pgThen4 (\modyule name wheree topdecls -> MkModule name topdecls) (pgItem Lmodule) paCon (pgItem Lwhere) (pgDeclList paTopDecl) parser_test toks = let parser_to_test = --paPat --paExpr --paValdef --pgZeroOrMore paInfixDecl --paDataDecl --paType paModule --pgTwoOrMoreWithSep (pgItem Lsemi) (pgItem Lcomma) in parser_to_test hsPrecTable toks -- ==============================================-- -- === The Operator-Precedence parser (yuck!) ===-- -- ==============================================-- -- -- ==========================================================-- -- hsAExprOrOp = pgAlts [paAExpr, paOp] hsDoExpr :: [PEntry] -> Parser Expr -- [PaEntry] is a stack of operators and atomic expressions -- hsDoExpr uses a parser (hsAexpOrOp :: Parsr PaEntry) for atomic -- expressions or operators hsDoExpr stack env toks = let (validIn, restIn, parseIn, err) = case hsAExprOrOp env toks of POk env1 toks1 item1 -> (True, toks1, item1, panic "hsDoExpr(1)") PFail err -> (False, panic "hsDoExpr(2)", panic "hsDoExpr(3)", err) (opIn, valueIn, nameIn) = parseIn (assocIn, priorIn) = utLookupDef env nameIn (InfixL, 9) shift = hsDoExpr (parseIn:stack) env restIn in case stack of s1:s2:s3:ss | validIn && opS2 && opIn && priorS2 > priorIn -> reduce | validIn && opS2 && opIn && priorS2 == priorIn -> if assocS2 == InfixL && assocIn == InfixL then reduce else if assocS2 == InfixR && assocIn == InfixR then shift else PFail (head toks) -- Because of ambiguousness | not validIn && opS2 -> reduce where (opS1, valueS1, nameS1) = s1 (opS2, valueS2, nameS2) = s2 (opS3, valueS3, nameS3) = s3 (assocS2, priorS2) = utLookupDef env nameS2 (InfixL, 9) reduce = hsDoExpr ((False, ExprApp (ExprApp valueS2 valueS3) valueS1, []) : ss) env toks s1:s2:ss | validIn && (opS1 || opS2) -> shift | otherwise -> reduce where (opS1, valueS1, nameS1) = s1 (opS2, valueS2, nameS2) = s2 reduce = hsDoExpr ((False, ExprApp valueS2 valueS1, []) : ss) env toks (s1:[]) | validIn -> shift | otherwise -> POk env toks valueS1 where (opS1, valueS1, nameS1) = s1 [] | validIn -> shift | otherwise -> PFail err -- ==========================================================-- -- === end Parser.hs ===-- -- ==========================================================-- hsPrecTable :: PEnv hsPrecTable = [ ("-", (InfixL, 6)), ("+", (InfixL, 6)), ("*", (InfixL, 7)), ("div", (InfixN, 7)), ("mod", (InfixN, 7)), ("<", (InfixN, 4)), ("<=", (InfixN, 4)), ("==", (InfixN, 4)), ("/=", (InfixN, 4)), (">=", (InfixN, 4)), (">", (InfixN, 4)), ("C:", (InfixR, 5)), ("++", (InfixR, 5)), ("\\", (InfixN, 5)), ("!!", (InfixL, 9)), (".", (InfixR, 9)), ("^", (InfixR, 8)), ("elem", (InfixN, 4)), ("notElem", (InfixN, 4)), ("||", (InfixR, 2)), ("&&", (InfixR, 3))] main = do cs <- getContents let tokens = laMain cs let parser_res = parser_test tokens putStr (showx parser_res) showx (PFail t) = "\n\nFailed on token: " ++ show t ++ "\n\n" showx (POk env toks result) = "\n\nSucceeded, with:\n Size env = " ++ show (length env) ++ "\n Next token = " ++ show (head toks) ++ "\n\n Result = " ++ show result ++ "\n\n" -- ==========================================================-- -- layn :: [[Char]] -> [Char] layn x = f 1 x where f :: Int -> [[Char]] -> [Char] f n [] = [] f n (a:x) = rjustify 4 (show n) ++") "++a++"\n"++f (n+1) x -- ==========================================================-- -- rjustify :: Int -> [Char] -> [Char] rjustify n s = spaces (n - length s)++s where spaces :: Int -> [Char] spaces m = copy m ' ' copy :: Int -> a -> [a] copy n x = take (max 0 n) xs where xs = x:xs