{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  ./Adl/Sign.hs
Description :  ADL signature and sentences
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.Sign where

import Adl.As
import Adl.Print ()

import Common.AS_Annotation
import Common.Doc
import Common.DocUtils
import Common.Id
import Common.Result
import qualified Common.Lib.Rel as Rel

import Data.Data
import qualified Data.Map as Map
import qualified Data.Set as Set

type RelMap = Map.Map Id (Set.Set RelType)

data Sign = Sign
  { rels :: RelMap
  , isas :: Rel.Rel Concept
  } deriving (Eq, Ord, Show, Typeable, Data)

emptySign :: Sign
emptySign = Sign
  { rels = Map.empty
  , isas = Rel.empty }

closeSign :: Sign -> Sign
closeSign s = s { isas = Rel.transClosure $ isas s }

isSubSignOf :: Sign -> Sign -> Bool
isSubSignOf s1 s2 =
  Map.isSubmapOfBy Set.isSubsetOf (rels s1) (rels s2)
  && Rel.isSubrelOf (isas s1) (isas s2)

signUnion :: Sign -> Sign -> Result Sign
signUnion s1 s2 = return s1
  { rels = Map.unionWith Set.union (rels s1) (rels s2)
  , isas = Rel.union (isas s1) (isas s2) }

data Symbol
  = Con Concept
  | Rel Relation
    deriving (Eq, Ord, Show, Typeable, Data)

data SymbolKind = ConK | RelK
  deriving (Eq, Ord, Show, Typeable, Data)

sym_kind :: Symbol -> SymbolKind
sym_kind (Con _) = ConK
sym_kind (Rel _) = RelK


instance Pretty SymbolKind where
 pretty ConK = text "concept"
 pretty RelK = text "relation"

instance GetRange Symbol where
  getRange s = case s of
    Rel r -> getRange r
    Con c -> getRange c
  rangeSpan s = case s of
    Rel r -> rangeSpan r
    Con c -> rangeSpan c

instance Pretty Symbol where
  pretty s = case s of
    Rel r -> pretty r
    Con c -> pretty c

conceptToId :: Concept -> Id
conceptToId c = case c of
  C t -> simpleIdToId t
  _ -> stringToId (show c)

symName :: Symbol -> Id
symName s = case s of
  Rel r -> simpleIdToId $ decnm r
  Con c -> conceptToId c

data RawSymbol
  = Symbol Symbol
  | AnId Id
    deriving (Eq, Ord, Show, Typeable, Data)

instance GetRange RawSymbol where
  getRange r = case r of
    Symbol s -> getRange s
    AnId i -> getRange i
  rangeSpan r = case r of
    Symbol s -> rangeSpan s
    AnId i -> rangeSpan i

instance Pretty RawSymbol where
  pretty r = case r of
    Symbol s -> pretty s
    AnId i -> pretty i

symMatch :: Symbol -> RawSymbol -> Bool
symMatch s r = case r of
  Symbol t -> s == t
  AnId i -> symName s == i

symOf :: Sign -> Set.Set Symbol
symOf = Set.unions . map (\ (i, l) ->
          Set.fromList
            . concatMap
              (\ y -> let
                   s = relSrc y
                   t = relTrg y
                   in [Con s, Con t, Rel $ Sgn (idToSimpleId i) y])
            $ Set.toList l)
        . Map.toList . rels

instance GetRange Sign where
  getRange = getRange . symOf
  rangeSpan = rangeSpan . symOf

instance Pretty Sign where
  pretty s =
    vcat (map pretty $ concatMap (\ (i, l) ->
               map (\ t -> Pm [] (Sgn (idToSimpleId i) t) False)
               $ Set.toList l) $ Map.toList $ rels s)
    $+$ vcat (map (\ (c1, c2) -> pretty $ Pg c1 c2)
              . Rel.toList . Rel.transReduce . Rel.transClosure $ isas s)

data Sen
  = DeclProp Relation RangedProp
  | Assertion (Maybe RuleKind) Rule
    deriving (Eq, Ord, Show, Typeable, Data)

instance GetRange Sen where
  getRange s = case s of
    DeclProp _ p -> getRange p
    Assertion _ r -> getRange r
  rangeSpan s = case s of
    DeclProp r p -> joinRanges [rangeSpan r, rangeSpan p]
    Assertion _ r -> rangeSpan r

instance Pretty Sen where
  pretty s = case s of
    DeclProp r p -> pretty $ Pm [p] r False
    Assertion _ r -> pretty $ Pr Always r

printNSen :: Named Sen -> Doc
printNSen ns = let
   s = sentence ns
   n = senAttr ns
   d = pretty s
   in case s of
   Assertion (Just k) r ->
     pretty $ Pr (RuleHeader k $ mkSimpleId n) r
   _ -> d <+> text ("-- " ++ n)