DocUtils.hs

{- |
Module      :  ./Common/DocUtils.hs
Description :  Pretty class for pretty printing with instances plus utilities
Copyright   :  (c) jianchun wang and Uni Bremen 2006
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Christian.Maeder@dfki.de
Stability   :  provisional
Portability :  portable

'Pretty' class for pretty printing, some instances and other utility functions
-}

module Common.DocUtils where

import Common.AS_Annotation
import Common.Doc
import Common.Id
import Common.IRI
import qualified Data.Set as Set
import qualified Data.Map as Map
import Common.GlobalAnnotations

-- * the class stuff
class Show a => Pretty a where
    pretty :: a -> Doc
    pretties :: [a] -> Doc
    pretties = brackets . ppWithCommas

instance Pretty Char where
    pretty c = text [c]
    pretties = text . take 25

instance Pretty () where
    pretty () = empty

instance Pretty Id where
    pretty = idDoc

instance Pretty Annotation where
    pretty = annoDoc

instance Pretty Token where
   pretty = sidDoc

-- | convert a token to a document (different from 'text' for LaTex)
sidDoc :: Token -> Doc
sidDoc = idDoc . simpleIdToId

-- | print several annotations vertically (each in a new line)
printAnnotationList :: [Annotation] -> Doc
printAnnotationList = vcat . map annoDoc

-- | print annotations flush right
printTrailer :: [Annotation] -> Doc
printTrailer = flushRight . hsep . map annoDoc

-- | add trailing annotation to a document
splitAndPrintRAnnos :: Doc -> [Annotation] -> Doc
splitAndPrintRAnnos i ras =
    let (r, s) = splitRAnnos ras
    in (if null s then id else ($+$ printAnnotationList s))
       $ if null r then i else fsep [i, printTrailer r]

-- | conditionally add a 'semi' after the doc but before trailing annotations
printSemiAnno :: (a -> Doc) -> Bool -> Annoted a -> Doc
printSemiAnno pp addSemi (Annoted i _ las ras) =
    let r = splitAndPrintRAnnos
            ((if addSemi then (<> semi) else id) $ pp i) ras
    in if null las then r else
           (if startsWithSemanticAnno las then id else (text "" $+$))
              $ printAnnotationList las $+$ r

-- | test for semantic annos before structured specs
startsWithSemanticAnno :: [Annotation] -> Bool
startsWithSemanticAnno l = case l of
    Semantic_anno _ _ : _ -> True
    _ -> False

-- | print annoted items with trailing semicolons except for the last item
semiAnnos :: (a -> Doc) -> [Annoted a] -> Doc
semiAnnos pp l = if null l then empty else
           vcat $ map (printSemiAnno pp True) (init l)
                ++ [printAnnoted pp $ last l]

-- | print sentence with label and non-axioms with implied annotation
printAnnoted :: (a -> Doc) -> Annoted a -> Doc
printAnnoted pp = printSemiAnno pp False

instance (Pretty a) => Pretty (Annoted a) where
    pretty = printAnnoted pretty

-- | convert a named sentence into an annoted one
fromLabelledSen :: Named s -> Annoted s
fromLabelledSen s = let label = senAttr s in
    appendAnno (emptyAnno $ sentence s) $
    (if null label then [] else [Label [label] nullRange])
    ++ if isAxiom s then [] else [Semantic_anno SA_implied nullRange]

{- | function to split the annotation to the right of an item.
* fst contains printed label and implied annotion
  if any at the begining of the list of annotations
* snd contains the remaining annos -}
splitRAnnos :: [Annotation] -> ([Annotation], [Annotation])
splitRAnnos r = case r of
    [l] | isLabel l || isImplied l -> (r, [])
    l : s@(i : t)
      | isLabel l ->
            if isImplied i then ([l, i], t)
            else ([l], s)
      | isImplied l -> ([l], s)
    _ -> ([], r)

-- | add global annotations for proper mixfix printing
useGlobalAnnos :: GlobalAnnos -> Doc -> Doc
useGlobalAnnos = changeGlobalAnnos . const

-- | like punctuate but prepends the symbol to all tail elements
prepPunctuate :: Doc -> [Doc] -> [Doc]
prepPunctuate s l = case l of
    x : r@(_ : _) -> x : map (s <>) r
    _ -> l

instance (Pretty a, Pretty b) => Pretty (Either a b) where
    pretty = printEither pretty pretty

printEither :: (a -> Doc) -> (b -> Doc) -> Either a b -> Doc
printEither fA fB ei = case ei of
    Left x -> fA x
    Right x -> fB x

instance Pretty a => Pretty (Maybe a) where
    pretty = printMaybe pretty

printMaybe :: (a -> Doc) -> Maybe a -> Doc
printMaybe fA mb = case mb of
    Just x -> fA x
    Nothing -> empty

ppWithCommas :: Pretty a => [a] -> Doc
ppWithCommas = sepByCommas . map pretty

instance (Pretty a, Pretty b) => Pretty (a, b) where
    pretty = printPair pretty pretty

printPair :: (a -> Doc) -> (b -> Doc) -> (a, b) -> Doc
printPair fA fB (a, b) = parens $ sepByCommas [fA a, fB b]

instance (Pretty a, Pretty b, Pretty c) => Pretty (a, b, c) where
    pretty = printTriple pretty pretty pretty

printTriple :: (a -> Doc) -> (b -> Doc) -> (c -> Doc) -> (a, b, c) -> Doc
printTriple fA fB fC (a, b, c) = parens $ sepByCommas [fA a, fB b, fC c]

instance (Pretty a, Pretty b, Pretty c, Pretty d) => Pretty (a, b, c, d) where
    pretty (a, b, c, d) =
      parens $ sepByCommas [pretty a, pretty b, pretty c, pretty d]

instance Pretty Int where
    pretty = sidDoc . mkSimpleId . show

instance Pretty Integer where
    pretty = sidDoc . mkSimpleId . show

instance Pretty a => Pretty [a] where
    pretty = pretties

instance Pretty a => Pretty (Set.Set a) where
    pretty = printSet braces sepByCommas

-- | container size
data CSize = CEmpty | CSingle | CMult

ppList :: (a -> Doc) -> (CSize -> Doc -> Doc) -> ([Doc] -> Doc) -> [a] -> Doc
ppList fa brace inter l = case l of
  [] -> brace CEmpty empty
  [e] -> brace CSingle $ fa e
  _ -> brace CMult . inter $ map fa l

ppSet :: (a -> Doc) -> (CSize -> Doc -> Doc) -> ([Doc] -> Doc)
  -> Set.Set a -> Doc
ppSet fa brace inter = ppList fa brace inter . Set.toList

optBraces :: CSize -> Doc -> Doc
optBraces c = case c of
  CSingle -> id
  _ -> braces

printSet :: Pretty a => (Doc -> Doc) -> ([Doc] -> Doc) -> Set.Set a -> Doc
printSet = ppSet pretty . const

printSetMap :: (Pretty k, Pretty a) => Doc -> Doc -> Map.Map k (Set.Set a)
  -> Doc
printSetMap header sepa = vcat . concatMap ( \ (i, s) ->
    map ( \ e -> header <+> pretty i <+> colon <> sepa <> pretty e)
            $ Set.toList s) . Map.toList

printMap :: (Pretty a, Pretty b) => (Doc -> Doc) -> ([Doc] -> Doc)
         -> (Doc -> Doc -> Doc) -> Map.Map a b -> Doc
printMap = ppMap pretty pretty . const

ppMap :: (a -> Doc) -> (b -> Doc) -> (CSize -> Doc -> Doc) -> ([Doc] -> Doc)
      -> (Doc -> Doc -> Doc) -> Map.Map a b -> Doc
ppMap fa fb brace inter pairDoc =
    ppPairlist fa fb brace inter pairDoc . Map.toList

ppPairlist :: (a -> Doc) -> (b -> Doc) -> (CSize -> Doc -> Doc)
  -> ([Doc] -> Doc) -> (Doc -> Doc -> Doc) -> [(a, b)] -> Doc
ppPairlist fa fb brace inter pairDoc =
  ppList (\ (a, b) -> pairDoc (fa a) (fb b)) brace inter

pairElems :: Doc -> Doc -> Doc
pairElems a b = a <+> mapsto <+> b

instance (Pretty a, Pretty b) => Pretty (Map.Map a b) where
    pretty = printMap braces sepByCommas pairElems

-- | start with a bullet, i.e. formulas
addBullet :: Doc -> Doc
addBullet = (bullet <+>)

showDoc :: Pretty a => a -> ShowS
showDoc = shows . pretty

-- | like showDoc but considers global annotations
showGlobalDoc :: Pretty a => GlobalAnnos -> a -> ShowS
showGlobalDoc ga = shows . useGlobalAnnos ga . pretty

instance Pretty IRI where
  pretty = text . show