{- |
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 :: Concept -> Doc
pretty c :: Concept
c = case Concept
c of
    C s :: Token
s -> Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
s
    _ -> String -> Doc
text (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Concept -> String
forall a. Show a => a -> String
show Concept
c

instance Pretty RelType where
  pretty :: RelType -> Doc
pretty (RelType c1 :: Concept
c1 c2 :: Concept
c2) = case (Concept
c1, Concept
c2) of
      (Anything, Anything) -> Doc
empty
      _ | Concept
c1 Concept -> Concept -> Bool
forall a. Eq a => a -> a -> Bool
== Concept
c2 -> Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c1
      _ -> Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Doc] -> Doc
hcat [Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c1, Doc
cross, Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c2]

instance Pretty Relation where
  pretty :: Relation -> Doc
pretty (Sgn n :: Token
n t :: RelType
t) = let s :: String
s = Token -> String
tokStr Token
n in
    (if String -> Bool
isBRel String
s then String -> Doc
keyword String
s else Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
n)
    Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> RelType -> Doc
forall a. Pretty a => a -> Doc
pretty RelType
t

pOp :: UnOp -> Id
pOp :: UnOp -> Id
pOp o :: UnOp
o = case UnOp
o of
  Co -> Id
converseId
  Cp -> Id
minusId
  _ -> String -> Id
stringToId (String -> Id) -> String -> Id
forall a b. (a -> b) -> a -> b
$ UnOp -> String
forall a. Show a => a -> String
show UnOp
o

instance Pretty UnOp where
  pretty :: UnOp -> Doc
pretty = Id -> Doc
idDoc (Id -> Doc) -> (UnOp -> Id) -> UnOp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Id
stringToId (String -> Id) -> (UnOp -> String) -> UnOp -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnOp -> String
forall a. Show a => a -> String
show

inOp :: MulOp -> Id
inOp :: MulOp -> Id
inOp = String -> Id
stringToId (String -> Id) -> (MulOp -> String) -> MulOp -> Id
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MulOp -> String
forall a. Show a => a -> String
show

instance Pretty MulOp where
  pretty :: MulOp -> Doc
pretty o :: MulOp
o = let i :: Doc
i = Id -> Doc
idDoc (MulOp -> Id
inOp MulOp
o) in case MulOp
o of
    Fc -> Doc
i
    Fd -> Doc
i
    _ -> Doc
space Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
i Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
space

prettyParen :: (Rule -> Bool) -> Rule -> Doc
prettyParen :: (Rule -> Bool) -> Rule -> Doc
prettyParen p :: Rule -> Bool
p e :: Rule
e = (if Rule -> Bool
p Rule
e then Doc -> Doc
parens else Doc -> Doc
forall a. a -> a
id) (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ Rule -> Doc
forall a. Pretty a => a -> Doc
pretty Rule
e

minusId :: Id
minusId :: Id
minusId = [Token] -> Id
mkId [String -> Token
mkSimpleId (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ UnOp -> String
forall a. Show a => a -> String
show UnOp
Cp, Token
placeTok]

converseId :: Id
converseId :: Id
converseId = [Token] -> Id
mkId [Token
placeTok, String -> Token
mkSimpleId (String -> Token) -> String -> Token
forall a b. (a -> b) -> a -> b
$ UnOp -> String
forall a. Show a => a -> String
show UnOp
Co]

displayMap :: DisplayMap
displayMap :: DisplayMap
displayMap = [(Id, Map Display_format [Token])] -> DisplayMap
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Id, Map Display_format [Token])] -> DisplayMap)
-> [(Id, Map Display_format [Token])] -> DisplayMap
forall a b. (a -> b) -> a -> b
$ ((Id, [Token]) -> (Id, Map Display_format [Token]))
-> [(Id, [Token])] -> [(Id, Map Display_format [Token])]
forall a b. (a -> b) -> [a] -> [b]
map ( \ (i :: Id
i, l :: [Token]
l) -> (Id
i, Display_format -> [Token] -> Map Display_format [Token]
forall k a. k -> a -> Map k a
Map.singleton Display_format
DF_LATEX [Token]
l))
  [ (Id
minusId, [String -> Token
mkSimpleId "\\overline{", Token
placeTok, String -> Token
mkSimpleId "}"])
  , (Id
converseId, [String -> Token
mkSimpleId "\\widetilde{", Token
placeTok, String -> Token
mkSimpleId "}"])
  , (MulOp -> Id
inOp MulOp
Fi, [String -> Token
mkSimpleId "\\cap"])
  , (MulOp -> Id
inOp MulOp
Fu, [String -> Token
mkSimpleId "\\cup"])
  , (MulOp -> Id
inOp MulOp
Fd, [String -> Token
mkSimpleId "\\dag"])
  , (MulOp -> Id
inOp MulOp
Ri, [String -> Token
mkSimpleId "\\vdash"])
  , (MulOp -> Id
inOp MulOp
Rr, [String -> Token
mkSimpleId "\\dashv"])
  , (MulOp -> Id
inOp MulOp
Re, [String -> Token
mkSimpleId "\\equiv"])
  , (String -> Id
stringToId (String -> Id) -> String -> Id
forall a b. (a -> b) -> a -> b
$ UnOp -> String
forall a. Show a => a -> String
show UnOp
Co, [String -> Token
mkSimpleId "\\breve{~}"])
  , (UnOp -> Id
pOp UnOp
K0, [String -> Token
mkSimpleId "\\texttt{*}"])
  , (UnOp -> Id
pOp UnOp
K1, [String -> Token
mkSimpleId "\\texttt{+}"])
  ]

adlGA :: GlobalAnnos
adlGA :: GlobalAnnos
adlGA = GlobalAnnos
emptyGlobalAnnos
  { display_annos :: DisplayMap
display_annos = DisplayMap
displayMap }

instance Pretty Rule where
  pretty :: Rule -> Doc
pretty e :: Rule
e = GlobalAnnos -> Doc -> Doc
useGlobalAnnos GlobalAnnos
adlGA (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ case Rule
e of
    Tm r :: Relation
r -> Relation -> Doc
forall a. Pretty a => a -> Doc
pretty Relation
r
    MulExp o :: MulOp
o es :: [Rule]
es ->
      [Doc] -> Doc
fcat ([Doc] -> Doc) -> ([Doc] -> [Doc]) -> [Doc] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate (MulOp -> Doc
forall a. Pretty a => a -> Doc
pretty MulOp
o) ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (Rule -> Doc) -> [Rule] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map
        ((Rule -> Bool) -> Rule -> Doc
prettyParen (\ a :: Rule
a -> case Rule
a of
           MulExp p :: MulOp
p _ -> MulOp
p MulOp -> MulOp -> Bool
forall a. Ord a => a -> a -> Bool
>= MulOp
o Bool -> Bool -> Bool
|| MulOp
o MulOp -> MulOp -> Bool
forall a. Eq a => a -> a -> Bool
== MulOp
Rr Bool -> Bool -> Bool
&& MulOp
p MulOp -> MulOp -> Bool
forall a. Eq a => a -> a -> Bool
== MulOp
Ri
           _ -> Bool
False)) [Rule]
es
    UnExp o :: UnOp
o r :: Rule
r -> (if UnOp
o UnOp -> UnOp -> Bool
forall a. Eq a => a -> a -> Bool
== UnOp
Cp
                  then Id -> [Doc] -> Doc
idApplDoc (UnOp -> Id
pOp UnOp
o) ([Doc] -> Doc) -> (Doc -> [Doc]) -> Doc -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: [])
                  else (Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> UnOp -> Doc
forall a. Pretty a => a -> Doc
pretty UnOp
o))
      (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ (Rule -> Bool) -> Rule -> Doc
prettyParen (\ a :: Rule
a -> case Rule
a of
        MulExp _ _ -> Bool
True
        UnExp p :: UnOp
p _ -> UnOp
o UnOp -> UnOp -> Bool
forall a. Eq a => a -> a -> Bool
/= UnOp
Cp Bool -> Bool -> Bool
&& UnOp
p UnOp -> UnOp -> Bool
forall a. Eq a => a -> a -> Bool
== UnOp
Cp
        _ -> Bool
False) Rule
r

instance Pretty Prop where
  pretty :: Prop -> Doc
pretty = String -> Doc
text (String -> Doc) -> (Prop -> String) -> Prop -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Prop -> String
forall a. Show a => a -> String
showUp

instance Pretty RangedProp where
  pretty :: RangedProp -> Doc
pretty = Prop -> Doc
forall a. Pretty a => a -> Doc
pretty (Prop -> Doc) -> (RangedProp -> Prop) -> RangedProp -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RangedProp -> Prop
propProp

instance Pretty Object where
  pretty :: Object -> Doc
pretty (Object n :: Token
n e :: Rule
e as :: [RangedProp]
as os :: [Object]
os) = [Doc] -> Doc
sep
    [ [Doc] -> Doc
fsep [String -> Doc
commentText (Token -> String
tokStr Token
n) Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon, Rule -> Doc
forall a. Pretty a => a -> Doc
pretty Rule
e]
    , if [RangedProp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RangedProp]
as then Doc
empty else [Doc] -> Doc
fsep ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ String -> Doc
keyword "ALWAYS" Doc -> [Doc] -> [Doc]
forall a. a -> [a] -> [a]
: (RangedProp -> Doc) -> [RangedProp] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map RangedProp -> Doc
forall a. Pretty a => a -> Doc
pretty [RangedProp]
as
    , if [Object] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Object]
os then Doc
empty else Doc
equals Doc -> Doc -> Doc
<+> Doc -> Doc
brackets ([Object] -> Doc
forall a. Pretty a => [a] -> Doc
ppWithCommas [Object]
os) ]

instance Pretty RuleKind where
  pretty :: RuleKind -> Doc
pretty = String -> Doc
keyword (String -> Doc) -> (RuleKind -> String) -> RuleKind -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. RuleKind -> String
showRuleKind

instance Pretty RuleHeader where
  pretty :: RuleHeader -> Doc
pretty h :: RuleHeader
h = case RuleHeader
h of
    Always -> Doc
empty
    RuleHeader k :: RuleKind
k t :: Token
t -> String -> Doc
keyword
      (if RuleKind
k RuleKind -> RuleKind -> Bool
forall a. Eq a => a -> a -> Bool
== RuleKind
SignalOn then "SIGNAL" else "RULE")
      Doc -> Doc -> Doc
<+> Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
t Doc -> Doc -> Doc
<+> RuleKind -> Doc
forall a. Pretty a => a -> Doc
pretty RuleKind
k

instance Pretty KeyAtt where
  pretty :: KeyAtt -> Doc
pretty (KeyAtt mt :: Maybe Token
mt e :: Rule
e) = [Doc] -> Doc
sep [case Maybe Token
mt of
      Nothing -> Doc
empty
      Just t :: Token
t -> Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
t Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon
      , Rule -> Doc
forall a. Pretty a => a -> Doc
pretty Rule
e]

instance Pretty KeyDef where
  pretty :: KeyDef -> Doc
pretty (KeyDef l :: Token
l c :: Concept
c atts :: [KeyAtt]
atts) = [Doc] -> Doc
fsep
    [ String -> Doc
keyword "KEY"
    , Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
l Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
colon
    , Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c
    , Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [KeyAtt] -> Doc
forall a. Pretty a => [a] -> Doc
ppWithCommas [KeyAtt]
atts ]

instance Pretty Pair where
   pretty :: Pair -> Doc
pretty (Pair x :: Token
x y :: Token
y) = Doc -> Doc
parens (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [Token] -> Doc
forall a. Pretty a => [a] -> Doc
ppWithCommas [Token
x, Token
y]

prettyContent :: [Pair] -> Doc
prettyContent :: [Pair] -> Doc
prettyContent = Doc -> Doc
brackets (Doc -> Doc) -> ([Pair] -> Doc) -> [Pair] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Doc] -> Doc
vcat ([Doc] -> Doc) -> ([Pair] -> [Doc]) -> [Pair] -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> [Doc] -> [Doc]
punctuate Doc
semi ([Doc] -> [Doc]) -> ([Pair] -> [Doc]) -> [Pair] -> [Doc]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Pair -> Doc) -> [Pair] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map Pair -> Doc
forall a. Pretty a => a -> Doc
pretty

instance Pretty PatElem where
  pretty :: PatElem -> Doc
pretty e :: PatElem
e = case PatElem
e of
    Pr k :: RuleHeader
k r :: Rule
r -> RuleHeader -> Doc
forall a. Pretty a => a -> Doc
pretty RuleHeader
k Doc -> Doc -> Doc
<+> Rule -> Doc
forall a. Pretty a => a -> Doc
pretty Rule
r
    Pg c1 :: Concept
c1 c2 :: Concept
c2 -> [Doc] -> Doc
fsep [String -> Doc
keyword "GEN", Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c1, String -> Doc
keyword "ISA", Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c2]
    Pk k :: KeyDef
k -> KeyDef -> Doc
forall a. Pretty a => a -> Doc
pretty KeyDef
k
    Pm ps :: [RangedProp]
ps (Sgn n :: Token
n (RelType c1 :: Concept
c1 c2 :: Concept
c2)) b :: Bool
b ->
      let u :: RangedProp
u = Prop -> RangedProp
rProp Prop
Uni
          t :: RangedProp
t = Prop -> RangedProp
rProp Prop
Tot
          f :: Bool
f = RangedProp -> [RangedProp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem RangedProp
u [RangedProp]
ps Bool -> Bool -> Bool
&& RangedProp -> [RangedProp] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem RangedProp
t [RangedProp]
ps
          ns :: [RangedProp]
ns = if Bool
f then RangedProp -> [RangedProp] -> [RangedProp]
forall a. Eq a => a -> [a] -> [a]
delete RangedProp
t ([RangedProp] -> [RangedProp]) -> [RangedProp] -> [RangedProp]
forall a b. (a -> b) -> a -> b
$ RangedProp -> [RangedProp] -> [RangedProp]
forall a. Eq a => a -> [a] -> [a]
delete RangedProp
u [RangedProp]
ps else [RangedProp]
ps
      in [Doc] -> Doc
fsep
      [ Token -> Doc
forall a. Pretty a => a -> Doc
pretty Token
n, String -> Doc
text "::", Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c1
      , if Bool
f then Doc
funArrow else Doc
cross, Concept -> Doc
forall a. Pretty a => a -> Doc
pretty Concept
c2
      , if [RangedProp] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [RangedProp]
ns then Doc
empty else Doc -> Doc
brackets (Doc -> Doc) -> Doc -> Doc
forall a b. (a -> b) -> a -> b
$ [RangedProp] -> Doc
forall a. Pretty a => [a] -> Doc
ppWithCommas [RangedProp]
ns]
      Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> if Bool
b then Doc
empty else Doc
dot
    Plug p :: Plugin
p o :: Object
o -> [Doc] -> Doc
sep [String -> Doc
keyword (String -> Doc) -> String -> Doc
forall a b. (a -> b) -> a -> b
$ Plugin -> String
forall a. Show a => a -> String
showUp Plugin
p, Object -> Doc
forall a. Pretty a => a -> Doc
pretty Object
o]
    Population b :: Bool
b r :: Relation
r l :: [Pair]
l -> let d :: Doc
d = [Pair] -> Doc
prettyContent [Pair]
l in
      if Bool
b then Doc
equals Doc -> Doc -> Doc
<+> Doc
d Doc -> Doc -> Doc
forall a. Semigroup a => a -> a -> a
<> Doc
dot else [Doc] -> Doc
fsep
        [ String -> Doc
keyword "POPULATION"
        , Relation -> Doc
forall a. Pretty a => a -> Doc
pretty Relation
r
        , String -> Doc
keyword "CONTAINS"
        , Doc
d ]

instance Pretty Context where
  pretty :: Context -> Doc
pretty (Context m :: Maybe Token
m ps :: [PatElem]
ps) = let l :: Doc
l = [Doc] -> Doc
vcat ([Doc] -> Doc) -> [Doc] -> Doc
forall a b. (a -> b) -> a -> b
$ (PatElem -> Doc) -> [PatElem] -> [Doc]
forall a b. (a -> b) -> [a] -> [b]
map PatElem -> Doc
forall a. Pretty a => a -> Doc
pretty [PatElem]
ps in case Maybe Token
m of
    Nothing -> Doc
l
    Just t :: Token
t -> [Doc] -> Doc
vcat
      [String -> Doc
keyword "CONTEXT" Doc -> Doc -> Doc
<+> String -> Doc
structId (Token -> String
tokStr Token
t), Doc
l, String -> Doc
keyword "ENDCONTEXT"]