hets/OWL2/AS.hs

{-# LANGUAGE DeriveDataTypeable #-}
{- |
Module      :  ./OWL2/AS.hs
Copyright   :  (c) C. Maeder, Felix Gabriel Mance
License     :  GPLv2 or higher, see LICENSE.txt

Maintainer  :  Alexander.Koslowski@st.ovgu.de
Stability   :  provisional
Portability :  portable

OWL 2 Functional Syntax constructs

References:
 <http://www.w3.org/TR/2009/REC-owl2-syntax-20091027/#Functional-Style_Syntax>
 <http://www.w3.org/TR/owl2-manchester-syntax/>
-}

module OWL2.AS where

import Common.Id
import Common.Keywords (stringS)
import Common.IRI

import Common.Result

import OWL2.ColonKeywords
import OWL2.Keywords

import Data.Char (intToDigit)
import Data.Data
import Data.List
import Data.Maybe
import qualified Data.Map as Map
import qualified Data.Set as Set

-- | checks if an IRI is an anonymous individual
isAnonymous :: IRI -> Bool
isAnonymous i = prefixName i == "_" && isBlankNode i

-- | prefix -> localname
type PrefixMap = Map.Map String String

predefPrefixes :: PrefixMap
predefPrefixes = Map.fromList
      [ ("owl", "http://www.w3.org/2002/07/owl#")
      , ("rdf", "http://www.w3.org/1999/02/22-rdf-syntax-ns#")
      , ("rdfs", "http://www.w3.org/2000/01/rdf-schema#")
      , ("xsd", "http://www.w3.org/2001/XMLSchema#")
      , ("", showIRICompact dummyIRI ++ "#") ]

type LexicalForm = String
type LanguageTag = String
type ImportIRI = IRI
type OntologyIRI = IRI
type Class = IRI
type Datatype = IRI
type ObjectProperty = IRI
type DataProperty = IRI
type AnnotationProperty = IRI
type Individual = IRI

data EquivOrDisjoint = Equivalent | Disjoint
    deriving (Show, Eq, Ord, Typeable, Data)

showEquivOrDisjoint :: EquivOrDisjoint -> String
showEquivOrDisjoint ed = case ed of
    Equivalent -> equivalentToC
    Disjoint -> disjointWithC

data DomainOrRange = ADomain | ARange
    deriving (Show, Eq, Ord, Typeable, Data)

showDomainOrRange :: DomainOrRange -> String
showDomainOrRange dr = case dr of
    ADomain -> domainC
    ARange -> rangeC

data SameOrDifferent = Same | Different
    deriving (Show, Eq, Ord, Typeable, Data)

showSameOrDifferent :: SameOrDifferent -> String
showSameOrDifferent sd = case sd of
    Same -> sameAsC
    Different -> differentFromC

data Relation =
    EDRelation EquivOrDisjoint
  | SubPropertyOf
  | InverseOf
  | SubClass
  | Types
  | DRRelation DomainOrRange
  | SDRelation SameOrDifferent
    deriving (Show, Eq, Ord, Typeable, Data)

showRelation :: Relation -> String
showRelation r = case r of
    EDRelation ed -> showEquivOrDisjoint ed
    SubPropertyOf -> subPropertyOfC
    InverseOf -> inverseOfC
    SubClass -> subClassOfC
    Types -> typesC
    DRRelation dr -> showDomainOrRange dr
    SDRelation sd -> showSameOrDifferent sd

getED :: Relation -> EquivOrDisjoint
getED r = case r of
    EDRelation ed -> ed
    _ -> error "not domain or range"

getDR :: Relation -> DomainOrRange
getDR r = case r of
    DRRelation dr -> dr
    _ -> error "not domain or range"

getSD :: Relation -> SameOrDifferent
getSD s = case s of
    SDRelation sd -> sd
    _ -> error "not same or different"

data Character =
    Functional
  | InverseFunctional
  | Reflexive
  | Irreflexive
  | Symmetric
  | Asymmetric
  | Antisymmetric
  | Transitive
    deriving (Enum, Bounded, Show, Eq, Ord, Typeable, Data)

data PositiveOrNegative = Positive | Negative
    deriving (Show, Eq, Ord, Typeable, Data)

data QuantifierType = AllValuesFrom | SomeValuesFrom
    deriving (Show, Eq, Ord, Typeable, Data)

showQuantifierType :: QuantifierType -> String
showQuantifierType ty = case ty of
    AllValuesFrom -> onlyS
    SomeValuesFrom -> someS

-- * Predefined IRI checkings

thingMap :: PreDefMaps
thingMap = makeOWLPredefMaps predefClass

isThing :: IRI -> Bool
isThing = checkPredef thingMap

makePredefObjProp :: PreDefMaps
makePredefObjProp = makeOWLPredefMaps predefObjProp

isPredefObjProp :: IRI -> Bool
isPredefObjProp = checkPredef makePredefObjProp

makePredefDataProp :: PreDefMaps
makePredefDataProp = makeOWLPredefMaps predefDataProp

isPredefDataProp :: IRI -> Bool
isPredefDataProp = checkPredef makePredefDataProp

makePredefRDFSAnnoProp :: PreDefMaps
makePredefRDFSAnnoProp = preDefMaps predefRDFSAnnoProps "rdfs"

isPredefRDFSAnnoProp :: IRI -> Bool
isPredefRDFSAnnoProp = checkPredef makePredefRDFSAnnoProp

makePredefOWLAnnoProp :: PreDefMaps
makePredefOWLAnnoProp = makeOWLPredefMaps predefOWLAnnoProps

isPredefOWLAnnoProp :: IRI -> Bool
isPredefOWLAnnoProp = checkPredef makePredefOWLAnnoProp

isPredefAnnoProp :: IRI -> Bool
isPredefAnnoProp i = isPredefOWLAnnoProp i || isPredefRDFSAnnoProp i

isPredefPropOrClass :: IRI -> Bool
isPredefPropOrClass i = isPredefAnnoProp i || isPredefDataProp i
    || isPredefObjProp i || isThing i

predefIRIs :: Set.Set IRI
predefIRIs = Set.fromList $ map (setPrefix "xsd" . mkIRI) xsdKeys
    ++ map (setPrefix "owl" . mkIRI) owlNumbers
    ++ map (setPrefix "rdf" . mkIRI) [rdfsLiteral, stringS]
    ++ [setPrefix "rdfs" $ mkIRI xmlLiteral]

isDatatypeKey :: IRI -> Bool
isDatatypeKey = not . null . isDatatypeKeyAux

xsdMap :: PreDefMaps
xsdMap = makeXsdMap xsdKeys

owlNumbersMap :: PreDefMaps
owlNumbersMap = makeOWLPredefMaps owlNumbers

rdfMap :: PreDefMaps
rdfMap = preDefMaps [xmlLiteral, stringS] "rdf"

rdfsMap :: PreDefMaps
rdfsMap = preDefMaps [rdfsLiteral] "rdfs"

isDatatypeKeyAux :: IRI -> [(String, String)]
isDatatypeKeyAux i = mapMaybe (`checkPredefAux` i)
  [ xsdMap, owlNumbersMap, rdfMap, rdfsMap ]

type PreDefMaps = ([String], String, String)

preDefMaps :: [String] -> String -> PreDefMaps
preDefMaps sl pref = let
  Just puri = Map.lookup pref predefPrefixes
  Just sp = stripPrefix "http://www.w3.org/" puri
 in (sl, pref, sp)

checkPredefAux :: PreDefMaps -> IRI -> Maybe (String, String)
checkPredefAux (sl, pref, exPref) u =
  let lp = show $ iriPath u
      res = Just (pref, lp)
  in case prefixName u of
    "http" -> case stripPrefix "//www." lp of
        Just q -> case stripPrefix "w3.org/" q of
            Just r -> case stripPrefix exPref r of
              Just s | elem s sl -> Just (pref, s)
              _ -> Nothing
            Nothing -> Nothing
        Nothing -> Nothing
    pu | elem lp sl -> case pu of
      "" -> let ex = iriToStringUnsecure u in
            case stripPrefix "http://www." ex of
              Just r | r == "w3.org/" ++ exPref ++ lp -- || r == lp
                  -> res
              _ | null ex -> res
              _ -> Nothing
      _ | pref == pu || pref ++ ":" == pu -> Just (pref, lp)
      _ -> Nothing
    _ -> Nothing


checkPredef :: PreDefMaps -> IRI -> Bool
checkPredef ms = isJust . checkPredefAux ms

makeOWLPredefMaps :: [String] -> PreDefMaps
makeOWLPredefMaps sl = preDefMaps sl "owl"

-- | sets the correct prefix for the predefined datatypes
setDatatypePrefix :: IRI -> IRI
setDatatypePrefix i = case isDatatypeKeyAux i of
  (p, l) : _ -> setPrefix p $ mkIRI l
  _ -> error $ showIRICompact i ++ " is not a predefined datatype"

-- | checks if the IRI is part of the built-in ones and puts the correct prefix
setReservedPrefix :: IRI -> IRI
setReservedPrefix i = case prefixName i of
  ""
    | isDatatypeKey i -> setDatatypePrefix i
    | isThing i || isPredefDataProp i || isPredefOWLAnnoProp i
        || isPredefObjProp i -> setPrefix "owl" i
    | isPredefRDFSAnnoProp i -> setPrefix "rdfs" i
  _ -> i

stripReservedPrefix :: IRI -> IRI
stripReservedPrefix = idToIRI . uriToId

{- | Extracts Id from IRI
     returns the name of the predefined IRI (e.g <xsd:string> returns "string"
     or <http://www.w3.org/2002/07/owl#real> returns "real") -}
uriToId :: IRI -> Id
uriToId i =
    if (prefixName i `elem` ["", "xsd", "rdf", "rdfs", "owl"])
       || (   null (iriScheme i)
           && null (iriQuery i)
           && null (iriFragment i)
           && isNothing (iriAuthority i))
        then iriPath i
        else stringToId $ case mapMaybe (`stripPrefix` showIRICompact i)
                    $ Map.elems predefPrefixes of
                [s] -> s
                _ -> showIRIFull i

getPredefName :: IRI -> String
getPredefName = show . uriToId

-- | Extracts Token from IRI
uriToTok :: IRI -> Token
uriToTok = mkSimpleId . show . getPredefName

-- | Extracts Id from Entities
entityToId :: Entity -> Id
entityToId = uriToId . cutIRI

printDatatype :: IRI -> String
printDatatype dt = showIRICompact $
    if isDatatypeKey dt then stripReservedPrefix dt else dt

data DatatypeCat = OWL2Number | OWL2String | OWL2Bool | Other
    deriving (Show, Eq, Ord, Typeable, Data)

getDatatypeCat :: IRI -> DatatypeCat
getDatatypeCat i = case isDatatypeKey i of
    True
        | checkPredef xsdBooleanMap i -> OWL2Bool
        | checkPredef xsdNumbersMap i || checkPredef owlNumbersMap i
            -> OWL2Number
        | checkPredef xsdStringsMap i -> OWL2String
        | otherwise -> Other
    False -> Other

makeXsdMap :: [String] -> PreDefMaps
makeXsdMap sl = preDefMaps sl "xsd"

xsdBooleanMap :: PreDefMaps
xsdBooleanMap = makeXsdMap [booleanS]

xsdNumbersMap :: PreDefMaps
xsdNumbersMap = makeXsdMap xsdNumbers

xsdStringsMap :: PreDefMaps
xsdStringsMap = makeXsdMap xsdStrings

facetToIRI :: DatatypeFacet -> ConstrainingFacet
facetToIRI = setPrefix "xsd" . mkIRI . showFacet

-- * Cardinalities

data CardinalityType = MinCardinality | MaxCardinality | ExactCardinality
    deriving (Show, Eq, Ord, Typeable, Data)

showCardinalityType :: CardinalityType -> String
showCardinalityType ty = case ty of
    MinCardinality -> minS
    MaxCardinality -> maxS
    ExactCardinality -> exactlyS

data Cardinality a b = Cardinality CardinalityType Int a (Maybe b)
    deriving (Show, Eq, Ord, Typeable, Data)

data JunctionType = UnionOf | IntersectionOf
    deriving (Show, Eq, Ord, Typeable, Data)

type ConstrainingFacet = IRI
type RestrictionValue = Literal

-- * ENTITIES

data Entity = Entity
  { label :: Maybe String
  , entityKind :: EntityType
  , cutIRI :: IRI }
  deriving (Show, Typeable, Data)

mkEntity :: EntityType -> IRI -> Entity
mkEntity = Entity Nothing

mkEntityLbl :: String -> EntityType -> IRI -> Entity
mkEntityLbl = Entity . Just

instance Ord Entity where
  compare (Entity _ ek1 ir1) (Entity _ ek2 ir2) = compare (ek1, ir1) (ek2, ir2)

instance Eq Entity where
  e1 == e2 = compare e1 e2 == EQ

instance GetRange Entity where
  getRange = iriPos . cutIRI
  rangeSpan = iRIRange . cutIRI

data EntityType =
    Datatype
  | Class
  | ObjectProperty
  | DataProperty
  | AnnotationProperty
  | NamedIndividual
    deriving (Enum, Bounded, Show, Read, Eq, Ord, Typeable, Data)

showEntityType :: EntityType -> String
showEntityType e = case e of
    Datatype -> datatypeC
    Class -> classC
    ObjectProperty -> objectPropertyC
    DataProperty -> dataPropertyC
    AnnotationProperty -> annotationPropertyC
    NamedIndividual -> individualC

entityTypes :: [EntityType]
entityTypes = [minBound .. maxBound]

pairSymbols :: Entity -> Entity -> Result Entity -- TODO: improve!
pairSymbols (Entity lb1 k1 i1) (Entity lb2 k2 i2) =
  if k1 /= k2 then
    error "can't pair symbols of different kind"
   else do
    let rest x = drop 1 $ dropWhile (/= '#') x
        pairLables lbl1 lbl2 = case (lbl1, lbl2) of
            (Nothing, _) -> pairLables lbl2 lbl1
            (Just l1, Just l2) | l1 /= l2 -> Just $ l1 ++ ", " ++ l2
            _ -> lbl1
        pairIRIs iri1 iri2 = nullIRI
          { prefixName = prefixName iri1
          , iriPath = if rest (show $ iriPath iri1) ==
                            rest (show $ iriPath iri2)
                          then iriPath iri1
                          else appendId (iriPath iri1) (iriPath iri2)
          } -- TODO: improve, see #1597
    return $ Entity (pairLables lb1 lb2) k1 $ pairIRIs i1 i2

-- * LITERALS

data TypedOrUntyped = Typed Datatype | Untyped (Maybe LanguageTag)
    deriving (Show, Eq, Ord, Typeable, Data)

data Literal = Literal LexicalForm TypedOrUntyped | NumberLit FloatLit
    deriving (Show, Eq, Ord, Typeable, Data)

-- | non-negative integers given by the sequence of digits
data NNInt = NNInt [Int] deriving (Eq, Ord, Typeable, Data)

instance Show NNInt where
  show (NNInt l) = map intToDigit l

zeroNNInt :: NNInt
zeroNNInt = NNInt []

isZeroNNInt :: NNInt -> Bool
isZeroNNInt (NNInt l) = null l

data IntLit = IntLit
  { absInt :: NNInt
  , isNegInt :: Bool }
  deriving (Eq, Ord, Typeable, Data)

instance Show IntLit where
  show (IntLit n b) = (if b then ('-' :) else id) $ show n

zeroInt :: IntLit
zeroInt = IntLit zeroNNInt False

isZeroInt :: IntLit -> Bool
isZeroInt (IntLit n _) = isZeroNNInt n

negNNInt :: Bool -> NNInt -> IntLit
negNNInt b n = IntLit n b

negInt :: IntLit -> IntLit
negInt (IntLit n b) = IntLit n $ not b

data DecLit = DecLit
  { truncDec :: IntLit
  , fracDec :: NNInt }
  deriving (Eq, Ord, Typeable, Data)

instance Show DecLit where
  show (DecLit t f) = show t
    ++ if isZeroNNInt f then "" else
      '.' : show f

isDecInt :: DecLit -> Bool
isDecInt = isZeroNNInt . fracDec

negDec :: Bool -> DecLit -> DecLit
negDec b (DecLit t f) = DecLit (if b then negInt t else t) f

data FloatLit = FloatLit
  { floatBase :: DecLit
  , floatExp :: IntLit }
  deriving (Eq, Ord, Typeable, Data)

instance Show FloatLit where
  show (FloatLit b e) = show b
    ++ if isZeroInt e then "" else
      'E' : show e ++ "F"

isFloatDec :: FloatLit -> Bool
isFloatDec = isZeroInt . floatExp

isFloatInt :: FloatLit -> Bool
isFloatInt f = isFloatDec f && isDecInt (floatBase f)

floatToInt :: FloatLit -> IntLit
floatToInt = truncDec . floatBase

intToDec :: IntLit -> DecLit
intToDec i = DecLit i zeroNNInt

decToFloat :: DecLit -> FloatLit
decToFloat d = FloatLit d zeroInt

intToFloat :: IntLit -> FloatLit
intToFloat = decToFloat . intToDec

abInt :: IntLit -> IntLit
abInt int = int {isNegInt = False}

abDec :: DecLit -> DecLit
abDec dec = dec {truncDec = abInt $ truncDec dec}

abFloat :: FloatLit -> FloatLit
abFloat f = f {floatBase = abDec $ floatBase f}

isNegDec :: DecLit -> Bool
isNegDec d = isNegInt $ truncDec d

numberName :: FloatLit -> String
numberName f
    | isFloatInt f = integerS
    | isFloatDec f = decimalS
    | otherwise = floatS

cTypeS :: String
cTypeS = "^^"

-- * PROPERTY EXPRESSIONS

type InverseObjectProperty = ObjectPropertyExpression

data ObjectPropertyExpression = ObjectProp ObjectProperty
  | ObjectInverseOf InverseObjectProperty
        deriving (Show, Eq, Ord, Typeable, Data)

objPropToIRI :: ObjectPropertyExpression -> Individual
objPropToIRI opExp = case opExp of
    ObjectProp u -> u
    ObjectInverseOf objProp -> objPropToIRI objProp

type DataPropertyExpression = DataProperty

-- * DATA RANGES

data DataRange =
    DataType Datatype [(ConstrainingFacet, RestrictionValue)]
  | DataJunction JunctionType [DataRange]
  | DataComplementOf DataRange
  | DataOneOf [Literal]
    deriving (Show, Eq, Ord, Typeable, Data)

-- * CLASS EXPERSSIONS

data ClassExpression =
    Expression Class
  | ObjectJunction JunctionType [ClassExpression]
  | ObjectComplementOf ClassExpression
  | ObjectOneOf [Individual]
  | ObjectValuesFrom QuantifierType ObjectPropertyExpression ClassExpression
  | ObjectHasValue ObjectPropertyExpression Individual
  | ObjectHasSelf ObjectPropertyExpression
  | ObjectCardinality (Cardinality ObjectPropertyExpression ClassExpression)
  | DataValuesFrom QuantifierType DataPropertyExpression DataRange
  | DataHasValue DataPropertyExpression Literal
  | DataCardinality (Cardinality DataPropertyExpression DataRange)
    deriving (Show, Eq, Ord, Typeable, Data)

-- * ANNOTATIONS

data Annotation = Annotation [Annotation] AnnotationProperty AnnotationValue
    deriving (Show, Eq, Ord, Typeable, Data)

data AnnotationValue = AnnValue IRI | AnnValLit Literal
    deriving (Show, Eq, Ord, Typeable, Data)