0N/A{- |

0N/AModule : $Header$

0N/ADescription : pretty printing ADL syntax

0N/ACopyright : (c) Stef Joosten, Christian Maeder DFKI GmbH 2010

0N/ALicense : GPLv2 or higher, see LICENSE.txt

0N/A

0N/AMaintainer : Christian.Maeder@dfki.de

0N/AStability : provisional

0N/APortability : portable

0N/A

0N/A-}

0N/A

0N/Amodule Adl.Print (adlGA) where

0N/A

0N/Aimport Adl.As

0N/Aimport Common.AS_Annotation

0N/Aimport Common.Doc

0N/Aimport Common.DocUtils

0N/Aimport Common.GlobalAnnotations

0N/Aimport Common.Id

0N/A

0N/Aimport Data.List

0N/Aimport qualified Data.Map as Map

0N/A

0N/Ainstance Pretty Concept where

0N/A pretty c = case c of

0N/A C s -> pretty s

0N/A _ -> text $ show c

0N/A

0N/Ainstance Pretty RelType where

0N/A pretty (RelType c1 c2) = case (c1, c2) of

0N/A (Anything, Anything) -> empty

0N/A _ | c1 == c2 -> brackets $ pretty c1

0N/A _ -> brackets $ hcat [pretty c1, cross, pretty c2]

0N/A

0N/Ainstance Pretty Relation where

0N/A pretty (Sgn n t) = let s = tokStr n in

0N/A (if isBRel s then keyword s else pretty n)

0N/A <> pretty t

0N/A

0N/ApOp :: UnOp -> Id

0N/ApOp o = case o of

0N/A Co -> converseId

0N/A Cp -> minusId

0N/A _ -> stringToId $ show o

0N/A

0N/Ainstance Pretty UnOp where

0N/A pretty = idDoc . stringToId . show

0N/A

0N/AinOp :: MulOp -> Id

0N/AinOp = stringToId . show

0N/A

0N/Ainstance Pretty MulOp where

0N/A pretty o = let i = idDoc (inOp o) in case o of

0N/A Fc -> i

0N/A Fd -> i

0N/A _ -> space <> i <> space

0N/A

0N/AprettyParen :: (Rule -> Bool) -> Rule -> Doc

0N/AprettyParen p e = (if p e then parens else id) $ pretty e

0N/A

0N/AminusId :: Id

minusId = mkId [mkSimpleId $ show Cp, placeTok]

converseId :: Id

converseId = mkId [placeTok, mkSimpleId $ show Co]

displayMap :: DisplayMap

displayMap = Map.fromList $ map ( \ (i, l) -> (i, Map.singleton DF_LATEX l))

[ (minusId, [mkSimpleId "\\overline{", placeTok, mkSimpleId "}"])

, (converseId, [mkSimpleId "\\widetilde{", placeTok, mkSimpleId "}"])

, (inOp Fi, [mkSimpleId "\\cap"])

, (inOp Fu, [mkSimpleId "\\cup"])

, (inOp Fd, [mkSimpleId "\\dag"])

, (inOp Ri, [mkSimpleId "\\vdash"])

, (inOp Rr, [mkSimpleId "\\dashv"])

, (inOp Re, [mkSimpleId "\\equiv"])

, (stringToId $ show Co, [mkSimpleId "\\breve{~}"])

, (pOp K0, [mkSimpleId "\\texttt{*}"])

, (pOp K1, [mkSimpleId "\\texttt{+}"])

]

adlGA :: GlobalAnnos

adlGA = emptyGlobalAnnos

{ display_annos = displayMap }

instance Pretty Rule where

pretty e = useGlobalAnnos adlGA $ case e of

Tm r -> pretty r

MulExp o es ->

fcat . punctuate (pretty o) $ map

(prettyParen (\ a -> case a of

MulExp p _ -> p >= o || o == Rr && p == Ri

_ -> False)) es

UnExp o r -> (if o == Cp

then idApplDoc (pOp o) . (: [])

else (<> pretty o))

$ prettyParen (\ a -> case a of

MulExp _ _ -> True

UnExp p _ -> o /= Cp && p == Cp

_ -> False) r

instance Pretty Prop where

pretty = text . showUp

instance Pretty RangedProp where

pretty = pretty . propProp

instance Pretty Object where

pretty (Object n e as os) = sep

[ fsep [commentText (tokStr n) <> colon, pretty e]

, if null as then empty else fsep $ keyword "ALWAYS" : map pretty as

, if null os then empty else equals <+> brackets (ppWithCommas os) ]

instance Pretty RuleKind where

pretty = keyword . showRuleKind

instance Pretty RuleHeader where

pretty h = case h of

Always -> empty

RuleHeader k t -> keyword

(if k == SignalOn then "SIGNAL" else "RULE")

<+> pretty t <+> pretty k

instance Pretty KeyAtt where

pretty (KeyAtt mt e) = sep [case mt of

Nothing -> empty

Just t -> pretty t <> colon

, pretty e]

instance Pretty KeyDef where

pretty (KeyDef l c atts) = fsep

[ keyword "KEY"

, pretty l <> colon

, pretty c

, parens $ ppWithCommas atts ]

instance Pretty Pair where

pretty (Pair x y) = parens $ ppWithCommas [x, y]

prettyContent :: [Pair] -> Doc

prettyContent = brackets . vcat . punctuate semi . map pretty

instance Pretty PatElem where

pretty e = case e of

Pr k r -> pretty k <+> pretty r

Pg c1 c2 -> fsep [keyword "GEN", pretty c1, keyword "ISA", pretty c2]

Pk k -> pretty k

Pm ps (Sgn n (RelType c1 c2)) b ->

let u = rProp Uni

t = rProp Tot

f = elem u ps && elem t ps

ns = if f then delete t $ delete u ps else ps

in fsep

[ pretty n, text "::", pretty c1

, if f then funArrow else cross, pretty c2

, if null ns then empty else brackets $ ppWithCommas ns]

<> if b then empty else dot

Plug p o -> sep [keyword $ showUp p, pretty o]

Population b r l -> let d = prettyContent l in

if b then equals <+> d <> dot else fsep

[ keyword "POPULATION"

, pretty r

, keyword "CONTAINS"

, d ]

instance Pretty Context where

pretty (Context m ps) = let l = vcat $ map pretty ps in case m of

Nothing -> l

Just t -> vcat

[keyword "CONTEXT" <+> structId (tokStr t), l, keyword "ENDCONTEXT"]