-- ==========================================================-- -- === 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) ===-- -- ==========================================================--