{-# 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)