{- |
Module      :  $Header$
Copyright   :  (c) Felix Gabriel Mance
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  f.mance@jacobs-university.de
Stability   :  provisional
Portability :  portable

Pretty printing for the Manchester Syntax of OWL 2
-}

module OWL2.ManchesterPrint where

import Common.Doc
import Common.DocUtils
import Common.AS_Annotation as Anno
import Common.Lib.State

import OWL2.AS
import OWL2.Extract
import OWL2.MS
import OWL2.Sign
import OWL2.Theorem
import OWL2.Print
import OWL2.Keywords
import OWL2.ColonKeywords

import Data.Function
import Data.List
import qualified Data.Map as Map
import qualified Data.Set as Set

-- | OWL2 signature printing

printOneNamed :: Anno.Named Axiom -> Doc
printOneNamed ns = pretty
  $ (if Anno.isAxiom ns then rmImplied else addImplied) $ Anno.sentence ns

delTopic :: Extended -> Sign -> Sign
delTopic e s = case e of
  ClassEntity (Expression c) -> s { concepts = Set.delete c $ concepts s }
  ObjectEntity (ObjectProp o) -> s
    { objectProperties = Set.delete o $ objectProperties s }
  SimpleEntity et -> execState (modEntity Set.delete et) s
  _ -> s

groupAxioms :: [Axiom] -> [Frame]
groupAxioms =
  concatMap (\ l@(PlainAxiom e _ : _) -> case e of
    Misc _ -> map (Frame e . (: []) . axiomBit) l
    _ -> [Frame e $ map axiomBit l])
  . groupBy (on (==) axiomTopic) . sortBy (on compare axiomTopic)

printOWLBasicTheory :: (Sign, [Named Axiom]) -> Doc
printOWLBasicTheory = printBasicTheory . prepareBasicTheory

prepareBasicTheory :: (Sign, [Named Axiom]) -> (Sign, [Named Axiom])
prepareBasicTheory (s, l) =
  (s { prefixMap = Map.union (prefixMap s) predefPrefixes }, l)

printBasicTheory :: (Sign, [Named Axiom]) -> Doc
printBasicTheory = pretty . convertBasicTheory

convertBasicTheory :: (Sign, [Named Axiom]) -> OntologyDocument
convertBasicTheory (sig, l) = let
  (axs, ths) = partition Anno.isAxiom l
  cnvrt f = map f . groupAxioms . map Anno.sentence
  s = foldr (delTopic . axiomTopic . sentence) sig l
  in OntologyDocument (prefixMap s) $ emptyOntology
  $ toDecl s ++ cnvrt rmImpliedFrame axs ++ cnvrt addImpliedFrame ths

instance Pretty Sign where
    pretty = printSign

printSignElem :: Pretty a => Sign -> String -> (Sign -> Set.Set a) -> Doc
printSignElem s ty f = vcat $ map (\ t -> keyword ty <+> pretty t)
    $ Set.toList $ f s

printSign :: Sign -> Doc
printSign s = vcat
    (map (\ (c, l) -> hsep $ map text [prefixC, c ++ ":", '<' : l ++ ">"])
    $ Map.toList $ prefixMap s)
        $++$ foldl1 ($++$) (map (uncurry $ printSignElem s)
                [ (datatypeC, datatypes)
                , (classC, concepts)
                , (objectPropertyC, objectProperties)
                , (dataPropertyC, dataProperties)
                , (individualC, individuals)
                , (annotationPropertyC, annotationRoles) ])

instance Pretty Fact where
    pretty = printFact

printFact :: Fact -> Doc
printFact pf = case pf of
    ObjectPropertyFact pn op i -> printPositiveOrNegative pn
           <+> pretty op <+> pretty i
    DataPropertyFact pn dp l -> printPositiveOrNegative pn
           <+> pretty dp <+> pretty l

instance Pretty ListFrameBit where
    pretty = printListFrameBit

-- | ListFrameBits only with relations
printListFrameBit :: ListFrameBit -> Doc
printListFrameBit lfb = case lfb of
    AnnotationBit a -> printAnnotatedList a
    ExpressionBit a -> printAnnotatedList a
    ObjectBit a -> printAnnotatedList a
    DataBit a -> printAnnotatedList a
    IndividualSameOrDifferent a -> printAnnotatedList a
    _ -> empty

printMisc :: Pretty a => Annotations -> (b -> Doc) -> b -> AnnotatedList a
    -> Doc
printMisc a f r anl = f r <+> (printAnnotations a $+$ printAnnotatedList anl)

-- | Misc ListFrameBits
printMiscBit :: Relation -> Annotations -> ListFrameBit -> Doc
printMiscBit r a lfb = case lfb of
    ExpressionBit anl -> printMisc a printEquivOrDisjointClasses (getED r) anl
    ObjectBit anl -> printMisc a printEquivOrDisjointProp (getED r) anl
    DataBit anl -> printMisc a printEquivOrDisjointProp (getED r) anl
    IndividualSameOrDifferent anl ->
        printMisc a printSameOrDifferentInd (getSD r) anl
    _ -> empty

printAnnFrameBit :: Annotations -> AnnFrameBit -> Doc
printAnnFrameBit a afb = case afb of
    AnnotationFrameBit _ -> printAnnotations a
    DatatypeBit x -> printAnnotations a
          $+$ keyword equivalentToC <+> pretty x
    ClassDisjointUnion x -> keyword disjointUnionOfC
      <+> (printAnnotations a
          $+$ vcat (punctuate comma ( map pretty x )))
    ClassHasKey op dp -> keyword hasKeyC <+> (printAnnotations a
      $+$ vcat (punctuate comma $ map pretty op ++ map pretty dp))
    ObjectSubPropertyChain opl -> keyword subPropertyChainC
      <+> (printAnnotations a $+$ fsep (prepPunctuate (keyword oS <> space)
          $ map pretty opl))
    DataFunctional -> keyword characteristicsC <+>
          (printAnnotations a $+$ printCharact functionalS)

instance Pretty FrameBit where
    pretty = printFrameBit

printFrameBit :: FrameBit -> Doc
printFrameBit fb = case fb of
    ListFrameBit r lfb -> case r of
        Just rel -> printRelation rel <+> pretty lfb
        Nothing -> case lfb of
            ObjectCharacteristics x -> keyword characteristicsC
                <+> printAnnotatedList x
            DataPropRange x -> keyword rangeC <+> printAnnotatedList x
            IndividualFacts x -> keyword factsC <+> printAnnotatedList x
            _ -> empty
    AnnFrameBit a afb -> printAnnFrameBit a afb

instance Pretty Frame where
    pretty = printFrame

printFrame :: Frame -> Doc
printFrame (Frame eith bl) = case eith of
    SimpleEntity (Entity _ e uri) -> keyword (showEntityType e) <+>
            fsep [pretty uri $+$ vcat (map pretty bl)]
    ObjectEntity ope -> keyword objectPropertyC <+>
            (pretty ope $+$ fsep [vcat (map pretty bl)])
    ClassEntity ce -> keyword classC <+>
            (pretty ce $+$ fsep [vcat (map pretty bl)])
    Misc a -> case bl of
        [ListFrameBit (Just r) lfb] -> printMiscBit r a lfb
        [AnnFrameBit ans (AnnotationFrameBit Assertion)] ->
            let [Annotation _ iri _] = a
            in keyword individualC <+> (pretty iri $+$ printAnnotations ans)
        h : r -> printFrame (Frame eith [h])
          $+$ printFrame (Frame eith r)
        [] -> empty

instance Pretty Axiom where
    pretty = printAxiom

printAxiom :: Axiom -> Doc
printAxiom (PlainAxiom e fb) = printFrame (Frame e [fb])

printImport :: ImportIRI -> Doc
printImport x = keyword importC <+> pretty x

printPrefixes :: PrefixMap -> Doc
printPrefixes x = vcat (map (\ (a, b) ->
       (text "Prefix:" <+> text a <> colon <+> text ('<' : b ++ ">")))
          (Map.toList x))

-- | Printing the ontology
instance Pretty Ontology where
    pretty = printOntology

printOntology :: Ontology -> Doc
printOntology Ontology {name = a, imports = b, ann = c, ontFrames = d} =
    (if nullQName == a then empty else keyword ontologyC <+> pretty a)
    $++$ vcat (map printImport b)
    $++$ vcat (map printAnnotations c) $+$ vcat (map pretty d)

printOntologyDocument :: OntologyDocument -> Doc
printOntologyDocument OntologyDocument {prefixDeclaration = a, ontology = b} =
    printPrefixes a $++$ pretty b

instance Pretty OntologyDocument where
    pretty = printOntologyDocument
