module UU_AG where import Trace import List import UU_Parsing -- http://www.cs.uu.nl/groups/ST/Software/Parse/ import UU_Scanner -- http://www.cs.uu.nl/groups/ST/Software/Parse/ import UU_Pretty -- http://www.cs.uu.nl/groups/ST/Software/PP/ import UU_Pretty_ext -- http://www.cs.uu.nl/groups/ST/Software/PP/ infix 8 `x` infix 8 ?? -- UU_Maps infixr 7 <++ infixr 7 <-- infixr 7 <+- type Map a b = [(a,b)] (<++) pos@(i, n) f (this@(key, val) : rest) | i == key = trace ("\n Error discoverd in <++ :: entry: " ++ show i ++ " already exists!\n") (this:rest) | otherwise = this : ((pos <++ f) rest) (<++) (i, n) f [] = [(i, f n)] (<--) i f (this@(key, val) : rest) | i == key = (i, (f val)): rest | otherwise = this : ((i <-- f) rest) (<--) i f [] = trace ("<-- :: entry: " ++ show i ++ " does not exist!\n") [] (<+-) pos@(i, n) f (this@(key, val) : rest) | i == key = (i, (f val)): rest | otherwise = this : ((pos <+- f) rest) (<+-) (i, n) f [] = [(i, f n)] -- ----------------------------------------------------------------------- -- AG Parser -- ----------------------------------------------------------------------- parser = parse pAG pAG = foldl sem_Elems_One_Elem sem_Elems_No_Elem <$> pList pElem pElem = sem_Elem_Data <$ pKey "DATA" <*> pConid <*> pAttrs <*> pAlts sem_Alt <|> sem_Elem_Data <$ pKey "EXT" <*> pConid <*> pAttrs <*> pAlts sem_Alt' <|> sem_Elem_AttrsDef <$ pKey "ATTR" <*> pList pConid <*> pAttrs <|> sem_Elem_Rules <$ pKey "SEM" <*> pConid <*> pAttrs <*> pAltRules <|> sem_Elem_Pre <$ pKey "PRE" <*> pVarid <|> sem_Elem_Txt <$> pTextnm <*> pList pTextln pAttrs = pBracks ((,,) <$> pAttrNames <* pSpec '|' <*> pAttrNames <* pSpec '|' <*> pAttrNames ) `opt` ([], [], []) pAttrNames = concat <$> pList ( sem_Attrs <$> pCommas pNameDef <*> (( (,) <$ pKey "USE" <*> pString <*> pString) `opt` ("","")) <*> ( pKey ":" *> (pConid <|> pString)) ) pAlts sem = applyall <$> pListPrefixed (pSpec '|') (sem <$> pConid <*> pFields) pFields = applyall <$> pList pField pField = sem_Field <$> pCommas pVarid <* pKey ":" <*> pConid <|> (\s -> sem_Field [(mklower s)] s) <$> pConid pAltRules = pFoldrPrefixed compose_alg (pSpec '|') pAltRule pAltRule = sem_AltRule <$> pConid <*> pFieldRules pFieldRules = pFoldr compose_alg ( sem_FieldRule <$> (pVarid <|> pKey "LHS") <*> pAttrRules (Ident <$> pVarid) <|> sem_FieldRule <$> pKey "LOC" <*> pAttrRules pNameDef ) pAttrRules pname = pFoldrPrefixed compose_alg (pSpec '.') (pAttrRule pname) pAttrRule pname = sem_AttrRule <$> pname <*> (pKey "=" <|> pKey ":=") <*> pAttrExpr pAttrExpr = pp_parens <$> pFoldr1 (>-<) (text <$> pString) <|> text <$> pVarid <|> text <$> pConid pNameDef = LocalDef <$> pVarid <*> ( pSpec '@' *> pPattern `opt` NoPat ) -- <*>?? <|> LocalDef <$> pSucceed "" <*> pPattern pPattern = Product <$> pParens (pListSep (pSpec ',') pSimplePattern) pSimplePattern = Var <$> pVarid <|> Constr <$> pConid <*> pList pSimplePattern <|> pPattern <|> Underscore <$ pSpec '_' ------------------------------------------------------------- mklower (a:aa) = toLower a : aa signOn :: String -- SEmantic Processing ------------------------------------- type Gram = Map Nonterminal Alts type Alts = Map Constructor Alt type Alt = Map El_name (Nonterminal, Sem_Funcs) type Sem_Funcs = Map Lhs PP_Doc type Attrtable = Map Nonterminal [(Attr_name, (Pattern, Type_name))] type Nonterminal = String type Constructor = String type El_name = String type Attr_name = String type Type_name = String data Lhs = LocalDef String Pattern | Ident String deriving (Eq, Show) data Pattern = NoPat | Constr String [Pattern] | Product [Pattern] | Var String | Underscore deriving (Eq, Show) lhs_names (Ident s) = [s] lhs_names (LocalDef s p ) = s:pat_names p pat_names (NoPat) = [] pat_names (Constr s l) = concat.map pat_names $ l pat_names (Product l) = concat.map pat_names $ l pat_names (Var s) = [s] pat_names (Underscore) = [] type Attr_table = Map Nonterminal [Attr_name] and_also (f1, f2, f3, f4, f5) (g1,g2,g3,g4,g5) = (f1.g1, f2.g2, f3.g3, f4.g4, f5.g5) sem_Elems_One_Elem (t1, t2, t3, t4, t5) (upd1, upd2, upd3, upd4, upd5) = (upd1 t1, upd2 t2, upd3 t3, upd4 t4, upd5 t5) sem_Elems_No_Elem = ([], [], [], [], "sem") sem_Elem_Data nt attrs alts = sem_Elem_AttrsDef [nt] attrs `and_also` ( (nt, []) <+- alts, id , id , id , id) sem_Elem_Rules ntname attrs altrules = sem_Elem_AttrsDef [ntname] attrs `and_also` (ntname <-- altrules, id, id , id, id) sem_Elem_AttrsDef ntlist (inattrs, inoutattr, outattrs) = ( id , addnames ntlist (inattrs ++ inoutattr) , addnames ntlist (outattrs ++ inoutattr) , id , id) sem_Alt constr_name aafields = (constr_name, [("LHS", ("lhs", [])),("LOC", ("loc", [])) ]) <++ aafields sem_Alt' constr_name aafields = constr_name <-- aafields sem_Field names nont = applyall [(name, (nont,[])) <++ id | name <- names] addnames ntlist attrs = applyall [(nt, []) <+- applyall (map (:) attrs) | nt <- ntlist] sem_Attrs attrs ops typ = [ (attr, (pattern,(ops,typ))) | LocalDef attr pattern <- attrs , if attr =="" then trace ("empty attrname") True else True ] -- ----------------------------------------------------------------- - -- Semantic Functions for processing Semantic Function Definitions -- ------------------------------------------------------------------ sem_Elem_Txt n t = (id, id, id, (n,[]) <+- (t ++), id ) sem_Elem_Pre pre = (id, id, id, id , const pre) sem_AltRule :: String -> (Alt -> Alt) -> Alts -> Alts sem_FieldRule :: String -> (Sem_Funcs -> Sem_Funcs) -> Alt -> Alt sem_AttrRule :: Lhs -> String -> PP_Doc -> Sem_Funcs -> Sem_Funcs sem_AltRule altname elrules = altname <-- elrules sem_FieldRule elname atrules = elname <-- \ (nt, funcs) -> (nt, atrules funcs) sem_AttrRule attr "=" exp = (attr, "") <++ const exp sem_AttrRule attr ":=" exp = attr <-- const exp compose_alg = ((.), id) applyall [] t = t applyall (f:fs) t = applyall fs (f t) signOn = "(MAGS) Micro Attribute Grammar System, SD Swierstra, Version 1.6.3, dd. 8-Jul-1999\n" tracelist [] = [] tracelist (a:as) = trace (show a) (a:tracelist as) ------------------------------------------------------------------------- -- Specialisation of Scanner ------------------------------------------------------------------------- keywordstxt = ["DATA", "ATTR", "LOC", "LHS", "SEM", "PRE", "EXT", "USE"] keywordsops = ["<-", "->", "=", ":=", ":"] specialchars = ".()[],|@_" opchars = "!#$%&*+/<=>?@\\^|-:" {- Available options for generating code: m : module header d : data type definition c : catas s : signatures for semantic functions -} allc = "mdcs" type Options = String compile :: Filename -> Options -> IO () compile fn options = do tokens <- scanner True keywordstxt keywordsops specialchars opchars (fn ++ ".ag") Nothing let (res, test, errors) = parser null tokens -- (tracelist tokens) putStr (show errors) printAll res fn options 200 putStr ("\n"++fn ++ ".hs generated") -- AG_Print adisp pw fn = mapM_ (\f -> appendFile fn (disp f pw "\n")) printAll (gram, inh, syn, copytext, pre) filename options pw = do writeFile fname (if 'm' `elem` options then ("module " ++ filename ++ " where\n") else "") appendFile fname (printText copytext pw "") printFunctions gram inh syn pre fname options pw where fname = filename ++ ".hs" printText [] pw = id printText cptext pw = vdisp pw . concat . map (map text . reverse) $ prtChunk "imports" cptext: prtChunk "" cptext: [ txt | (name,txt) <- cptext, name /= "" && name /= "imports"] where prtChunk n = maybe [] id . lookup n printFunctions gram inh syn pre fn options pw = adisp pw fn . map (printdatatype gram inh syn (map fst gram) pre options) $ gram printdatatype gram inh syn nonterms pre _ (nt, [] ) = empty printdatatype gram inh syn nonterms pre options (nt, alts@(_:_)) = comm ("---------------------- "++nt++" -------------------------") >-< datad ( if 'd' `elem` options then printdata else empty ) >-< if nt `elem` nonterms && (not.null) synnames then ( if fullytyped then comm "-- semantic domains" >-< typing ( text ("type T_" ++ nt ++ " = ") >#< hv [ pp_seq . map (text.(++" ->")) $ inhtypes , pp_list' . map text $ syntypes ] ) else empty ) >-< ( trace ( if synnames /= nub synnames then "\nduplicate synth attr: "++ show synnames ++ " for " ++ nt else "") (trace ( if inhnames /= nub inhnames then "\nduplicate inh attr: "++ show inhnames ++ " in " ++ nt else "") ( ( (if 'c' `elem` options then uncurry (>-<) else snd) . (catas . vlist . (comm "-- catas":) `x` sem . vlist . (comm "-- funcs":) ) . unzip . map prfunction $ alts ) ))) else empty where (synnames, _ , synops, syntypes) = let (ns,fsopsts) = unzip . ((syn, []) ??) $ nt (fs,opsts) = unzip fsopsts (ops, ts) = unzip opsts in (map Ident ns, fs, ops, ts) (inhnames, inhpatterns, _ , inhtypes) = let (ns,fsopsts) = unzip . ((inh, []) ??) $ nt (fs,opsts) = unzip fsopsts (ops, ts) = unzip opsts in (ns, fs, ops, ts) printdata = "data" >#< nt >#< ( pp_block "=" "" "| " [ pp_seq ( text (nt++"_"++constr) : [ text rhsnt | (name, (rhsnt,_)) <- rhs , not (rhsnt `elem` nonterms && (null ((gram, []) ?? rhsnt))) ] ) | (constr, (_:_:rhs)) <- alts ] >-< "deriving Show" ) fullytyped = all ((/="")) syntypes && all ((/="")) inhtypes cataname = "sem_" ++ nt prfunction (con, rhslong) = let funcname = "sem_"++nt++"_"++con ((_,(_,synt_funcs)):(_,(_,local_funcs)) :rhs ) = rhslong defsynnames = map fst synt_funcs localnames = filter (/="").filter (/="_").concat . map (lhs_names.fst) $ local_funcs rhsnames = map fst rhs children = [ name | (name,(rhsnt,_)) <- rhs , not (rhsnt `elem` nonterms && null ((gram, []) ?? rhsnt)) ] rhselems = [ (e, iscalled) | e@(_, (rhsnt,_)) <- rhs , let iscalled = rhsnt `elem` nonterms && (not.null) ((syn, []) ?? rhsnt) ] rhscalls = [ e | (e,True) <- rhselems ] initenv = map (\x -> (Ident x,text x)) (localnames `union` rhsnames) : [allfullnames] allfullnames'' = do (rhsname, (rhsnt,_)) <- rhscalls (s, (pat,_)) <- (syn, []) ?? rhsnt ident <- lhs_names (LocalDef s pat) let fullname = rhsname ++ "_" ++ ident [(Ident fullname, text fullname)] allfullnames' = do inhattr <- zipWith LocalDef inhnames inhpatterns ident <- lhs_names inhattr let fullname = "lhs_"++ident [(Ident fullname, text fullname), (Ident ident, text fullname) ] allfullnames = allfullnames' ++ allfullnames'' print_elem (others,envs) (elname, (rhsnt, inhfuncs)) = trace( if not.null $ falsedefs then "\ndefinition for nonexisting attributes: " ++ show falsedefs ++ " in " ++ nt ++ "'s alternative " ++ con ++ " for element " ++ elname else "") ( hv [ list [ lhs_pp (elname++"_") (LocalDef s pat) | (s, (pat,_)) <- (syn, []) ?? rhsnt ] , text (" = " ++ (if null((gram, []) ?? rhsnt) then pre++"_"++elname else elname)) >#< pp_seq [ (locateatdef (inhfuncs:envs) (report con elname) $ Ident atname) | atname <- inhnames ] ] : others , newenv ) where inhnames = [ atname | (atname, (_,_)) <- (inh, []) ?? rhsnt] inhdefs = [id | (Ident id, _) <- inhfuncs] falsedefs = filter (\v -> not (v `elem` inhnames)) inhdefs newenv = zip (map Ident leftnames) (map (text.((elname++"_")++)) leftnames):envs leftnames = concat [lhs_names (LocalDef name pat)| (name, (pat,typ)) <- (syn, []) ?? rhsnt] report con elname atname= trace( "\nno definition for attr: " ++ show atname ++ "at elem: " ++ elname ++ "of alt : " ++ con ++ "of nt : " ++ nt++"\n") (text "undefined") (elems_calls, finalenv) = foldl print_elem ([], initenv) rhscalls printsignature = funcname ++" ::" >|< hv ( [ (if iscalled then " T_" else "") ++ rhsnt ++ " ->" | ((_,(rhsnt,_)),iscalled) <- rhselems , not ( rhsnt`elem` nonterms && null((gram, []) ?? rhsnt)) ] ++ [" T_" ++ nt] ) in trace( if not.null $ (intersect localnames rhsnames) then "\nnondisjoint localnames and rhsnames: "++ show (intersect localnames rhsnames) else "") (trace( if localnames /= nub localnames then "\nduplicate local names: "++ show localnames ++ " in " ++ nt ++ "'s alternative " ++ con else "") (trace( if rhsnames /= nub rhsnames then "\nduplicate rhs names: "++ show rhsnames ++ " in " ++ nt ++ "'s alternative " ++ con else "") (trace( if ( synnames `union` defsynnames) /= synnames then "\ndefinitions for non-existing synthesised attrs: "++ shownames defsynnames ++ " in " ++ nt ++ "'s alternative " ++ con else "") ( ( -- the catamorphism for this alternative hv [ cataname >#< (pp_parens.pp_seq $ text (nt++"_"++con):map text children) >#< "=" , indent 2 ( funcname >#< pp_seq [ if iscalled then text (" (sem_"++ntname++" "++elemname++")") else text (' ':elemname) | ((elemname, (ntname, _)), iscalled) <- rhselems , not ( ntname`elem` nonterms && null((gram, []) ?? ntname)) ] ) ] , -- the type definition for the semantic function typing ( if ('s' `elem` options) && fullytyped then printsignature else empty ) >-< -- the definition of the semantic function hv [{-heading-} pp_seq (text funcname:map text children++map (lhs_pp "lhs_") (zipWith LocalDef inhnames inhpatterns)) ,{-body-} " = " >|< (if null elems_calls && null local_funcs then empty else pp_block "let{ " "}in " "; " ( reverse elems_calls ++ [lhs_pp "" lhs >|< text " = " >|< expr | (lhs,expr) <- local_funcs] ) ) >#< list [ let explicit = locateatdefs [synt_funcs] synname exprs = locateatdefs finalenv synname in if null explicit then case exprs of [] -> if unop /="" then text unop else trace ("\nno definition for attr:" ++ show synname ++ " of alt : " ++ con ++ " of nt : " ++ nt) (text "undefined") [r] -> r (r:_) -> if binop /="" then hv.intersperse (text binop) $ (reverse exprs) else r else (head explicit) | ((binop,unop),synname) <- zip synops synnames ] ] ))))) --building attribute definition environments locateatdef envs notfound name = foldr search notfound envs name search ((name,expr):rest) notfound n | n == name = expr | otherwise = search rest notfound n search [] notfound n = notfound n locateatdefs envs name = [ expr | env <- envs , (name',expr) <- env, name == name'] -- some utility functions cat (a, b) = a ++ b (f `x` g) (a, b) = (f a, g b) pp_list' l = if length l == 1 then head l else pp_list 40 "(" ")" "," l --pp_list 40 (text "(") (text ")") (text ",") l pp_seq :: [PP_Doc] -> PP_Doc pp_seq = hv_sp --if null l then empty else hlist_sp l >^< vlist l list l = if length l == 1 then head l else pp_block "(" ") " ", " l lhs_pp pref (Ident s) = text (pref++s) lhs_pp pref (LocalDef s NoPat) = text (pref++s) lhs_pp pref (LocalDef "" p ) = pat_pp pref p lhs_pp pref (LocalDef s p ) = text (pref++s) >|< text "@">|< pat_pp pref p pat_pp pref NoPat = empty pat_pp pref (Constr s l) = pp_parens.hlist_sp.(text s:).map (pat_pp pref)$ l pat_pp pref (Product l) = pp_list' (map (pat_pp pref) l) pat_pp pref (Var s) = text (pref++s) pat_pp pref (Underscore) = text "_" correct (gram, inh, syn, copytext, pre) = if not.null $ [ ops | (nt,attrs) <- inh, (attr, (pattern,(ops,typ))) <- attrs, ops/=("","")] then trace "\noperators declared for inherited attribute" True else True (table, errval) ?? key = case lookup key table of Nothing -> trace ("Could not locate:" ++ show key ++ " in " ++ show (map fst table)) errval Just v -> v shownames n = show [name | (Ident name) <- n] -- UU_No_HTML color :: (PP b) => a -> b -> PP_Doc color c t = pp t red = "#CC0000" dblue = "#660099" dgreen = "#009900" dpurple = "#990066" orange = "#FF6633" datad t = color dblue t -- the t's are necessary to prevent "unresolved top-level overloading" messages, SORRY comm t = color dgreen t typing t = color red t sem t = color dpurple t catas t = color orange t