-- ==========================================================--
-- === Parser of Core programs File: parse.m (1) ===--
-- ==========================================================--
module Parser2 where
import BaseDefs
import Utils
import MyUtils
import MakeDomains
import List(nub) -- 1.3
import Char(isAlpha,isDigit) -- 1.3
-- ====================================--
-- === Lexical analyser ===--
-- ====================================--
-- ==========================================================--
--
paLex :: Int ->
[Char] ->
[Token]
paLex n (':':':':'=':cs)
= (n,"::="):paLex n cs
paLex n (c1:c2:cs)
| [c1,c2] `elem` ["==", ">=", "<=", "->", ";;"] = (n, [c1,c2]):paLex n cs
paLex n ('{':cs)
= lexcomment n cs
where
lexcomment n [] = paLex n []
lexcomment n ('}':ds) = paLex n ds
lexcomment n ('\n':ds) = lexcomment (n+1) ds
lexcomment n (e:es) = lexcomment n es
paLex n ('\n':cs)
= paLex (n+1) cs
paLex n (c:cs)
| c `elem` " \t" = paLex n cs
paLex n (c:cs)
| isDigit c = (n, num_token): paLex n rest_cs
where
num_token = c:takeWhile isDigit cs
rest_cs = dropWhile isDigit cs
paLex n (c:cs)
| isAlpha c = (n, var_tok):paLex n rest_cs
where
var_tok = c:takeWhile isIdChar cs
rest_cs = dropWhile isIdChar cs
isIdChar c = isAlpha c || isDigit c || (c == '_')
paLex n (c:cs)
= (n, [c]):paLex n cs
paLex n [] = [(999999, "$$$")]
-- ====================================--
-- === Generic parsing functions ===--
-- ====================================--
-- ==========================================================--
--
paFailed (PFail _) = True
paFailed (POk _ _) = False
paGetItem :: PResult a -> a
paGetItem (POk item _) = item
paGetRest :: PResult a -> [Token]
paGetRest (POk _ rest) = rest
paGetRest (PFail rest) = rest
-- ==========================================================--
--
paLit :: [Char] ->
Parser [Char]
paLit lit [] = PFail []
paLit lit ((n, t):ts) | lit == t = POk lit ts
| otherwise = PFail ((n, t):ts)
-- ==========================================================--
--
paAlts :: [([Char] -> Bool, Parser a)] -> Parser a
paAlts pps [] = PFail []
paAlts [] toks = PFail []
paAlts ((pred, par):pps) toks@((n,t):_)
| pred t = par toks
| otherwise = paAlts pps toks
-- ==========================================================--
--
paThen2 :: (a -> b -> c) ->
Parser a ->
Parser b ->
Parser c
paThen2 combine p1 p2 toks
= let p1parse = p1 toks
p2parse = p2 (paGetRest p1parse)
in
if paFailed p1parse then PFail (paGetRest p1parse)
else if paFailed p2parse then PFail (paGetRest p2parse)
else POk (combine (paGetItem p1parse) (paGetItem p2parse))
(paGetRest p2parse)
-- ==========================================================--
--
paThen3 :: (a -> b -> c -> d) ->
Parser a ->
Parser b ->
Parser c ->
Parser d
paThen3 combine p1 p2 p3 toks
= let p1parse = p1 toks
p2parse = p2 (paGetRest p1parse)
p3parse = p3 (paGetRest p2parse)
in
if paFailed p1parse then PFail (paGetRest p1parse)
else if paFailed p2parse then PFail (paGetRest p2parse)
else if paFailed p3parse then PFail (paGetRest p3parse)
else POk (combine (paGetItem p1parse) (paGetItem p2parse)
(paGetItem p3parse))
(paGetRest p3parse)
-- ==========================================================--
--
paThen4 :: (a -> b -> c -> d -> e) ->
Parser a ->
Parser b ->
Parser c ->
Parser d ->
Parser e
paThen4 combine p1 p2 p3 p4 toks
= let p1parse = p1 toks
p2parse = p2 (paGetRest p1parse)
p3parse = p3 (paGetRest p2parse)
p4parse = p4 (paGetRest p3parse)
in
if paFailed p1parse then PFail (paGetRest p1parse)
else if paFailed p2parse then PFail (paGetRest p2parse)
else if paFailed p3parse then PFail (paGetRest p3parse)
else if paFailed p4parse then PFail (paGetRest p4parse)
else POk (combine (paGetItem p1parse) (paGetItem p2parse)
(paGetItem p3parse) (paGetItem p4parse))
(paGetRest p4parse)
-- ==========================================================--
--
paZeroOrMore :: Parser a -> Parser [a]
paZeroOrMore p toks
= let pParse = p toks
pUnused = paGetRest pParse
zmParse = paZeroOrMore p pUnused
zmUnused = paGetRest zmParse
in
if paFailed pParse then POk [] toks
else if paFailed zmParse then POk [paGetItem pParse] pUnused
else POk ((paGetItem pParse):paGetItem zmParse) zmUnused
-- ==========================================================--
--
paOneOrMore :: Parser a -> Parser [a]
paOneOrMore p
= paThen2 (:) p (paZeroOrMore p)
-- ==========================================================--
--
paOneOrMoreWithSep :: Parser a ->
Parser b ->
Parser [a]
paOneOrMoreWithSep p psep toks
= let pParse = p toks
pRest = paGetRest pParse
sParse = psep pRest
sRest = paGetRest sParse
mParse = paOneOrMoreWithSep p psep sRest
mRest = paGetRest mParse
in
if paFailed pParse then PFail toks
else if paFailed sParse then POk [paGetItem pParse] pRest
else if paFailed mParse then POk [paGetItem pParse] pRest
else POk ((paGetItem pParse):paGetItem mParse) mRest
-- ==========================================================--
--
paApply :: Parser a ->
(a -> b) ->
Parser b
paApply p f toks
= let pParse = p toks
in
if paFailed pParse
then PFail (paGetRest pParse)
else POk (f (paGetItem pParse)) (paGetRest pParse)
-- ==========================================================--
--
paSat :: (String -> Bool) ->
Parser String
paSat pred [] = PFail []
paSat pred ((n,t):toks)
| pred t = POk t toks
| otherwise = PFail toks
-- ==========================================================--
--
paEmpty :: a -> Parser a
paEmpty v toks = POk v toks
-- ====================================--
-- === Specific parsing functions ===--
-- ====================================--
-- ================================================--
paSyntax
= get_parse . paProgram
where
get_parse (PFail [])
= myFail "Syntax error: Unexpected end of source text"
get_parse (PFail ((n,t):_))
= myFail ( "Syntax error: unexpected token \"" ++ t ++
"\" on line " ++ show ( n :: Int ))
get_parse (POk _ ((n,t):_:_))
= myFail ( "Syntax error: unexpected token \"" ++ t ++
"\" on line " ++ show ( n :: Int ))
get_parse (POk prog [(999999, "$$$")]) = prog
get_parse (POk _ []) = myFail "Parser2.paSyntax:261: empty []"
get_parse (POk _ x@(_:_)) = myFail ("Parser2.paSyntax:262: "++show x)
-- ================================================--
paProgram = paThen3 f paTypeDefList (paLit ";;") paScdefs
where f a b c = (a,c)
-- ================================================--
paName = paSat paIsName
-- ================================================--
paIsName s = isAlpha (head s) && not (s `elem` paKeywords)
-- ================================================--
paCname = paSat paIsCname
-- ================================================--
paIsCname s = ('A'<=(head s)) &&
((head s)<='Z') &&
not (s `elem` paKeywords)
-- ================================================--
paKeywords = ["let", "letrec", "case", "in", "of", "end"]
-- ================================================--
paRelops = ["<=", "<", ">=", ">", "==", "~="]
-- ================================================--
paIsRelop op = op `elem` paRelops
-- ================================================--
paRelop = paSat paIsRelop
-- ================================================--
paNum = paSat paIsNum `paApply` paNumval
-- ================================================--
paNumval :: [Char] -> Int
paNumval cs
= sum (powers 1 (map (\d -> fromEnum d - 48) (reverse cs)))
where
powers n [] = []
powers n (h:t) = n*h : powers ((10 :: Int) *n) t
-- ================================================--
paIsNum = isDigit.head
-- ================================================--
paWithTrailingSemi p = paThen2 const p (paLit ";")
-- ==================================--
-- === Parsing type definitions ===--
-- ==================================--
-- ================================================--
paTypeDefList = paZeroOrMore (paThen2 f paTypeDef (paLit ";"))
where f a b = a
-- ================================================--
paTypeDef
= paThen4 f paName (paZeroOrMore paName) (paLit "::=") paConstrAlts
where f a b c d = (a,b,d)
-- ================================================--
paConstrAlts = paOneOrMoreWithSep paConstrAlt (paLit "|")
-- ================================================--
paConstrAlt = paThen2 f paCname (paZeroOrMore paTDefExpr)
where f a b = (a,b)
-- ================================================--
paTDefExpr
= paAlts [ ( (== "("), paTDefExpr2 ),
( paIsName, paApply paName TDefVar) ]
where
paTDefExpr2 = paThen3 g (paLit "(") paTDefExpr3 (paLit ")")
g a b c = b
paTDefExpr3 = paThen2 h paName (paZeroOrMore paTDefExpr)
h a b = TDefCons a b
-- ===========================================--
-- === Parsing supercombinator definitions ===--
-- ===========================================--
-- ================================================--
paScdefs = paOneOrMore (paWithTrailingSemi paSc)
-- ================================================--
paSc = paThen4 mk_sc paName (paZeroOrMore paName) (paLit "=") paExpr
where
mk_sc sc args eq rhs = (sc, (args, rhs))
-- ================================================--
paExpr
= paAlts [ ( (== "let"), paLet ),
( (== "letrec"), paLetrec ),
( (== "case"), paCase ),
( (== "\\"), paLambda ),
( (const True), paExpr1 ) ]
-- ================================================--
paLet = paThen4 mk_let
(paLit "let")
paDefns
(paLit "in") paExpr
where
mk_let lett defns inn expr = ELet False defns expr
-- ================================================--
paLetrec = paThen4 mk_letrec
(paLit "letrec")
paDefns
(paLit "in") paExpr
where
mk_letrec letrecc defns inn expr = ELet True defns expr
-- ================================================--
paDefns = paOneOrMoreWithSep paDefn (paLit ";")
-- ================================================--
paDefn = paThen3 mk_defn paName (paLit "=") paExpr
where
mk_defn var equals rhs = (var,rhs)
-- ================================================--
paCase = paThen4 mk_case (paLit "case") paExpr (paLit "of") paAlters
where
mk_case kase e ov alts = ECase e alts
-- ================================================--
paAlters = paThen2 const (paOneOrMoreWithSep paAlter (paLit ";")) (paLit "end")
-- ================================================--
paAlter = paThen4 mk_alt paCname (paZeroOrMore paName) (paLit "->") paExpr
where
mk_alt tag args arrow rhs = (tag, (args, rhs))
-- ================================================--
paLambda = paThen4 mk_lam
(paLit "\\") (paOneOrMore paName) (paLit "->") paExpr
where
mk_lam lam vars dot expr = ELam vars expr
-- ================================================--
paExpr1 = paThen2 paAssembleOp paExpr2 paExpr1c
-- ================================================--
paExpr1c = paAlts [((== "|"), paThen2 FoundOp (paLit "|") paExpr1),
((== "#"), paThen2 FoundOp (paLit "#") paExpr1),
(const True, paEmpty NoOp)]
-- ================================================--
paExpr2 = paThen2 paAssembleOp paExpr3 paExpr2c
-- ================================================--
paExpr2c = paAlts [((== "&"), paThen2 FoundOp (paLit "&") paExpr2),
(const True, paEmpty NoOp)]
-- ================================================--
paExpr3 = paThen2 paAssembleOp paExpr4 paExpr3c
-- ================================================--
paExpr3c = paAlts [(paIsRelop, paThen2 FoundOp paRelop paExpr4),
(const True, paEmpty NoOp)]
-- ================================================--
paExpr4 = paThen2 paAssembleOp paExpr5 paExpr4c
-- ================================================--
paExpr4c = paAlts [((== "+"), paThen2 FoundOp (paLit "+") paExpr4),
((== "-"), paThen2 FoundOp (paLit "-") paExpr5),
(const True, paEmpty NoOp)]
-- ================================================--
paExpr5 = paThen2 paAssembleOp paExpr6 paExpr5c
-- ================================================--
paExpr5c = paAlts [((== "*"), paThen2 FoundOp (paLit "*") paExpr5),
((== "/"), paThen2 FoundOp (paLit "/") paExpr6),
(const True, paEmpty NoOp)]
-- ================================================--
paExpr6 = (paOneOrMore paAtomic) `paApply` mk_ap_chain
where
mk_ap_chain (fn:args) = foldl EAp fn args
-- ================================================--
paAtomic = paAlts [(paIsCname, paConstr),
((== "("), paBracExpr),
(paIsName, paName `paApply` EVar),
(paIsNum, paNum `paApply` ENum)]
-- ================================================--
paBracExpr = paThen3 mk_brack (paLit "(") paExpr (paLit ")")
where
mk_brack open expr close = expr
-- ================================================--
paConstr = paApply paCname EConstr
-- ================================================--
paAssembleOp e1 NoOp = e1
paAssembleOp e1 (FoundOp op e2) = EAp (EAp (EVar op) e1) e2
-- ===================================================--
-- === Validation & transformation of parsed trees ===--
-- ===================================================--
-- ==========================================================--
--
paProgramToAtomic :: CoreProgram ->
AtomicProgram
paProgramToAtomic (tds, scdefs)
= (tds, ce)
where
ce = ELet True
[(name, ELam ns b) | (name, (ns, b)) <- scdefs]
(ENum 42)
-- ==========================================================--
--
paValidTypeDefs :: [TypeDef] -> -- all type definitions
TypeDependancy -> -- type dependancy info
[Char] -- wordy description of any problems
paValidTypeDefs tds rda
= if not uniqueTNames then "Non-unique type names" else
if not uniqueParNames then "Non-unique parameter names" else
if not uniqueCNames then "Non-unique constructor names" else
if not balanced then "Declared parameters do not match used parameters" else
if not allDefined then "Undefined types are present" else
if not rightArity then "Types are used at wrong arities" else
if not allSimple then "Perverse type definitions are present"
else ""
where
arityMap = map f tds
where
f (tname, tvs, cal) = (tname, length tvs)
allTNames = map f tds
where
f (tname, tvs, cal) = tname
allCNames = concat (map f tds)
where
f (tname, tvs, cal) = map first cal
uniqueTNames = length allTNames == ((length.nub) allTNames)
uniqueParNames = and (map f tds)
where
f (tname, tvs, cal) = length tvs == ((length.nub) tvs)
uniqueCNames = length allCNames == ((length.nub) allCNames)
balanced = and (map isBalanced tds)
where
tvsIn (TDefVar n) = [n]
tvsIn (TDefCons n tel) = concat (map tvsIn tel)
g tDefExprList = concat (map tvsIn tDefExprList)
isBalanced (tname, tvs, cal)
= (utSetFromList tvs) ==
(utSetFromList (concat (map (g.second) cal)))
allDefined = utSetSubsetOf
(utSetFromList (concat (map mdFreeTVarsIn tds)))
(utSetFromList allTNames)
rightArity = and (map f tds)
where
f (tname, tvs, cal) = and (map (g.second) cal)
g tDefExprList = and (map rArity tDefExprList)
rArity (TDefVar v) = True
rArity (TDefCons n tel)
= (length tel == utSureLookup arityMap "paVTD`rA`rA" n) &&
(and (map rArity tel))
allSimple = and (map f tds)
where
f (tname, tvs, cal) =
utSetSubsetOf (utSetFromList (allVars cal))
(utSetFromList (tvs++(groupOf tname rda)))
allVars cal = concat (map g cal)
g (n, tel) = concat (map allTVs tel)
allTVs (TDefVar n) = [n]
allTVs (TDefCons n tel) = n:concat (map allTVs tel)
groupOf tname ((rf, group):rest)
| tname `elem` group && rf = group
| tname `elem` group && not rf = []
| otherwise = groupOf tname rest
-- ==========================================================--
--
paParse :: [Char] -> (TypeDependancy, AtomicProgram)
paParse fileContents
= if typeDefErrors == ""
then (dependResult, (typeDefs, mainExpr))
else myFail typeDefErrors
where
(typeDefs, mainExpr) = paProgramToAtomic parsedProgram
dependResult = mdTypeDependancy typeDefs
typeDefErrors = paValidTypeDefs typeDefs dependResult
tokens = paLex 1 fileContents
parsedProgram = paSyntax tokens
-- ==========================================================--
-- === End parse.m (1) ===--
-- ==========================================================--
|
