-- UUAGC 0.9.5 (GenerateCode.ag) import CommonTypes import Patterns import ErrorMessages import AbstractSyntax import VisageSyntax import VisagePatterns import Code hiding (Type) import qualified Code import qualified UU.DData.Map as Map import qualified UU.DData.Seq as Seq import qualified UU.DData.Set as Set import UU.DData.Map(Map) import UU.DData.Set(Set) import UU.DData.Seq(Seq, (<>)) import Maybe import UU.Pretty import UU.Util.Utils import Expression import Options import CommonTypes import UU.Pretty import Patterns import Expression import UU.DData.Set(Set) import List (intersect, (\\)) import qualified UU.DData.Map as Map(toList) import UU.Scanner.Position(Pos) import CommonTypes import UU.Pretty.Basic(PP_Doc) import Expression import HsTokenScanner(lexTokens) import SemHsTokens(sem_HsTokensRoot,wrap_HsTokensRoot, Syn_HsTokensRoot(..),Inh_HsTokensRoot(..)) import ErrorMessages import UU.Scanner.Position import CommonTypes import HsToken import UU.DData.Seq(Seq) import UU.Scanner.Position(Pos) import Options import Streaming import qualified UU.DData.Map as Map import List(partition,transpose) import CommonTypes(_LHS) import DepTypes import List(nub) import Char import CommonTypes import UU.Pretty import AbstractSyntax import VisagePatterns import Expression import UU.Scanner.Position(Pos) import CommonTypes import VisagePatterns import VisageSyntax {- de definitieve versie -} getResult :: [[(Vertex,Result)]] -> Seq Error getResult (res:rest) = if and (map (\(v,(set,upd)) -> null upd) res) then checkCircular res else getResult rest getResult [] = Seq.empty -- volgorde van belang: eerst de inh aflopen, dat zijn er minder!! checkCircular :: [(Vertex,Result)] -> Seq Error checkCircular res = Seq.fromList $ concat [ [ CircGrammar nt1 attr1 (fromJust (lookup attr2 (map toPair set1))) attr2 (fromJust (lookup attr1 (map toPair set2))) | (NTSyn nt2 attr2,(set2,upd2))<-res , nt1==nt2 , attr1 `elem` (map getAttr set2) , attr2 `elem` (map getAttr set1)] | (NTInh nt1 attr1,(set1,upd1))<-res ] -- de vertex is die die aangemaakt wordt door de productie -- 1 allereerst worden de useStreams geselecteerd die met deze knoop verbonden dienen te worden -- 2 daarna worden hier alle resultaten gefilterd die met de lhs nonterminal verbonden zijn -- want we zijn alleen geïnteresseerd in hoe de inh (syn) attributen van de syn (inh) attributen van een nonterminal afhangen -- 3 de field informatie is nu niet meer nodig en wordt eruit gegooid door van een lokaal resultaat een globaal resultaat te maken prod2stream :: Vertex -> [UseStream] -> Stream prod2stream (NTSyn nt at) streams = foldr stUnion stEmpty (map (stLocal2global . stFilterInclSide) . filter p $ streams) where p ((LHSSyn nont con attr),_) = nont==nt && attr==at p _ = False prod2stream (NTInh nt at) streams = foldr stUnion stEmpty (map (stLocal2global . stFilterInclSide) . filter p $ streams) where p ((RHSInh rhs lhs con fld attr),_) = rhs==nt && attr==at p _ = False prod2stream _ _ = stEmpty ports2stream :: Vertex -> [Vertex] -> [UseStream] -> Stream ports2stream vport vertices useStreams = foldr stUnion stEmpty stPorts where stPorts = [ stPort (getAttr vertex) (getStream vport useStreams) (getStream vertex useStreams) | vertex<-vertices ] getNonterminalName (NT nt) = nt getNonterminalName _ = nullIdent child_syn2stream :: Vertex -> [Vertex] -> [UseStream] -> Stream child_syn2stream vport vins useStreams = foldr stUnion stEmpty stPorts where stPorts = [ stPort (getAttr vin) (getStream vport useStreams) (getStream vin useStreams) | vin<-vins ] smsdtype :: Nonterminal -> String -> String smsdtype tp post = "T_sm_" ++ getName tp ++ "_" ++ post smsdtype2 :: Nonterminal -> Constructor -> String -> String smsdtype2 tp con post = "T_sm_" ++ getName tp ++ getName con ++ "_" ++ post smcataname :: String -> Nonterminal -> String smcataname pre name = cataname ("sm" ++ pre) name smpcataname :: String -> Nonterminal -> Constructor -> String smpcataname pre nt con = smsemname ('p':pre) nt con smsemname :: String -> Nonterminal -> Constructor -> String smsemname pre nt con = semname ("sm"++pre) nt con smcompname :: String -> Nonterminal -> Constructor -> String smcompname pre nt con = pre ++ "_" ++ getName nt ++ "_" ++ getName con ++ "f" mktuppat :: [String] -> String mktuppat args = '(' : (foldl1 (\l r -> l ++ ", " ++ r) args) ++ ")" tupnest = foldr (\l r -> TupleExpr [l,r]) (SimpleExpr unit) tupnest' es = if null es then TupleExpr [SimpleExpr unit] else foldr1 (\l r -> TupleExpr [l,r]) es tupnestTp = foldr (\l r -> TupleType [l,r]) (SimpleType unit) tupnestTp' es = if null es then TupleType [SimpleType unit] else foldr1 (\l r -> TupleType [l,r]) es smattrcompnamein :: String -> Nonterminal -> Constructor -> Name -> Name ->String smattrcompnamein pre nt con attr name = (smcompname pre nt con) ++ "_" ++ getName attr ++ getName name ++ "in" smattrcompnameout :: String -> Nonterminal -> Constructor -> Name -> String smattrcompnameout pre nt con attr = (smcompname pre nt con) ++ "_" ++ getName attr ++ "out" smattrcompnameloc :: String -> Nonterminal -> Constructor -> Name ->String smattrcompnameloc pre nt con attr = (smcompname pre nt con) ++ "_" ++ getName attr ++ "loc" fknit :: String fknit = "knit" unit :: String unit = "()" unittp :: String unittp = "UnitSMTP" underscore :: String underscore = "_" tup :: String tup = "(,)" lazytilde :: String lazytilde = "~" mk_def_name n i = "def_" ++ (show n) ++ "_" ++ (show i) mk_def_nm_decls n = map (mk_def_nm_decl n) [1..n] mk_def_nm_decl n i = let lhs = Fun (mk_def_name n i) [f, inppat] f = SimpleExpr "f" l = SimpleExpr "l" p = SimpleExpr "p" chpatelems = (map ((++) "ch" . show) [1..n]) chpat = tupnest' (map SimpleExpr chpatelems) inppat = TupleExpr [ chpat , l , p ] rhs = TupleExpr [ tupnest' chpat' , l , p ] chpat' = map (\e -> if e == ("ch" ++ show i) then App "f" [SimpleExpr e] else SimpleExpr e) chpatelems in Decl lhs rhs syn_def :: String syn_def = "syndef" loc_def :: String loc_def = "locdef" extname :: String extname = "ext" selectnm :: Nonterminal -> Constructor -> Name -> String selectnm nt con s = "select_" ++ getName nt ++ "_" ++ getName con ++ "_" ++ getName s insertnm :: Nonterminal -> Constructor -> Name -> String insertnm nt con s = "insert_" ++ getName nt ++ "_" ++ getName con ++ "_" ++ getName s insertinhnm :: Nonterminal -> Constructor -> Name -> Name -> String insertinhnm nt con nm s = "insert_" ++ getName nt ++ "_" ++ getName con ++ "_" ++ getName nm ++ "_" ++ getName s mkExtendExpr fnnm defnm insertnm = let extend = "_extend_" origcomp = "_origcomp_" newcomp = "_newcomp_" compinp = "_compinput_" extendExpr = Lambda [compinp] (App defnm [insertExpr]) insertExpr = App insertnm [App newcomp [SimpleExpr compinp]] lhs = Fun fnnm [SimpleExpr newcomp, SimpleExpr origcomp] rhs = Lambda [unit] (App extname [extendExpr, App origcomp [SimpleExpr unit]]) in Decl lhs rhs makesemnm :: Nonterminal -> Constructor -> String makesemnm nt con = "make_sem_" ++ getName nt ++ "_" ++ getName con showAsList = printList "[]" "[" "]" ", " printList e o c s xs = case xs of [] -> [e] (x:xs) -> (o ++ x) : map (s ++) xs ++ [c] spindent n = map (sp++) where sp = replicate n ' ' mkDynValList nm vals = (nm ++ " =") : spindent 4 (showAsList (map datatype vals)) where datatype (fident,(fnm,args)) = let args' = map (\v -> "tp_" ++ v) args arr a b = a ++ " .->. " ++ b in "(" ++ show fident ++ ", Id " ++ fnm ++ " ::: " ++ foldr1 arr args' ++ ")" mkDynValList' nm vals = (nm ++ " =") : spindent 4 (showAsList (map datatype vals)) where datatype (fident,(fnm,tp)) = "(" ++ show fident ++ ", Id " ++ fnm ++ " ::: " ++ (tpToDyn tp) ++ ")" tpToDyn (SimpleType tp) = "tp_" ++ tp tpToDyn (Arr tp1 tp2) = "(" ++ (tpToDyn tp1) ++ " .->. " ++ (tpToDyn tp2) ++ ")" tpToDyn _ = error "There may only be simple and arr types when converting to dyn." mkDynValListExt nm vals = (nm ++ " =") : spindent 4 (showAsList (map datatype vals)) where datatype (fident,(ftp,fnm,args)) = let args' = map (\v -> "tp_" ++ v) args arr a b = a ++ " .->. " ++ b in "(" ++ show fident ++ ",( " ++ show ftp ++ ", Id " ++ fnm ++ " ::: " ++ foldr1 arr args' ++ "))" mkExistList nm vals = (nm ++ " =") : spindent 4 (showAsList (map datatype vals)) where datatype (fident,(fnm,ftp)) = "(" ++ show fident ++ ", (" ++ show fnm ++ ", E " ++ "tp_" ++ ftp ++ "))" locname' n = "_loc_" ++ getName n -- Maps a rule to a pair -- Later, I expect to map to a list of rules, because we might need to unfold. -- Checks that a certain alias is in fact a Var in the old representation of the AG system isVar (Alias _ _ (Underscore _)) = True isVar _ = False type VisageRuleMap = [(String, VisageRule)] splitVRules :: [VisageRule] -> VisageRuleMap splitVRules vrs = concat (map unfoldvrs vrs) unfoldvrs :: VisageRule -> VisageRuleMap unfoldvrs vr@(VRule attrfields _ _ _ _) = zip (map (getName . fst) attrfields) (map (copyRule vr) attrfields) copyRule :: VisageRule -> (Name,Name) -> VisageRule copyRule (VRule attrfields pat expr owrt rule) (field,attr) = VRule attrfields (VVar field attr) expr owrt rule getForField :: String -> VisageRuleMap -> [VisageRule] getForField field xs = map snd (filter ((field ==) . fst) xs) {- Delivers a map from fieldname to VisageRule with all references to others underscored. So, (lhs.x, rt.y, loc.z) = (0,1,2) becomes something like [("lhs", (lhs.x,_,_) = (0,1,2) allways :: VisageRule -> VisageRuleMap allways vr@(VRule vrfields _ _ _ _) = zip vrfields (map (underScoreRule vr) (nub vrfields)) splitVRules :: [VisageRule] -> VisageRuleMap splitVRules vrs = concat (map allways vrs) underScoreRule :: VisageRule -> String -> VisageRule underScoreRule (VRule fields pat expr owrt rule) s = VRule fields (underScore s pat) expr owrt rule underScore :: String -> VisagePattern -> VisagePattern underScore field (VConstr name pats) = VConstr name (map (underScore field) pats) underScore field (VProduct pos pats) = VProduct pos (map (underScore field) pats) underScore field vp@(VVar vfield attr) = if (field == getName vfield) then vp else (VUnderscore (getPos vfield)) -- Should I recurse into the pat of VAlias? underScore field vp@(VAlias afield attr pat) = if (field == getName afield) then vp else (VUnderscore (getPos afield)) underScore field vp@(VUnderscore pos) = vp -} -- Alternative ------------------------------------------------- -- Alternatives ------------------------------------------------ -- Child ------------------------------------------------------- -- Children ---------------------------------------------------- -- Expression -------------------------------------------------- -- Grammar ----------------------------------------------------- -- Pattern ----------------------------------------------------- -- Patterns ---------------------------------------------------- -- Production -------------------------------------------------- -- Productions ------------------------------------------------- -- Rule -------------------------------------------------------- -- Rules ------------------------------------------------------- -- VisageAlternative ------------------------------------------- -- VisageAlternatives ------------------------------------------ -- VisageChild ------------------------------------------------- -- VisageChildren ---------------------------------------------- -- VisageGrammar ----------------------------------------------- -- VisagePattern ----------------------------------------------- -- VisagePatterns ---------------------------------------------- -- VisageProduction -------------------------------------------- -- VisageProductions ------------------------------------------- -- VisageRule -------------------------------------------------- -- VisageRules -------------------------------------------------