-- ========================================================== --
-- === 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 = [
("-", (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))]
{- 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 = [
("-", (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))]
{- 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 = [
("-", (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))]
{- 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 = [
("-", (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))]
|
