ag-pictgen-1.0.0.0: src/PictGen.ag

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}