content: {- |
  Module      :  ./Adl/Print.hs
  Description :  pretty printing ADL syntax
  Copyright   :  (c) Stef Joosten, Christian Maeder DFKI GmbH 2010
  License     :  GPLv2 or higher, see LICENSE.txt
  
  Maintainer  :  Christian.Maeder@dfki.de
  Stability   :  provisional
  Portability :  portable
  
  -}
  
  module Adl.Print (adlGA) where
  
  import Adl.As
  import Common.AS_Annotation
  import Common.Doc
  import Common.DocUtils
  import Common.GlobalAnnotations
  import Common.Id
  
  import Data.List
  import qualified Data.Map as Map
  
  instance Pretty Concept where
    pretty c = case c of
      C s -> pretty s
      _ -> text $ show c
  
  instance Pretty RelType where
    pretty (RelType c1 c2) = case (c1, c2) of
        (Anything, Anything) -> empty
        _ | c1 == c2 -> brackets $ pretty c1
        _ -> brackets $ hcat [pretty c1, cross, pretty c2]
  
  instance Pretty Relation where
    pretty (Sgn n t) = let s = tokStr n in
      (if isBRel s then keyword s else pretty n)
      <> pretty t
  
  pOp :: UnOp -> Id
  pOp o = case o of
    Co -> converseId
    Cp -> minusId
    _ -> stringToId $ show o
  
  instance Pretty UnOp where
    pretty = idDoc . stringToId . show
  
  inOp :: MulOp -> Id
  inOp = stringToId . show
  
  instance Pretty MulOp where
    pretty o = let i = idDoc (inOp o) in case o of
      Fc -> i
      Fd -> i
      _ -> space <> i <> space
  
  prettyParen :: (Rule -> Bool) -> Rule -> Doc
  prettyParen p e = (if p e then parens else id) $ pretty e
  
  minusId :: 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"]
  