ag-pictgen (empty) → 1.0.0.0
raw patch · 5 files changed
+857/−0 lines, 5 filesdep +basedep +containersdep +uuagcbuild-type:Customsetup-changed
Dependencies added: base, containers, uuagc, uulib
Files
- LICENSE +27/−0
- Setup.hs +5/−0
- ag-pictgen.cabal +28/−0
- src/PictGen.ag +795/−0
- uuagc_options +2/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2016, UU CS Department+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++* Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++* Redistributions in binary form must reproduce the above copyright notice,+ this list of conditions and the following disclaimer in the documentation+ and/or other materials provided with the distribution.++* Neither the name of ag-pictgen nor the names of its+ contributors may be used to endorse or promote products derived from+ this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,5 @@+import Distribution.Simple (defaultMainWithHooks)+import Distribution.Simple.UUAGC (uuagcLibUserHook)+import UU.UUAGC (uuagc)++main = defaultMainWithHooks (uuagcLibUserHook uuagc)
+ ag-pictgen.cabal view
@@ -0,0 +1,28 @@+cabal-version: >=1.6 +build-type: Custom +name: ag-pictgen +version: 1.0.0.0 +license: BSD3 +license-file: LICENSE +author: Arie Middelkoop <amiddelk@gmail.com> +maintainer: Atze Dijkstra <atzedijkstra@gmail.com> +homepage: https://github.com/UU-ComputerScience/ag-pictgen +bug-reports: https://github.com/UU-ComputerScience/ag-pictgen/issues +synopsis: Attribute Grammar picture generation +description: Attribute Grammar picture generation +category: Development +stability: Experimental +copyright: Arie Middelkoop, Atze Dijkstra +extra-source-files: uuagc_options, src/PictGen.ag + +source-repository head + type: git + location: https://github.com/UU-ComputerScience/ag-pictgen.git + +executable ag-pictgen + build-depends: base >= 4 && < 5, + uulib, + uuagc >= 0.9.26, + containers >= 0.3 + main-is: PictGen.hs + hs-source-dirs: src
+ src/PictGen.ag view
@@ -0,0 +1,795 @@+MODULE {Main} {main} {}++--+-- Imports+--++imports+{+import Data.Foldable(toList)+import Data.Sequence(Seq)+import qualified Data.Sequence as Seq+import Data.Map(Map)+import qualified Data.Map as Map+import Data.Set(Set)+import qualified Data.Set as Set+import UU.Pretty+import UU.Scanner+import UU.Parsing+import UU.Scanner.GenTokenParser+import System.Environment+import Data.List+}+++--+-- Source language+--++DATA ViewedGrammar | Gram+ name : {String}+ hierarchies : {[[String]]}+ prods : ProdViews++DATA Grammar | Gram+ name : {String}+ view : {String}+ prods : Prods++TYPE ProdViews = [ProdView]+TYPE Prods = [Prod]++DATA ProdView | Prod+ view : {String}+ prod : Prod++DATA Prod | Prod+ name : {String}+ parent : Nonterm+ children : Syms+ locals : Attrs+ deps : Deps++TYPE Syms = [Sym]++DATA Sym+ | Term+ name : {String}+ tp : {String}+ tex : {[String]}+ | Nont+ name : {String}+ tp : Nonterm++DATA Nonterm | Nont+ tp : {String}+ inh : Attrs+ syn : Attrs+ tex : {[String]}++TYPE Attrs = [Attr]++DATA Attr | Attr+ name : {String}+ tp : {String}+ tex : {[String]}++TYPE Deps = [Dep]++DATA Dep | Dep+ source : {Ident}+ target : {Ident}+ hint : {Maybe DirHint}+ tex : {[String]}++DATA DirHint+ | ForceUp+ | ForceDown++DATA HorHint+ | LeftRight+ | RightLeft+ | Unknown++DATA Flow+ | Inh+ | Syn++DATA Ident+ | ChildAttr+ child : {String}+ flow : {Flow}+ attr : {String}+ | LocAttr+ attr : {String}+ | LhsAttr+ flow : {Flow}+ attr : {String}+ | ChildVal+ child : {String}++DERIVING Ident Flow : Eq, Ord+DERIVING * : Show+++SET AllAttr = Attrs Attr+SET AllNonterm = Nonterm AllAttr+SET AllSyms = Syms Sym AllNonterm+SET AllDeps = Deps Dep+SET AllProdViews = ProdViews ProdView AllProds+SET AllProds = Prods Prod AllSyms AllDeps+SET AllGram = Grammar AllProds+SET AllViewedGram = ViewedGrammar AllProdViews++{+type Dim = Double++data UID+ = UidName !String+ | UidNum !Int+ | UidIdent !Ident+ deriving (Eq,Ord,Show)++half :: Dim -> Dim+half = (/2)++isSmall :: Dim -> Bool+isSmall d = d < 0.0001+}+++--+-- Desugar+--++ATTR ViewedGrammar [ | | grammars : {Map String Grammar} ]+ATTR ProdViews ProdView [ | | prods USE {++} {[]} : {[(String, Prod)]} ]+ATTR AllProds [ | | copy : SELF ]++SEM ViewedGrammar+ | Gram+ loc.views = flattenViews @hierarchies+ lhs.grammars = Map.mapWithKey (mergeForView @name @prods.prods) @loc.views++SEM ProdView+ | Prod+ lhs.prods = [(@view, @prod.copy)]++{+flattenViews :: [[String]] -> Map String (Set String)+flattenViews hierarchies+ = let views = nub $ concat hierarchies+ parents v acc [] = []+ parents v acc (x:xs)+ | v == x = acc+ | otherwise = parents v (x:acc) xs+ in Map.fromList [ (v, Set.fromList (concatMap (parents v [v]) hierarchies)) | v <- views ]++mergeForView :: String -> [(String, Prod)] -> String -> Set String -> Grammar+mergeForView name prods view parents+ = Grammar_Gram name view prods'+ where+ prods' = [ p | (n,p) <- prods, n `Set.member` parents ]+}+++--+-- Distributing unique numbers+--++ATTR AllSyms [ | guid : Int | ]+SEM Prod | Prod+ loc.luid = 1+ parent.guid = @loc.luid + 1++SEM Attr | Attr+ loc.luid = @lhs.guid+ lhs.guid = @lhs.guid + 1++SEM Sym+ | Term+ loc.luid = @lhs.guid+ lhs.guid = @lhs.guid + 1+ | Nont+ loc.luid = @lhs.guid+ tp.guid = @lhs.guid + 1++--+-- Constructing unique identifiers+--++ATTR Nonterm Attrs Attr [ mkAttrIdent : {Flow -> String -> Ident} | | ]+ATTR Attrs Attr [ flow : Flow | | ]++SEM Sym | Term Nont+ loc.ident = Ident_ChildVal @name+ loc.uid = UidIdent @loc.ident++SEM Sym | Nont+ tp.mkAttrIdent = Ident_ChildAttr @name++SEM Prod | Prod+ loc.uid = UidName "lhs"+ parent.mkAttrIdent = Ident_LhsAttr+ locals.flow = Flow_Syn+ locals.mkAttrIdent = const Ident_LocAttr++SEM Nonterm | Nont+ inh.flow = Flow_Inh+ syn.flow = Flow_Syn++SEM Attr | Attr+ loc.ident = @lhs.mkAttrIdent @lhs.flow @name+ loc.uid = UidIdent @loc.ident+++--+-- Name of Nont+--++{+-- | Combine parent name and own name of Nont+cmbNontNm :: String -> String -> String+cmbNontNm ctxtNm tp = ctxtNm ++ ":" ++ tp+}++ATTR Nonterm [ ctxtNm: String | | ]+SEM Prod+ | Prod+ parent.ctxtNm = @name++SEM Sym+ | Nont+ tp.ctxtNm = ""++--+-- Width calculation+--++ATTR AllSyms [ | | width : Dim ]+SEM Prod | Prod+ loc.totalWidth = @parent.width `max` @children.width `max` @locals.width++SEM Syms+ | Cons+ loc.sepWidth = defaultSymSepWidth+ loc.totalWidth = consWidth @hd.width @tl.width @loc.sepWidth+ lhs.width = @loc.totalWidth+ | Nil+ lhs.width = 0++SEM Sym | Term+ loc.width = defaultSymWidth++SEM Nonterm | Nont+ loc.width = ((fromIntegral $ length (cmbNontNm @lhs.ctxtNm @tp)) * defaultSymWidth) / 3+ loc.sepWidth = defaultAttrSepWidth+ loc.innerWidth = @loc.width + 2 * @loc.sepWidth+ loc.totalWidth = @loc.innerWidth + @inh.width + @syn.width+ lhs.width = @loc.totalWidth++SEM Attrs+ | Cons+ loc.sepWidth = defaultAttrSepWidth+ loc.totalWidth = consWidth @hd.width @tl.width @loc.sepWidth+ lhs.width = @loc.totalWidth+ | Nil+ lhs.width = 0++SEM Attr | Attr+ loc.width = defaultAttrWidth++{+consWidth :: Dim -> Dim -> Dim -> Dim+consWidth hd tl defltSep = sepWidth + hd + tl where+ sepWidth | isSmall tl = 0+ | otherwise = defltSep++defaultSymSepWidth :: Dim+defaultSymSepWidth = 2++defaultSymWidth :: Dim+defaultSymWidth = 1++defaultAttrSepWidth :: Dim+defaultAttrSepWidth = 0.8++defaultAttrWidth :: Dim+defaultAttrWidth = 1+}+++--+-- Horizontal coordinate distribution+-- (center position)+--++ATTR AllSyms [ x : Dim | | ]++SEM Prod | Prod+ parent.x = left 0 @loc.totalWidth @parent.width+ locals.x = left 0 @loc.totalWidth @locals.width+ children.x = left 0 @loc.totalWidth @children.width++SEM Syms | Cons+ hd.x = @lhs.x+ tl.x = @lhs.x + @loc.totalWidth - @tl.width++SEM Nonterm | Nont+ inh.x = @lhs.x+ syn.x = @lhs.x + @loc.totalWidth - @syn.width+ loc.x = left (@lhs.x + @inh.width) @loc.innerWidth 0++SEM Attrs | Cons+ hd.x = @lhs.x+ tl.x = @lhs.x + @loc.totalWidth - @tl.width++SEM Attr | Attr+ loc.x = left @lhs.x @loc.width 0++{+left :: Dim -> Dim -> Dim -> Dim+left x total width+ = x + (half (total - width))+}+++--+-- Collect uids of attributes+--++ATTR Attrs Attr [ | | uids USE {Seq.><} {Seq.empty} : {Seq UID} ]+SEM Attr | Attr+ lhs.uids = Seq.singleton @loc.uid++ATTR Nonterm [ | | inhUids : {Seq UID} synUids : {Seq UID} ]+SEM Nonterm | Nont+ lhs.inhUids = @inh.uids+ lhs.synUids = @syn.uids++--+-- The nonterminal name+--++ATTR Nonterm [ | | nt : String ]+SEM Nonterm | Nont+ lhs.nt = @tp+++--+-- UID dictionary construction+--++{+type UIDDict = Map Ident UID+}++ATTR AllSyms [ | | dictCol USE {`Map.union`} {Map.empty} : UIDDict ]+ATTR AllDeps [ dict : UIDDict | | ]++SEM Sym | Term+ lhs.dictCol = Map.singleton @loc.ident @loc.uid++SEM Attr | Attr+ lhs.dictCol = Map.singleton @loc.ident @loc.uid++SEM Prod | Prod+ loc.dict = @parent.dictCol `Map.union` @children.dictCol `Map.union` @locals.dictCol++--+-- The order of children+--++ATTR Syms Sym [ | rank : Int | collRanks USE {`Map.union`} {Map.empty} : {Map String Int} ]+ATTR AllDeps [ childRanks : {Map String Int} | | ]++SEM Prod | Prod+ children.rank = 1+ loc.childRanks = @children.collRanks++SEM Sym+ | Term Nont+ loc.rank = @lhs.rank+ lhs.rank = 1 + @lhs.rank+ lhs.collRanks = Map.singleton @name @loc.rank+++--+-- Command synthesis+--++ATTR AllGram [ | | cmds USE {Seq.><} {Seq.empty} : Cmds ]+ATTR Nonterm [ build : PartCmd | | ]+ATTR AllNonterm [ buildAttr : AttrCmd | | ]++SEM Prod | Prod+ parent.build = \x tp -> Cmd_Parent "lhs" @loc.uid x (cmbNontNm @name tp)+ parent.buildAttr = Cmd_AttrParent+ locals.buildAttr = Cmd_AttrLocal+ loc.inhEdges = mkEdges (@parent.inhUids Seq.>< Seq.singleton @loc.uid)+ loc.synEdges = mkEdges (Seq.singleton @loc.uid Seq.>< @parent.synUids)+ loc.beginCmds = Seq.singleton $ Cmd_BeginProd @name @loc.uid @parent.nt @loc.totalWidth+ loc.endCmds = Seq.singleton $ Cmd_EndProd @name @loc.uid @parent.nt @loc.totalWidth+ lhs.cmds = @loc.beginCmds+ Seq.>< @parent.cmds+ Seq.>< @children.cmds+ Seq.>< @locals.cmds+ Seq.>< Seq.fromList @loc.inhEdges Seq.>< Seq.fromList @loc.synEdges+ Seq.>< @deps.cmds+ Seq.>< @loc.endCmds++SEM Sym | Nont+ tp.build = Cmd_ChildNonTerm @name @loc.uid+ tp.buildAttr = Cmd_AttrChild+ loc.inhEdges = mkEdges (@tp.inhUids Seq.>< Seq.singleton @loc.uid)+ loc.synEdges = mkEdges (Seq.singleton @loc.uid Seq.>< @tp.synUids)+ lhs.cmds = @tp.cmds Seq.>< Seq.fromList @loc.inhEdges Seq.>< Seq.fromList @loc.synEdges++SEM Sym | Term+ lhs.cmds = Seq.singleton $ Cmd_ChildTerm @name @loc.uid @lhs.x @tp @tex++SEM Nonterm | Nont+ lhs.cmds = (Seq.singleton $ @lhs.build @loc.x @tp @tex) Seq.>< @inh.cmds Seq.>< @syn.cmds++SEM Attr | Attr+ lhs.cmds = Seq.singleton $ @lhs.buildAttr @name @loc.uid @loc.x @tp @tex++SEM Dep | Dep+ loc.uidSource = Map.findWithDefault (error $ "not in map: " ++ show @source) @source @lhs.dict+ loc.uidTarget = Map.findWithDefault (error $ "not in map: " ++ show @target) @target @lhs.dict+ (loc.hintSource, loc.hintDest) = selectHints @source @target @hint+ loc.hintHor = selectHorHint @lhs.childRanks @source @target+ lhs.cmds = Seq.singleton $ Cmd_DepLine @loc.uidSource @loc.uidTarget @loc.hintSource @loc.hintDest @loc.hintHor @tex++{+mkEdges :: Seq UID -> [Cmd]+mkEdges us+ = zipWith Cmd_SibLine uids (tail uids)+ where uids = toList us++-- Gives an indication if the line will be from right to left or from left to right+selectHorHint :: Map String Int -> Ident -> Ident -> HorHint+selectHorHint order (Ident_ChildAttr a flowA _) (Ident_ChildAttr b flowB _) = case Map.lookup a order of+ Nothing -> HorHint_Unknown+ Just rankA -> case Map.lookup b order of+ Nothing -> HorHint_Unknown+ Just rankB | rankA == rankB -> case (flowA, flowB) of+ (Flow_Inh, Flow_Inh) -> HorHint_Unknown+ (Flow_Syn, Flow_Syn) -> HorHint_Unknown+ (Flow_Inh, Flow_Syn) -> HorHint_LeftRight+ (Flow_Syn, Flow_Inh) -> HorHint_RightLeft+ | rankA > rankB -> HorHint_RightLeft+ | otherwise -> HorHint_LeftRight+selectHorHint order _ _ = HorHint_Unknown++-- Gives an indication if the arrow will arrive upward or downward on an attribute box+selectHints :: Ident -> Ident -> Maybe DirHint -> (DirHint, DirHint)+selectHints _ _ (Just h) = (h, h)+selectHints (Ident_LocAttr _) (Ident_LocAttr _) _ = (DirHint_ForceUp, DirHint_ForceUp)+selectHints (Ident_LocAttr _) (Ident_LhsAttr _ _) _ = (DirHint_ForceUp, DirHint_ForceDown)+selectHints (Ident_LhsAttr _ _) (Ident_LocAttr _) _ = (DirHint_ForceDown, DirHint_ForceUp)+selectHints (Ident_LocAttr _) _ _ = (DirHint_ForceDown, DirHint_ForceUp)+selectHints _ (Ident_LocAttr _) _ = (DirHint_ForceUp, DirHint_ForceDown)+selectHints (Ident_ChildAttr _ _ _) (Ident_ChildAttr _ _ _) _ = error "Dep from child attr to child attr: a hint is required."+selectHints (Ident_ChildAttr _ _ _) (Ident_LhsAttr _ _) _ = (DirHint_ForceUp, DirHint_ForceDown)+selectHints (Ident_ChildAttr _ _ _) (Ident_ChildVal _) _ = error "Child-values cannot have a dependency on an attribute."+selectHints (Ident_LhsAttr _ _) (Ident_ChildAttr _ _ _) _ = (DirHint_ForceDown, DirHint_ForceUp)+selectHints (Ident_LhsAttr _ _) (Ident_LhsAttr _ _) _ = error "Dep from lhs attr to lhs attr: a hint is required."+selectHints (Ident_LhsAttr _ _) (Ident_ChildVal _) _ = error "Child-values cannot have a dependency on an attribute."+selectHints (Ident_ChildVal _) (Ident_ChildAttr _ _ _) _ = (DirHint_ForceDown, DirHint_ForceDown)+selectHints (Ident_ChildVal _) (Ident_LhsAttr _ _) _ = (DirHint_ForceUp, DirHint_ForceDown)+selectHints (Ident_ChildVal _) (Ident_ChildVal _) _ = error "Child-values cannot have a dependency on another child-value."+}+++++--+-- Target language+--++{+type Cmds = Seq.Seq Cmd+type PartCmd = Dim -> String -> [String] -> Cmd+type AttrCmd = String -> UID -> Dim -> String -> [String] -> Cmd+}++TYPE CmdList = [Cmd]++DATA Cmd+ | (BeginProd EndProd)+ nm : {String}+ uid : {UID}+ nt : {String}+ width : {Dim}+ | Parent+ nm : {String}+ uid : {UID}+ x : {Dim}+ tp : {String}+ tex : {[String]}+ | (AttrParent AttrChild AttrLocal)+ nm : {String}+ uid : {UID}+ x : {Dim}+ tp : {String}+ tex : {[String]}+ | (ChildNonTerm ChildTerm)+ nm : {String}+ uid : {UID}+ x : {Dim}+ tp : {String}+ tex : {[String]}+ | SibLine+ uidA : {UID}+ uidB : {UID}+ | DepLine+ uidA : {UID}+ uidB : {UID}+ hintA : {DirHint}+ hintB : {DirHint}+ hint : {HorHint}+ tex : {[String]}++SET AllCmds = CmdList Cmd+++--+-- Wrappers+--++WRAPPER ViewedGrammar Grammar CmdList+++--+-- PP+--++ATTR AllCmds [ | | pp USE {>-<} {empty} : {PP_Doc} ]++SEM Cmd+ | BeginProd+ lhs.pp = texcmd "agbeginprod" [@nm, mkId @uid, @nt, show @width] []+ | EndProd+ lhs.pp = texcmd "agendprod" [@nm, mkId @uid, @nt, show @width] []+ | Parent+ lhs.pp = texcmd "agparent" [@nm, mkId @uid, show @x, @tp] @tex+ | AttrParent+ lhs.pp = texcmd "agparattr" [@nm, mkId @uid, show @x, @tp] @tex+ | AttrChild+ lhs.pp = texcmd "agchldattr" [@nm, mkId @uid, show @x, @tp] @tex+ | AttrLocal+ lhs.pp = texcmd "aglocattr" [@nm, mkId @uid, show @x, @tp] @tex+ | ChildNonTerm+ lhs.pp = texcmd "agchldnonterm" [@nm, mkId @uid, show @x, @tp] @tex+ | ChildTerm+ lhs.pp = texcmd "agchldterm" [@nm, mkId @uid, show @x, @tp] @tex+ | SibLine+ lhs.pp = texcmd "agsibline" [mkId @uidA, mkId @uidB] []+ | DepLine+ loc.texname = case (@hintA, @hintB) of+ (DirHint_ForceUp, DirHint_ForceUp) -> "agdeplineupup"+ (DirHint_ForceUp, DirHint_ForceDown) -> "agdeplineupdown"+ (DirHint_ForceDown, DirHint_ForceUp) -> "agdeplinedownup"+ (DirHint_ForceDown, DirHint_ForceDown) -> "agdeplinedowndown"+ loc.hor = case @hint of+ HorHint_Unknown -> "horunknown"+ HorHint_LeftRight -> "horleftright"+ HorHint_RightLeft -> "horrightleft"+ lhs.pp = texcmd @loc.texname [mkId @uidA, mkId @uidB, @loc.hor] @tex++{+mkId :: UID -> String+mkId uid = case uid of+ UidName nm -> nm+ UidNum u -> "s" ++ show u+ UidIdent i -> ident2LaTeX i++ident2LaTeX :: Ident -> String+ident2LaTeX i = case i of+ Ident_ChildAttr child flow attr -> attr2LaTeX child flow attr+ Ident_LocAttr attr -> attr2LaTeX "loc" Flow_Syn attr+ Ident_LhsAttr flow attr -> attr2LaTeX "lhs" flow attr+ Ident_ChildVal child -> child++attr2LaTeX :: String -> Flow -> String -> String+attr2LaTeX child flow attr = child ++ flow2LaTeX flow ++ attr++flow2LaTeX :: Flow -> String+flow2LaTeX Flow_Inh = "I"+flow2LaTeX Flow_Syn = "S"++optStyle :: Maybe String -> [String]+optStyle (Just s) = [s]+optStyle Nothing = []++texcmd :: String -> [String] -> [String] -> PP_Doc+texcmd nm ps os+ = "\\" >|< nm >|< hlist (map (pp_brackets . pp) os) >|< pp_braces (pp $ length os) >|< hlist (map (pp_braces . pp) ps) >#< "%"+}+++--+-- Pipeline+--++{+transform :: ViewedGrammar -> String+transform+ = phasePPString+ . vlist+ . Map.elems+ . Map.mapWithKey (\v -> phaseCreateTexMacro v . phaseCmdListPP . phaseCmdSeqCmdList . phaseGrammarCmdSeq)+ . phaseDesugar+ where+ phaseDesugar :: ViewedGrammar -> Map String Grammar+ phaseDesugar grammar+ = let inh = Inh_ViewedGrammar {}+ sem = sem_ViewedGrammar grammar+ syn = wrap_ViewedGrammar sem inh+ in grammars_Syn_ViewedGrammar syn++ phaseGrammarCmdSeq :: Grammar -> Cmds+ phaseGrammarCmdSeq grammar+ = let inh = Inh_Grammar {}+ sem = sem_Grammar grammar+ syn = wrap_Grammar sem inh+ in cmds_Syn_Grammar syn++ phaseCmdSeqCmdList :: Cmds -> CmdList+ phaseCmdSeqCmdList = toList++ phaseCmdListPP :: CmdList -> PP_Doc+ phaseCmdListPP list+ = let inh = Inh_CmdList {}+ sem = sem_CmdList list+ syn = wrap_CmdList sem inh+ in pp_Syn_CmdList syn++ phaseCreateTexMacro :: String -> PP_Doc -> PP_Doc+ phaseCreateTexMacro v d+ = d+ -- disabled for now:+ {-+ "\\newcommand{\\tikz." >|< v >|< "}" >#< "{ %"+ >-< " " >#< d+ >-< "}"+ -}++ phasePPString :: PP_Doc -> String+ phasePPString doc+ = disp doc 10000 ""+++scanPPDFile :: FilePath -> IO [Token]+scanPPDFile+ = let keywords = ["grammar", "hierarchy", "view", "prod", "attrs", "inh", "syn", "children", "nonterm", "term", "locals", "flows", "lhs", "loc", "downwards", "upwards", "in", "out", "style"]+ keywordsops = ["->", ".", ":"]+ opchars = "->.:"+ in scanFile keywords keywordsops "" opchars+++pUpperId :: Parser Token String+pUpperId = pConid <|> pString++pLowerId :: Parser Token String+pLowerId = pVarid <|> pString++pGrammar :: Parser Token ViewedGrammar+pGrammar+ = opt (ViewedGrammar_Gram+ <$ pKey "grammar" <*> pUpperId+ <*> pList pHierarchy+ )+ (ViewedGrammar_Gram "Nont" [["View"]]) -- backwards compatibility+ <*> pList pProd++pHierarchy :: Parser Token [String]+pHierarchy+ = pKey "hierarchy" *> pList pUpperId++pProd :: Parser Token ProdView+pProd+ = (\n t c v (i,s) syms locs deps -> ProdView_Prod v (Prod_Prod n (Nonterm_Nont t i s c) syms locs deps))+ <$ pKey "prod" <*> pUpperId <* pKey ":" <*> pUpperId+ <*> pTex+ <*> opt (pKey "view" *> pUpperId) "View" -- backwards compatibility+ <*> pAttrs+ <*> pSyms+ <*> pLocals+ <*> pDeps++pTex :: Parser Token [String]+pTex = pList_gr pTexBlock <?> "tex blocks"++pTexBlock :: Parser Token String+pTexBlock = pString <?> "a tex block"++pAttrs :: Parser Token (Attrs, Attrs)+pAttrs+ = (,) <$ pKey "attrs" <*> pList (pAttr "inh") <*> pList (pAttr "syn") <?> "attribute decls"++pAttr :: String -> Parser Token Attr+pAttr key+ = Attr_Attr <$ pKey key <*> pLowerId <* pKey ":" <*> pUpperId <*> pTex <?> (key ++ " decl")++pSyms :: Parser Token Syms+pSyms+ = pKey "children" *> pList pRhsSym <?> "children decls"++pLocals :: Parser Token Attrs+pLocals+ = ((pKey "locals" *> pList ((\nm -> Attr_Attr nm "LOC") <$ pKey "loc" <*> pLowerId <*> pTex)) `opt` []) <?> "local decls"++pRhsSym :: Parser Token Sym+pRhsSym+ = Sym_Term <$ pKey "term" <*> pLowerId <* pKey ":" <*> pUpperId <*> pTex+ <|> (\n t c (i,s) -> Sym_Nont n (Nonterm_Nont t i s c)) <$ pKey "nonterm" <*> pLowerId <* pKey ":" <*> pUpperId <*> pTex <*> pAttrs+ <?> "(non)term decls"++pDeps :: Parser Token Deps+pDeps+ = pKey "flows" *> pList pDep <?> "dependencies"++pDep :: Parser Token Dep+pDep = Dep_Dep <$> pAttrOcc <* pKey "->" <*> pAttrOcc <*> opt (Just <$> pHint) Nothing <*> pTex <?> "dependency"++pAttrOcc :: Parser Token Ident+pAttrOcc = (\fl f a -> f fl a) <$> pFlow <* pKey "." <*> pChildOcc <* pKey "." <*> pLowerId+ <|> pChildOcc <* pKey "." <*> pFlowOld <* pKey "." <*> pLowerId+ <|> Ident_ChildVal <$> pLowerId+ <|> Ident_LocAttr <$ pKey "loc" <* pKey "." <*> pLowerId+ <?> "attribute occurrence"++pChildOcc :: Parser Token (Flow -> String -> Ident)+pChildOcc+ = Ident_LhsAttr <$ pKey "lhs"+ <|> Ident_ChildAttr <$> pLowerId+ <?> "child occurrence"++pHint :: Parser Token DirHint+pHint = DirHint_ForceUp <$ pKey "upwards"+ <|> DirHint_ForceDown <$ pKey "downwards"+ <?> "dir hints"++pFlow :: Parser Token Flow+pFlow = Flow_Inh <$ pKey "inh"+ <|> Flow_Syn <$ pKey "syn"+ <?> "inh/syn"++pFlowOld :: Parser Token Flow+pFlowOld+ = Flow_Inh <$ pKey "in"+ <|> Flow_Syn <$ pKey "out"+ <?> "in/out"+++compile :: FilePath -> FilePath -> IO ()+compile source dest+ = do tokens <- scanPPDFile source+ gram <- parseIOMessage show pGrammar tokens+ let pict = transform gram+ writeFile dest pict+++main :: IO ()+main+ = do args <- getArgs+ if (length args /= 2)+ then putStrLn "usage: ag-pictgen <source> <dest>"+ else let [source,dest] = args+ in compile source dest+}+++--+-- Additional type signatures+--++SEM *+ | *+ loc.innerWidth : {Dim}+ loc.width : {Dim}+ loc.totalWidth : {Dim}+ loc.uid : {UID}+
+ uuagc_options view
@@ -0,0 +1,2 @@+file: "src/PictGen.ag" +options: data, rename, catas, semfuns, signatures, optimize, strictdata, strictwrap, genlinepragmas