1N/A{- |

1N/AModule : $Header$

1N/ACopyright : (c) Christian Maeder and Uni Bremen 2006

1N/ALicense : similar to LGPL, see HetCATS/LICENSE.txt or LIZENZ.txt

1N/A

1N/AMaintainer : maeder@tzi.de

1N/AStability : provisional

1N/APortability : portable

1N/A

1N/Adocument data type for displaying (heterogenous) CASL specifications

1N/Aat least as plain text and latex (and maybe in html as well)

1N/A

1N/Ainspired by John Hughes's and Simon Peyton Jones's Pretty Printer Combinators

1N/Ain "Text.PrettyPrint.HughesPJ", Thomas Hallgren's

1N/A<http://www.cse.ogi.edu/~hallgren/Programatica/tools/pfe.cgi?PrettyDoc>

1N/ADaan Leijen's PPrint: A prettier printer 2001, Olaf Chiti's

1N/APretty printing with lazy Dequeues 2003

1N/A-}

1N/A

1N/Amodule Common.Doc

1N/A ( -- * The document type

1N/A Doc -- Abstract

1N/A -- * Primitive Documents

1N/A , empty

1N/A , space

1N/A , semi

1N/A , comma

1N/A , colon

1N/A , equals

1N/A , lparen

1N/A , rparen

1N/A , lbrack

1N/A , rbrack

1N/A , lbrace

1N/A , rbrace

1N/A -- * Converting values into documents

1N/A , text

1N/A -- * Wrapping documents in delimiters

1N/A , parens

1N/A , brackets

1N/A , braces

1N/A , quotes

1N/A , doubleQuotes

1N/A -- * Combining documents

1N/A , (<>)

1N/A , (<+>)

1N/A , hcat

1N/A , hsep

1N/A , ($+$)

1N/A , vcat

1N/A , sep

1N/A , cat

1N/A , fsep

1N/A , fcat

1N/A , punctuate

1N/A , flushRight

1N/A , indentBy

1N/A -- * keywords

1N/A , keyword

1N/A , topKey

1N/A , indexed

1N/A , structId

1N/A -- * symbols

1N/A , dot

1N/A , bullet

1N/A , defn

1N/A , less

1N/A , lambda

1N/A , mapsto

1N/A , funArrow

1N/A , pfun

1N/A , cfun

1N/A , pcfun

1N/A , exequal

1N/A , forallDoc

1N/A , exists

1N/A , unique

1N/A , cross

1N/A , bar

1N/A , notDoc

1N/A , inDoc

1N/A , andDoc

1N/A , orDoc

1N/A , implies

1N/A , equiv

1N/A -- * docifying annotations and ids

1N/A , annoDoc

1N/A , idDoc

1N/A , idApplDoc

1N/A -- * transforming to existing formats

1N/A , codeOut

1N/A , toText

1N/A , toHPJDoc

1N/A , toLatex

1N/A ) where

1N/A

1N/Aimport Common.Id

import Common.Keywords

import Common.AS_Annotation

import Common.GlobalAnnotations

import qualified Common.Lib.Map as Map

import qualified Common.Lib.Pretty as Pretty

import Common.LaTeX_funs

import Common.ConvertLiteral

import Common.Prec

import Data.Char

import Data.List

infixl 6 <>

infixl 6 <+>

infixl 5 $+$

data TextKind =

IdKind | IdSymb | Symbol | Comment | Keyword | TopKey | Indexed | StructId

| Native

data Format = Small | FlushRight

data ComposeKind

= Vert -- ($+$) (no support for $$!)

| Horiz -- (<>)

| HorizOrVert -- either Horiz or Vert

| Fill

data Doc

= Empty -- creates an empty line if composed vertically

| AnnoDoc Annotation -- we know how to print annotations

| IdDoc Id -- for plain ids outside applications

| IdApplDoc Id [Doc] -- for mixfix applications and literal terms

| Text TextKind String -- non-empty and no white spaces inside

| Cat ComposeKind [Doc]

| Attr Format Doc -- for annotations

| IndentBy Doc Doc Doc

{-

IdentBy refDoc startDoc hangDoc

is: startDoc <> (length refDoc - length startDoc) <> hangDoc

if refDoc >= startDoc

(i.e indent hangBlock by refDoc and put it beside startDoc)

is: startDoc <> hangDoc if it fits on a single line!

is: startDoc $+$

nest refDoc hangDoc

if refDoc < startDoc

-}

isEmpty :: Doc -> Bool

isEmpty d = case d of

Empty -> True

_ -> False

empty :: Doc -- ^ An empty document

empty = Empty

text :: String -> Doc

text = Text IdKind

semi :: Doc -- ^ A ';' character

semi = text ";"

comma :: Doc -- ^ A ',' character

comma = text ","

colon :: Doc -- ^ A ':' character

colon = text colonS

-- the only legal white space within Text

space :: Doc -- ^ A horizontal space (omitted at end of line)

space = text " "

equals :: Doc -- ^ A '=' character

equals = text equalS

-- use symbol for signs that need to be put in mathmode for latex

symbol :: String -> Doc

symbol = Text Symbol

-- for text within comments

commentText :: String -> Doc

commentText = Text Comment

-- don't escape this strings since they are interpreted by latex

native :: String -> Doc

native = Text Native

lparen, rparen, lbrack, rbrack, lbrace, rbrace, quote, doubleQuote :: Doc

lparen = symbol "("

rparen = symbol ")"

lbrack = symbol "["

rbrack = symbol "]"

lbrace = symbol "{" -- to allow for latex translations

rbrace = symbol "}"

quote = symbol "\'"

doubleQuote = symbol "\""

parens :: Doc -> Doc -- ^ Wrap document in @(...)@

parens d = fcat [lparen, d, rparen]

brackets :: Doc -> Doc -- ^ Wrap document in @[...]@

brackets d = fcat [lbrack, d, rbrack]

braces :: Doc -> Doc -- ^ Wrap document in @{...}@

braces d = cat [lbrace <> d, rbrace]

quotes :: Doc -> Doc -- ^ Wrap document in @\'...\'@

quotes d = hcat [quote, d, quote]

doubleQuotes :: Doc -> Doc -- ^ Wrap document in @\"...\"@

doubleQuotes d = hcat [doubleQuote, d, doubleQuote]

(<>) :: Doc -> Doc -> Doc -- ^Beside

a <> b = Cat Horiz [a, b]

hcat :: [Doc] -> Doc -- ^List version of '<>'

hcat = Cat Horiz

(<+>) :: Doc -> Doc -> Doc -- ^Beside, separated by space

a <+> b = if isEmpty a then b else

if isEmpty b then a else Cat Horiz [a, space, b]

punctuate :: Doc -> [Doc] -> [Doc]

punctuate d l = case l of

x : r@(_ : _) -> (x <> d) : punctuate d r

_ -> l

hsep :: [Doc] -> Doc -- ^List version of '<+>'

hsep = hcat . punctuate space

($+$) :: Doc -> Doc -> Doc; -- ^Above, without dovetailing.

a $+$ b = Cat Vert [a, b]

vcat :: [Doc] -> Doc -- ^List version of '$+$'

vcat = Cat Vert

cat :: [Doc] -> Doc -- ^ Either hcat or vcat

cat = Cat HorizOrVert

sep :: [Doc] -> Doc -- ^ Either hsep or vcat

sep = cat . punctuate space

fcat :: [Doc] -> Doc -- ^ \"Paragraph fill\" version of cat

fcat = Cat Fill

fsep :: [Doc] -> Doc -- ^ \"Paragraph fill\" version of sep

fsep = fcat . punctuate space

keyword, topKey, indexed, structId :: String -> Doc

keyword = Text Keyword

indexed = Text Indexed

structId = Text StructId

topKey = Text TopKey

-- | docs possibly rendered differently for Text or LaTeX

dot, bullet, defn, less, lambda, mapsto, funArrow, pfun, cfun, pcfun,

exequal, forallDoc, exists, unique, cross, bar, notDoc, inDoc, andDoc,

orDoc, implies, equiv :: Doc

dot = text dotS

bullet = symbol dotS

defn = symbol defnS

less = symbol lessS

lambda = symbol lambdaS

mapsto = symbol mapsTo

funArrow = symbol funS

pfun = symbol pFun

cfun = symbol contFun

pcfun = symbol pContFun

exequal = symbol exEqual

forallDoc = symbol forallS

exists = symbol existsS

unique = symbol existsUnique

cross = symbol prodS

bar = symbol barS

notDoc = symbol notS

inDoc = symbol inS

andDoc = symbol lAnd

orDoc = symbol lOr

implies = symbol implS

equiv = symbol equivS

-- | we know how to print annotations

annoDoc :: Annotation -> Doc

annoDoc = AnnoDoc

-- | for plain ids outside applications

idDoc :: Id -> Doc

idDoc = IdDoc

-- | for mixfix applications and literal terms (may print \"\" for empty)

idApplDoc :: Id -> [Doc] -> Doc

idApplDoc = IdApplDoc

-- | put document as far to the right as fits (for annotations)

flushRight :: Doc -> Doc

flushRight = Attr FlushRight

small :: Doc -> Doc

small = Attr Small

{- | print second argument and then indent the last one by the width

of the first one -}

indentBy :: Doc -> Doc -> Doc -> Doc

indentBy = IndentBy

-- * folding stuff

data DocRecord a = DocRecord

{ foldEmpty :: Doc -> a

, foldAnnoDoc :: Doc -> Annotation -> a

, foldIdDoc :: Doc -> Id -> a

, foldIdApplDoc :: Doc -> Id -> [a] -> a

, foldText :: Doc -> TextKind -> String -> a

, foldCat :: Doc -> ComposeKind -> [a] -> a

, foldAttr :: Doc -> Format -> a -> a

, foldIndentBy :: Doc -> a -> a -> a -> a

}

foldDoc :: DocRecord a -> Doc -> a

foldDoc r d = case d of

Empty -> foldEmpty r d

AnnoDoc a -> foldAnnoDoc r d a

IdDoc i -> foldIdDoc r d i

IdApplDoc i l -> foldIdApplDoc r d i $ map (foldDoc r) l

Text k s -> foldText r d k s

Cat k l -> foldCat r d k $ map (foldDoc r) l

Attr a e -> foldAttr r d a $ foldDoc r e

IndentBy e f g ->

foldIndentBy r d (foldDoc r e) (foldDoc r f) $ foldDoc r g

idRecord :: DocRecord Doc

idRecord = DocRecord

{ foldEmpty = \ _ -> Empty

, foldAnnoDoc = \ _ -> AnnoDoc

, foldIdDoc = \ _ -> IdDoc

, foldIdApplDoc = \ _ -> IdApplDoc

, foldText = \ _ -> Text

, foldCat = \ _ -> Cat

, foldAttr = \ _ -> Attr

, foldIndentBy = \ _ -> IndentBy

}

anyRecord :: DocRecord a

anyRecord = DocRecord

{ foldEmpty = error "anyRecord.Empty"

, foldAnnoDoc = error "anyRecord.AnnoDoc"

, foldIdDoc = error "anyRecord.IdDoc"

, foldIdApplDoc = error "anyRecord.IdApplDoc"

, foldText = error "anyRecord.Text"

, foldCat = error "anyRecord.Cat"

, foldAttr = error "anyRecord.Attr"

, foldIndentBy = error "anyRecord.IndentBy"

}

-- * conversions

-- | simple conversion to a standard text document

toText :: Doc -> Pretty.Doc

toText = toHPJDoc emptyGlobalAnnos

-- | simple conversion to a standard text document

toHPJDoc :: GlobalAnnos -> Doc -> Pretty.Doc

toHPJDoc ga = foldDoc anyRecord

{ foldEmpty = \ _ -> Pretty.empty

, foldText = \ _ _ -> Pretty.text

, foldCat = \ _ c -> case c of

Vert -> Pretty.vcat

Horiz -> Pretty.hcat

HorizOrVert -> Pretty.cat

Fill -> Pretty.fcat

, foldAttr = \ _ k d -> case k of

FlushRight -> let l = length $ show d in

if l < 80 then Pretty.nest (80 - l) d else d

_ -> d

, foldIndentBy = \ _ d1 d2 d3 ->

d2 Pretty.$$ Pretty.nest (length $ show d1) d3

} . codeOut ga Nothing Map.empty

-- | conversion to latex

toLatex :: GlobalAnnos -> Doc -> Pretty.Doc

toLatex ga = let dm = Map.map (Map.! DF_LATEX) .

Map.filter (Map.member DF_LATEX) $ display_annos ga

in foldDoc anyRecord

{ foldEmpty = \ _ -> Pretty.empty

, foldText = \ _ k s -> textToLatex False k s

, foldCat = \ _ c l -> case c of

Horiz -> Pretty.hcat l

_ -> latex_macro setTab Pretty.<>

latex_macro startTab Pretty.<> (case c of

Vert -> Pretty.vcat

Horiz -> error "toLatex.Horiz"

HorizOrVert -> Pretty.cat

Fill -> Pretty.fcat) l Pretty.<> latex_macro endTab

, foldAttr = \ o k d -> case k of

FlushRight -> flushright d

Small -> case o of

Attr Small (Text j s) -> textToLatex True j s

_ -> error "toLatex.Small"

, foldIndentBy = \ _ d1 d2 d3 ->

d2 Pretty.$$ Pretty.nest (length $ show d1) d3

} . makeSmall False . codeOut ga (Just DF_LATEX) dm

textToLatex :: Bool -> TextKind -> String -> Pretty.Doc

textToLatex b k s = let e = escape_comment_latex s in

if elem s $ map (: []) ",;[]() "

then makeSmallLatex b $ casl_normal_latex s

else case k of

IdKind -> makeSmallLatex b $ hc_sty_id e

IdSymb -> makeSmallLatex b $ hc_sty_axiom e

Symbol -> makeSmallLatex b $ symbolToLatex s

Comment -> (if b then makeSmallLatex b . casl_comment_latex

else casl_normal_latex) e

-- multiple spaces should be replaced by \hspace

Keyword -> (if b then makeSmallLatex b . hc_sty_small_keyword

else hc_sty_plain_keyword) e

TopKey -> hc_sty_casl_keyword e

Indexed -> hc_sty_structid_indexed e

StructId -> hc_sty_structid e

Native -> makeSmallLatex b $ hc_sty_axiom s

makeSmallLatex :: Bool -> Pretty.Doc -> Pretty.Doc

makeSmallLatex b d =

if b then Pretty.hcat [latex_macro startAnno, d, latex_macro endAnno]

else d

symbolToLatex :: String -> Pretty.Doc

symbolToLatex s = Map.findWithDefault (hc_sty_axiom

$ escape_latex s) s latexSymbols

latexSymbols :: Map.Map String Pretty.Doc

latexSymbols = Map.fromList

[ (dotS, bullet_latex)

, (diamondS, hc_sty_axiom "\\Diamond")

, (percentS, hc_sty_small_keyword "\\%")

, (percents, hc_sty_small_keyword "\\%\\%")

, ("{", casl_normal_latex "\\{")

, ("}", casl_normal_latex "\\}")

, ("__", hc_sty_axiom "\\_\\_")

, (lambdaS, hc_sty_axiom "\\lambda")

, (mapsTo, mapsto_latex)

, (funS, rightArrow)

, (contFun, cfun_latex)

, (pContFun, pcfun_latex)

, (exEqual, exequal_latex)

, (forallS, forall_latex)

, (existsS, exists_latex)

, (existsUnique, unique_latex)

, (prodS, hc_sty_axiom "\\times")

, (notS, hc_sty_axiom "\\neg")

, (inS, hc_sty_axiom "\\in")

, (lAnd, hc_sty_axiom "\\wedge")

, (lOr, hc_sty_axiom "\\vee")

, (implS, hc_sty_axiom "\\Rightarrow")

, (equivS, hc_sty_axiom "\\Leftrightarrow") ]

makeSmall :: Bool -> Doc -> Doc

makeSmall b = foldDoc idRecord

{ foldAttr = \ _ k d -> makeSmall (case k of

Small -> True

_ -> b) d

, foldCat = \ (Cat c l) _ _ -> Cat c $ map (makeSmall b) l

, foldIndentBy = \ (IndentBy d1 d2 d3) _ _ _ ->

IndentBy (makeSmall b d1) (makeSmall b d2) $ makeSmall b d3

, foldText = \ d _ _ -> if b then Attr Small d else d

}

-- * coding out stuff

{- | transform document according to a specific display map and other

global annotations like precedences, associativities, and literal

annotations. -}

codeOut :: GlobalAnnos -> Maybe Display_format -> Map.Map Id [Token] -> Doc

-> Doc

codeOut ga d m = foldDoc idRecord

{ foldAnnoDoc = \ _ -> small . codeOutAnno d m

, foldIdDoc = \ _ -> codeOutId m

, foldIdApplDoc = codeOutAppl ga d m

}

codeToken :: String -> Doc

codeToken s = case s of

[] -> empty

h : _ -> (if isAlphaNum h || elem h "._'" then text else Text IdSymb) s

codeOrigId :: Map.Map Id [Token] -> Id -> [Doc]

codeOrigId m (Id ts cs _) = let

(toks, places) = splitMixToken ts

conv = map (codeToken . tokStr) in

if null cs then conv ts

else conv toks ++ codeCompIds m cs : conv places

codeCompIds :: Map.Map Id [Token] -> [Id] -> Doc

codeCompIds m cs =

hcat $ lbrack : intersperse comma (map (codeOutId m) cs) ++ [rbrack]

codeIdToks :: [Token] -> [Doc]

codeIdToks = map (\ t -> let s = tokStr t in

if isPlace t then symbol s else native s)

codeOutId :: Map.Map Id [Token] -> Id -> Doc

codeOutId m i = hcat $ case Map.lookup i m of

Nothing -> codeOrigId m i

Just ts -> codeIdToks ts

annoLine :: String -> Doc

annoLine w = percent <> keyword w

annoLparen :: String -> Doc

annoLparen w = percent <> keyword w <> lparen

wrapAnnoLines :: Maybe Display_format -> Doc -> [String] -> Doc -> Doc

wrapAnnoLines d a l b = case map (commentText .

maybe id (const $ dropWhile isSpace) d) l of

[] -> a <> b

[x] -> hcat [a, x, b]

ds@(x : r) -> case d of

Nothing -> vcat $ fcat [a, x] : init r ++ [fcat [last r, b]]

Just _ -> a <+> vcat ds <> b

percent :: Doc

percent = symbol percentS

annoRparen :: Doc

annoRparen = rparen <> percent

cCommaT :: Map.Map Id [Token] -> [Id] -> [Doc]

cCommaT m = punctuate comma . map (codeOutId m)

hCommaT :: Map.Map Id [Token] -> [Id] -> Doc

hCommaT m = hsep . cCommaT m

fCommaT :: Map.Map Id [Token] -> [Id] -> Doc

fCommaT m = fsep . cCommaT m

codeOutAnno :: Maybe Display_format -> Map.Map Id [Token] -> Annotation -> Doc

codeOutAnno d m a = case a of

Unparsed_anno aw at _ -> case at of

Line_anno s -> (case aw of

Annote_word w -> annoLine w

Comment_start -> symbol percents) <> commentText s

Group_anno l -> case aw of

Annote_word w -> wrapAnnoLines d (annoLparen w) l annoRparen

Comment_start -> wrapAnnoLines d (percent <> lbrace) l

(rbrace <> percent)

Display_anno i ds _ -> annoLparen displayS <> fsep

( hcat (codeOrigId m i) :

map ( \ (df, s) -> percent <> text (lookupDisplayFormat df)

<+> maybe (commentText s) (const $ codeOutId m i)

(Map.lookup i m)) ds) <> annoRparen

List_anno i1 i2 i3 _ -> annoLine listS <+> hCommaT m [i1, i2, i3]

Number_anno i _ -> annoLine numberS <+> codeOutId m i

Float_anno i1 i2 _ -> annoLine floatingS <+> hCommaT m [i1, i2]

String_anno i1 i2 _ -> annoLine stringS <+> hCommaT m [i1, i2]

Prec_anno p l1 l2 _ -> annoLparen precS <>

fsep [ braces $ fCommaT m l1

, case p of

Lower -> symbol lessS

Higher -> symbol greaterS

BothDirections -> symbol lessS <> symbol greaterS

NoDirection -> symbol greaterS <> symbol lessS

, braces $ fCommaT m l2

] <> annoRparen

Assoc_anno s l _ -> annoLparen (case s of

ALeft -> left_assocS

ARight -> right_assocS)

<> fCommaT m l <> annoRparen

Label l _ -> wrapAnnoLines d (annoLparen "") l annoRparen

Semantic_anno sa _ -> annoLine $ lookupSemanticAnno sa

splitDoc :: Doc -> Maybe (Id, [Doc])

splitDoc d = case d of

IdApplDoc i l -> Just (i, l)

_ -> Nothing

data Weight = Weight Int Id Id Id -- top, left, right

-- print literal terms and mixfix applications

codeOutAppl :: GlobalAnnos -> Maybe Display_format -> Map.Map Id [Token]

-> Doc -> Id -> [Doc] -> Doc

codeOutAppl ga md m origDoc _ args = case origDoc of

IdApplDoc i@(Id ts cs _) aas ->

let mk t = codeToken $ tokStr t

pa = prec_annos ga

assocs = assoc_annos ga

precs = mkPrecIntMap pa

p = getSimpleIdPrec precs i

doSplit = maybe (error "doSplit") id . splitDoc

mkList op largs cl = fsep $ codeOutId m op : punctuate comma

(map (codeOut ga md m) largs)

++ [codeOutId m cl]

in if isGenNumber splitDoc ga i aas then

mk $ toNumber doSplit i aas

else if isGenFrac splitDoc ga i aas then

mk $ toFrac doSplit aas

else if isGenFloat splitDoc ga i aas then

mk $ toFloat doSplit ga aas

else if isGenString splitDoc ga i aas then

mk $ toString doSplit ga i aas

else if isGenList splitDoc ga i aas then

toMixfixList mkList doSplit ga i aas

else if null args || length args /= placeCount i then

codeOutId m i <> if null args then empty else

parens (fsep $ punctuate comma args)

else let

parArgs = reverse $ foldl ( \ l (arg, d) ->

let pArg = parens d

in case getWeight ga arg of

Nothing -> d : l

Just (Weight q ta la ra) ->

(if isKnownArg assocs precs i ta then

if isLeftArg i l then

if checkArg ARight ga (i, p) (ta, q) ra

then d else pArg

else if isRightArg i l then

if checkArg ALeft ga (i, p) (ta, q) la

then d else pArg

else d

else pArg) : l) [] $ zip aas args

fts = fst $ splitMixToken ts

(rArgs, fArgs) = mapAccumL ( \ ac t ->

if isPlace t then case ac of

hd : tl -> (tl, hd)

_ -> error "addPlainArg"

else (ac, codeToken $ tokStr t)) parArgs fts

in fsep $ fArgs ++ (if null cs then [] else [codeCompIds m cs])

++ rArgs

_ -> error "Common.Doc.codeOutAppl"

getWeight :: GlobalAnnos -> Doc -> Maybe Weight

getWeight ga d = let

pa = prec_annos ga

precs = mkPrecIntMap pa

in case d of

IdApplDoc i aas@(hd : _) -> let p = getSimpleIdPrec precs i in

if isGenLiteral splitDoc ga i aas then Nothing else

let lw = case getWeight ga hd of

Just (Weight _ _ l _) -> nextWeight ALeft ga i l

Nothing -> i

rw = case getWeight ga $ last aas of

Just (Weight _ _ _ r) -> nextWeight ARight ga i r

Nothing -> i

in Just $ Weight p i lw rw

_ -> Nothing

isKnownArg :: AssocMap -> PrecMap -> Id -> Id -> Bool

isKnownArg assocs p op arg = let m = precMap p in

if isInfix arg then

Map.member op m && Map.member arg m ||

op == arg && Map.member op assocs

else True