diff --git a/src/Data/Interned/URI.hs b/src/Data/Interned/URI.hs --- a/src/Data/Interned/URI.hs +++ b/src/Data/Interned/URI.hs @@ -1,16 +1,18 @@ -{-# LANGUAGE TypeFamilies, FlexibleInstances #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE FlexibleInstances #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : URI --- Copyright : (c) 2011 Douglas Burke +-- Copyright : (c) 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : TypeFamilies, FlexibleInstances +-- Portability : CPP, TypeFamilies, FlexibleInstances -- -- Support interning URIs. -- @@ -27,7 +29,10 @@ import Network.URI --- Could look at adding UNPACK statements before each component +-- Could look at adding UNPACK statements before the Int component + +-- | An interned URI. The hashing is based on the +-- reversed URI (as a string). data InternedURI = InternedURI !Int !URI instance IsString InternedURI where @@ -50,7 +55,10 @@ data Description InternedURI = DU !URI deriving (Eq) -- DU {-# UNPACK #-} !URI deriving (Eq) describe = DU identify = InternedURI +#if MIN_VERSION_intern(0,9,0) +#else identity (InternedURI i _) = i +#endif cache = iuCache instance Uninternable InternedURI where @@ -68,7 +76,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Data/LookupMap.hs b/src/Data/LookupMap.hs new file mode 100644 --- /dev/null +++ b/src/Data/LookupMap.hs @@ -0,0 +1,368 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : LookupMap +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : A lot of LANGUAGE extensions... +-- +-- This module defines a lookup table format and associated functions +-- used by the graph matching code. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Generic list-of-pairs lookup functions +------------------------------------------------------------ + +module Data.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , emptyLookupMap, makeLookupMap, listLookupMap + , reverseLookupMap + , keyOrder + , mapFind, mapFindMaybe, mapContains + , mapReplace, mapReplaceAll, mapReplaceMap + , mapAdd, mapAddIfNew + , mapDelete, mapDeleteAll + , mapEq, mapKeys, mapVals + , mapMerge + ) + where + +import Control.Arrow (first, second) + +import Data.Maybe (fromMaybe) +import Data.Function (on) +import Data.Ord (comparing) + +import Swish.Utils.ListHelpers (equiv) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Data.List as L + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) +import Data.Tuple (swap) +#else +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) +#endif + +------------------------------------------------------------ +-- Class for lookup map entries +------------------------------------------------------------ + +-- |@LookupEntryClass@ defines essential functions of any datatype +-- that can be used to make a 'LookupMap'. +-- +-- Minimal definition: @newEntry@ and @keyVal@ +-- +class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v + where + newEntry :: (k,v) -> a + keyVal :: a -> (k,v) + + entryKey :: a -> k + entryKey = fst . keyVal + + entryVal :: a -> v + entryVal = snd . keyVal + + entryEq :: (Eq v) => a -> a -> Bool + entryEq e1 e2 = keyVal e1 == keyVal e2 + + entryShow :: (Show v) => a -> String + entryShow e = show k ++ ":" ++ show v where (k,v) = keyVal e + + kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2 + kmap f = newEntry . first f . keyVal + + vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2 + vmap f = newEntry . second f . keyVal + +-- |Predefine a pair of appropriate values as a valid lookup table entry +-- (i.e. an instance of LookupEntryClass). +-- +instance (Eq k, Show k) => LookupEntryClass (k,v) k v where + newEntry = id + keyVal = id + +-- Note: the class constraint that a is an instance of 'LookupEntryClass' +-- is not defined here, for good reasons (which I forget right now, but +-- something to do with the method dictionary being superfluous on +-- an algebraic data type). + +-- |Define a lookup map based on a list of values. +-- +data LookupMap a = LookupMap [a] + deriving (Functor, F.Foldable, T.Traversable) + +{- + +To allow this Monoid instance, we would need UndecidableInstances. +Also, mapMerge can error out which is not what we would want. + +instance (LookupEntryClass a k v, Eq a, Show a, Ord k) => Monoid (LookupMap a) where + mempty = LookupMap [] + mappend = mapMerge + +We could use the following (perhaps with a L.nub on the result before sticling back +into LookupMap) but it is unclear what the semantics are for repeated keys; it is +likely to be left-biased but would leave duplicate keys in the list which could +cause confusion at a later time (e.g. key removal). Many of the routines assume a single +key (or single key,value) pair. + +instance (Eq a) => Monoid (LookupMap a) where + mempty = LookupMap [] + (LookupMap a) `mappend` (LookupMap b) = + LookupMap (a `mappend` b)) +-} + +gLM :: LookupMap a -> [a] +gLM (LookupMap es) = es + +-- |Define equality of 'LookupMap' values based on equality of entries. +-- +-- (This is possibly a poor definition, as it is dependent on ordering +-- of list members. But it passes all current test cases, and is used +-- only for testing.) +-- +instance (Eq a) => Eq (LookupMap a) where + (==) = (==) `on` gLM + +-- |Define Show instance for LookupMap based on Showing the +-- list of entries. +-- +instance (Show a ) => Show (LookupMap a) where + show (LookupMap es) = "LookupMap " ++ show es + +-- |Empty lookup map of arbitrary (i.e. polymorphic) type. +-- +emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a +emptyLookupMap = LookupMap [] + +-- |Function to create a `LookupMap` from a list of entries. +-- +makeLookupMap :: + (LookupEntryClass a k v) + => [a] -- ^ This list is not checked for duplicate entries, or + -- entries with the same key but different values. + -> LookupMap a +makeLookupMap = LookupMap + +-- |Returns a list of lookup map entries. +-- +listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a] +listLookupMap = gLM + +-- |Given a lookup map entry, return a new entry that can be used +-- in the reverse direction of lookup. This is used to construct +-- a reverse LookupMap. +-- +reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k) + => a1 -> a2 +reverseEntry = newEntry . swap . keyVal + +-- |Given a lookup map, return a new map that can be used +-- in the opposite direction of lookup. +-- +reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b) + => LookupMap a1 -> LookupMap a2 +reverseLookupMap = fmap reverseEntry + +-- |Given a pair of lookup entry values, return the ordering of their +-- key values. +-- +keyOrder :: (LookupEntryClass a k v, Ord k) + => a -> a -> Ordering +keyOrder = comparing entryKey + +-- |Find key in lookup map and return corresponding value, +-- otherwise return default supplied. +-- +mapFind :: + (LookupEntryClass a k v) + => v -- ^ The default value. + -> k + -> LookupMap a -> v +mapFind def key = fromMaybe def . mapFindMaybe key + +-- |Find key in lookup map and return Just the corresponding value, +-- otherwise return Nothing. +-- +mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v +mapFindMaybe key (LookupMap es) = foldr match Nothing es where + match ent alt + | key == entryKey ent = Just (entryVal ent) + | otherwise = alt + +-- |Test to see if key is present in the supplied map +-- +mapContains :: (LookupEntryClass a k v) => + LookupMap a -> k -> Bool +mapContains (LookupMap es) key = any match es where + match ent = key == entryKey ent + +-- |Replace the first occurrence of a key a with a new key-value pair, +-- or add a new key-value pair if the supplied key is not already present. +-- +mapReplace :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapReplace (LookupMap []) newe = LookupMap [newe] +mapReplace (LookupMap (e:es)) newe + | entryKey e == entryKey newe = LookupMap (newe:es) + | otherwise = mapAdd more e where + more = mapReplace (LookupMap es) newe + +-- |Replace all occurrence of a key a with a new key-value pair. +-- +-- The resulting lookup map has the same form as the original in all +-- other respects. +-- +mapReplaceAll :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapReplaceAll l@(LookupMap []) _ = l +mapReplaceAll (LookupMap (e:es)) newe = mapAdd more e' where + more = mapReplaceAll (LookupMap es) newe + e' = if entryKey e == entryKey newe then newe else e + +-- |Replace any occurrence of a key in the first argument with a +-- corresponding key-value pair from the second argument, if present. +-- +-- This could be implemented by multiple applications of 'mapReplaceAll', +-- but is arranged differently so that only one new @LookupMap@ value is +-- created. +-- +-- Note: keys in the new map that are not present in the old map +-- are not included in the result map +-- +mapReplaceMap :: (LookupEntryClass a k v) => + LookupMap a -> LookupMap a -> LookupMap a +mapReplaceMap l@(LookupMap []) _ = l +mapReplaceMap (LookupMap (e:es)) newmap = mapAdd more e' where + more = mapReplaceMap (LookupMap es) newmap + e' = newEntry (k, mapFind v k newmap) + (k,v) = keyVal e + +-- |Add supplied key-value pair to the lookup map. +-- +-- This is effectively an optimized case of 'mapReplace' or 'mapAddIfNew', +-- where the caller guarantees to avoid duplicate key values. +-- +mapAdd :: LookupMap a -> a -> LookupMap a +mapAdd (LookupMap es) e = LookupMap (e:es) + +-- |Add supplied key-value pair to the lookup map, +-- only if the key value is not already present. +-- +mapAddIfNew :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapAddIfNew emap e = if mapContains emap (entryKey e) + then emap + else mapAdd emap e + +-- |Delete the first occurrence of the key from the lookup map. +-- +-- If the key does not exist in the map then no change is made. +-- +mapDelete :: (LookupEntryClass a k v) => + LookupMap a -> k -> LookupMap a +mapDelete l@(LookupMap []) _ = l +mapDelete (LookupMap (e:es)) k + | k == entryKey e = LookupMap es + | otherwise = mapAdd more e where + more = mapDelete (LookupMap es) k + +-- |Delete all occurrences of the key from the lookup map. +-- +mapDeleteAll :: (LookupEntryClass a k v) => + LookupMap a -> k -> LookupMap a +mapDeleteAll l@(LookupMap []) _ = l +mapDeleteAll (LookupMap (e:es)) k = + let more = mapDeleteAll (LookupMap es) k + in if entryKey e == k then more else mapAdd more e + +-- |Compare two lookup maps for equality. +-- +-- Two maps are equal if they have the same set of keys, and if +-- each key maps to an equivalent value. This is only guaranteed +-- if the maps do not contain duplicate entries. +-- +mapEq :: (LookupEntryClass a k v, Eq v) => + LookupMap a -> LookupMap a -> Bool +mapEq es1 es2 = + ks1 `equiv` ks2 && + and [ mapFindMaybe k es1 == mapFindMaybe k es2 | k <- ks1 ] + where + ks1 = mapKeys es1 + ks2 = mapKeys es2 + +-- |Return the list of distinct keys in a supplied LookupMap +-- +mapKeys :: (LookupEntryClass a k v) => + LookupMap a -> [k] +mapKeys = L.nub . gLM . fmap entryKey + +-- |Return list of distinct values in a supplied LookupMap +-- +mapVals :: (Eq v, LookupEntryClass a k v) => + LookupMap a -> [v] +mapVals = L.nub . gLM . fmap entryVal + +-- |Merge two lookup maps, ensuring that if the same key appears +-- in both maps it is associated with the same value. +-- +mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) => + LookupMap a -> LookupMap a -> LookupMap a +mapMerge a b = LookupMap $ on merge (L.sortBy keyOrder . gLM) a b + where + merge es1 [] = es1 + merge [] es2 = es2 + merge es1@(e1:et1) es2@(e2:et2) = + case keyOrder e1 e2 of + LT -> e1 : merge et1 es2 + GT -> e2 : merge es1 et2 + EQ -> if e1 /= e2 + then error ("mapMerge key conflict: " ++ show e1 + ++ " with " ++ show e2) + else e1 : merge et1 et2 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Data/Ord/Partial.hs b/src/Data/Ord/Partial.hs new file mode 100644 --- /dev/null +++ b/src/Data/Ord/Partial.hs @@ -0,0 +1,367 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Partial +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module provides methods to support operations on partially ordered +-- collections. The partial ordering relationship is represented by +-- 'Maybe' 'Ordering'. +-- +-- Thanks to members of the haskell-cafe mailing list - +-- Robert (rvollmert-lists\@gmx.net) and +-- Tom Pledger (Tom.Pledger\@peace.com) - +-- who suggested key ideas on which some of the code in this module is based. +-- +-------------------------------------------------------------------------------- + +-- at present the only user of this module is Swish.RDF.ClassRestrictionRule + +module Data.Ord.Partial + ( PartCompare + -- * Finding the range of a part-ordered list + , minima + , maxima + -- * Comparing part-ordered containers + , partCompareEq + , partComparePair + , partCompareListMaybe + , partCompareListSubset + ) + where + +import Data.List (foldl') + +------------------------------------------------------------ +-- Type of partial compare function +------------------------------------------------------------ + +-- | Partial comparison function. +type PartCompare a = a -> a -> Maybe Ordering + +------------------------------------------------------------ +-- Functions for minima and maxima of a part-ordered list +------------------------------------------------------------ + +-- |This function finds the maxima in a list of partially +-- ordered values, preserving the sequence of retained +-- values from the supplied list. +-- +-- It returns all those values in the supplied list +-- for which there is no larger element in the list. +-- +maxima :: PartCompare a -> [a] -> [a] +maxima cmp = foldl' add [] + where + add [] e = [e] + add ms@(m:mr) e = case cmp m e of + Nothing -> m : add mr e + Just GT -> ms + Just EQ -> ms + Just LT -> add mr e + +-- |This function finds the minima in a list of partially +-- ordered values, preserving the sequence of retained +-- values from the supplied list. +-- +-- It returns all those values in the supplied list +-- for which there is no smaller element in the list. +-- +minima :: PartCompare a -> [a] -> [a] +minima cmp = maxima (flip cmp) + +------------------------------------------------------------ +-- Partial ordering comparison functions +------------------------------------------------------------ + +-- |Partial ordering for Eq values +partCompareEq :: (Eq a) => PartCompare a +partCompareEq a1 a2 = if a1 == a2 then Just EQ else Nothing + +-- |Part-ordering comparison on pairs of values, +-- where each has a part-ordering relationship +partComparePair :: + PartCompare a + -> PartCompare b + -> (a,b) + -> (a,b) + -> Maybe Ordering +partComparePair cmpa cmpb (a1,b1) (a2,b2) = case (cmpa a1 a2,cmpb b1 b2) of + (_,Nothing) -> Nothing + (jc1,Just EQ) -> jc1 + (Nothing,_) -> Nothing + (Just EQ,jc2) -> jc2 + (Just c1,Just c2) -> if c1 == c2 then Just c1 else Nothing + +-- |Part-ordering comparison on lists of partially ordered values, where: +-- +-- [@as==bs@] if members of as are all equal to corresponding members of bs +-- +-- [@as<=bs@] if members of as are all less than or equal to corresponding +-- members of bs +-- +-- [@as>=bs@] if members of as are all greater than or equal to corresponding +-- members of bs +-- +-- [otherwise] as and bs are unrelated +-- +-- The comparison is restricted to the common elements in the two lists. +-- +partCompareListPartOrd :: PartCompare a -> [a] -> [a] -> Maybe Ordering +partCompareListPartOrd cmp a1s b1s = pcomp a1s b1s EQ + where + pcomp (a:as) (b:bs) ordp = case cmp a b of + Just rel -> pcomp1 as bs rel ordp + _ -> Nothing + pcomp _ _ ordp = Just ordp + -- pcomp [] [] ordp = Just ordp + + pcomp1 as bs ordn EQ = pcomp as bs ordn + pcomp1 as bs EQ ordp = pcomp as bs ordp + pcomp1 as bs ordn ordp = + if ordn == ordp then pcomp as bs ordp else Nothing + +-- |Part-ordering comparison for Maybe values. +partCompareMaybe :: (Eq a) => Maybe a -> Maybe a -> Maybe Ordering +partCompareMaybe Nothing Nothing = Just EQ +partCompareMaybe (Just _) Nothing = Just GT +partCompareMaybe Nothing (Just _) = Just LT +partCompareMaybe (Just a) (Just b) = if a == b then Just EQ else Nothing + +-- |Part-ordering comparison on lists of Maybe values. +partCompareListMaybe :: (Eq a) => [Maybe a] -> [Maybe a] -> Maybe Ordering +partCompareListMaybe = partCompareListPartOrd partCompareMaybe + +-- |Part-ordering comparison on lists based on subset relationship +partCompareListSubset :: (Eq a) => [a] -> [a] -> Maybe Ordering +partCompareListSubset a b + | aeqvb = Just EQ + | asubb = Just LT + | bsuba = Just GT + | otherwise = Nothing + where + asubb = a `subset` b + bsuba = b `subset` a + aeqvb = asubb && bsuba + x `subset` y = and [ ma `elem` y | ma <- x ] + +------------------------------------------------------------ +-- Test cases +------------------------------------------------------------ + +{- + +notTrueFalse = Nothing :: Maybe Bool + +-- partCompareListOrd +test01 = partCompareListOrd [1,2,3] [1,2,3] == Just EQ +test02 = partCompareListOrd [1,2,3] [2,3,4] == Just LT +test03 = partCompareListOrd [1,2,4] [1,2,3] == Just GT +test04 = partCompareListOrd [1,2,3] [2,1,3] == Nothing + +-- partCompareMaybe +test11 = partCompareMaybe (Just True) (Just True) == Just EQ +test12 = partCompareMaybe (Just True) (Just False) == Nothing +test13 = partCompareMaybe notTrueFalse (Just False) == Just LT +test14 = partCompareMaybe (Just True) notTrueFalse == Just GT +test15 = partCompareMaybe notTrueFalse notTrueFalse == Just EQ + +-- partCompareListMaybe +test21 = partCompareListMaybe [Just True,Just False] + [Just True,Just False] + == Just EQ +test22 = partCompareListMaybe [Just True,Just False] + [Just True,Just True] + == Nothing +test23 = partCompareListMaybe [Just False,Just True] + [Just False,Just True] + == Just EQ +test24 = partCompareListMaybe [Nothing, Just True] + [Just False,Just True] + == Just LT +test25 = partCompareListMaybe [Just False,Just True] + [Just False,Nothing] + == Just GT +test26 = partCompareListMaybe [Nothing, Just True] + [Just False,Nothing] + == Nothing +test27 = partCompareListMaybe [Nothing,Just True] + [Nothing,Nothing] + == Just GT +test28 = partCompareListMaybe [notTrueFalse,notTrueFalse] + [notTrueFalse,notTrueFalse] + == Just EQ + +-- minima, maxima +test31a = maxima partCompareListMaybe ds1a == ds1b +test31b = minima partCompareListMaybe ds1a == ds1c +ds1a = + [ [Just 'a',Just 'b',Just 'c'] + , [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Nothing ,Nothing ] + ] +ds1b = + [ [Just 'a',Just 'b',Just 'c'] + ] +ds1c = + [ [Nothing ,Nothing ,Nothing ] + ] + +test32a = maxima partCompareListMaybe ds2a == ds2b +test32b = minima partCompareListMaybe ds2a == ds2c +ds2a = + [ [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + ] +ds2b = + [ [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Nothing ,Just 'b',Just 'c'] + ] +ds2c = + [ [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + ] + +test33a = maxima partCompareListMaybe ds3a == ds3b +test33b = minima partCompareListMaybe ds3a == ds3c +ds3a = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] +ds3b = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] +ds3c = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] + + +test34a = maxima partCompareListMaybe ds4a == ds4b +test34b = minima partCompareListMaybe ds4a == ds4c +ds4a = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + ] +ds4b = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + ] +ds4c = + [ [Nothing,Nothing] + ] + +-- Check handling of equal values +test35a = maxima partCompareListMaybe ds5a == ds5b +test35b = minima partCompareListMaybe ds5a == ds5c +ds5a = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + , [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + ] +ds5b = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + ] +ds5c = + [ [Nothing,Nothing] + ] + +-- test case 32 with different ordering of values +test36a = maxima partCompareListMaybe ds6a == ds6b +test36b = minima partCompareListMaybe ds6a == ds6c +ds6a = + [ [Just 'a',Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Just 'a',Nothing ,Just 'c'] + ] +ds6b = + [ [Just 'a',Just 'b',Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Just 'a',Nothing ,Just 'c'] + ] +ds6c = + [ [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Just 'a',Nothing ,Nothing ] + ] + +test = and + [ test01, test02, test03, test04 + , test11, test12, test13, test14, test15 + , test21, test22, test23, test24, test25, test26, test27, test28 + , test31a, test31b, test32a, test32b, test33a, test33b + , test34a, test34b, test35a, test35b, test36a, test36b + ] + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Data/String/ShowLines.hs b/src/Data/String/ShowLines.hs new file mode 100644 --- /dev/null +++ b/src/Data/String/ShowLines.hs @@ -0,0 +1,73 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : ShowLines +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines an extension of the 'Show' class for displaying +-- multi-line values. It serves the following purposes: +-- +-- (1) provides a method with greater layout control of multiline values, +-- +-- (2) provides a possibility to override the default 'Show' behaviour +-- for programs that use the extended 'ShowLines' interface, and +-- +-- (3) uses a 'ShowS' intermediate value to avoid unnecessary +-- concatenation of long strings. +-- +-------------------------------------------------------------------------------- + +module Data.String.ShowLines (ShowLines(..)) where + +-- |ShowLines is a type class for values that may be formatted in +-- multi-line displays. +class (Show sh) => ShowLines sh where + -- |Multi-line value display method + -- + -- Create a multiline displayable form of a value, returned + -- as a 'ShowS' value. The default implementation behaves just + -- like a normal instance of 'Show'. + -- + -- This function is intended to allow the calling function some control + -- of multiline displays by providing: + -- + -- (1) the first line of the value is not preceded by any text, so + -- it may be appended to some preceding text on the same line, + -- + -- (2) the supplied line break string is used to separate lines of the + -- formatted text, and may include any desired indentation, and + -- + -- (3) no newline is output following the final line of text. + showls :: String -> sh -> ShowS + showls _ = shows + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish.hs b/src/Swish.hs --- a/src/Swish.hs +++ b/src/Swish.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : Swish --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -25,12 +25,13 @@ -- the lines described in [3]. -- -- The script format used by Swish is described in --- "Swish.RDF.SwishScript". +-- "Swish.Script". -- -- Users wishing to process RDF data directly may prefer to look at --- the following modules; "Swish.RDF", "Swish.RDF.TurtleParser", --- "Swish.RDF.N3Parser", "Swish.RDF.N3Formatter", "Swish.RDF.NTParser" --- and "Swish.RDF.NTFormatter". +-- the following modules; "Swish.RDF", "Swish.RDF.Parser.Turtle", +-- "Swish.RDF.Parser.N3", "Swish.RDF.Parser.NTriples", +-- "Swish.RDF.Formatter.Turtle", "Swish.RDF.Formatter.N3" +-- and "Swish.RDF.Formatter.NTriples". -- -- (1) Semantic web: -- @@ -44,19 +45,269 @@ -- -- (6) RDF: -- +-- Notes +-- +-- I anticipate that this module may be used as a starting point for +-- creating new programs rather then as a complete program in its own +-- right. The functionality built into this code is selected with a +-- view to testing the Haskell modules for handling RDF rather than +-- for performing any particular application processing (though +-- development as a tool with some broader utility is not ruled out). +-- +-- With the following in ghci: +-- +-- >>> :m + Swish +-- >>> :set prompt "swish> " +-- +-- then we can run a Swish script (format described in "Swish.Script") +-- by saying: +-- +-- >>> runSwish "-s=script.ss" +-- ExitSuccess +-- +-- or convert a file from Turtle to NTriples format with: +-- +-- >>> runSwish "-ttl -i=foo.ttl -nt -o=foo.nt" +-- ExitSuccess +-- +-- You can also use `validateCommands` by giving it the individual commands, +-- such as +-- +-- >>> let Right cs = validateCommands ["-ttl", "-i=file1.ttl", "-c=file2.ttl"] +-- >>> cs +-- [SwishAction: -ttl,SwishAction: -i=file1.ttl,SwishAction: -c=file2.ttl] +-- >>> st <- runSwishActions cs +-- >>> st +-- The graphs do not compare as equal. +-- -------------------------------------------------------------------------------- -module Swish - ( - module Swish.RDF.SwishMain - ) where +module Swish ( SwishStatus(..) + , SwishAction + , runSwish + , runSwishActions + , displaySwishHelp + , splitArguments + , validateCommands + ) where -import Swish.RDF.SwishMain --- should this re-export Swish.RDF.SwishMain or other components? - +import Swish.Commands + ( swishFormat + , swishBase + , swishInput + , swishOutput + , swishMerge + , swishCompare + , swishGraphDiff + , swishScript + ) + +import Swish.Monad (SwishStateIO, SwishState(..), SwishStatus(..) + , SwishFormat(..) + , emptyState) +import Swish.QName (qnameFromURI) + + +import Control.Monad.State (execStateT) +import Control.Monad (liftM) + +import Network.URI (parseURI) + +import Data.Char (isSpace) +import Data.Either (partitionEithers) + +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) + +------------------------------------------------------------ +-- Command line description +------------------------------------------------------------ + +-- we do not display the version in the help file to avoid having +-- to include the Paths_swish module (so that we can use this from +-- an interactive environment). +-- + +usageText :: [String] +usageText = + [ "Swish: Read, merge, write, compare and process RDF graphs." + , "" + , "Usage: swish option option ..." + , "" + , "where the options are processed from left to right, and may be" + , "any of the following:" + , "-h display this message." + , "-? display this message." + , "-v display Swish version and quit." + , "-q do not display Swish version on start up." + , "-nt use Ntriples format for subsequent input and output." + , "-ttl use Turtle format for subsequent input and output." + , "-n3 use Notation3 format for subsequent input and output (default)" + , "-i[=file] read file in selected format into the graph workspace," + , " replacing any existing graph." + , "-m[=file] merge file in selected format with the graph workspace." + , "-c[=file] compare file in selected format with the graph workspace." + , "-d[=file] show graph differences between the file in selected" + , " format and the graph workspace. Differences are displayed" + , " to the standard output stream." + , "-o[=file] write the graph workspace to a file in the selected format." + , "-s[=file] read and execute Swish script commands from the named file." + , "-b[=base] set or clear the base URI. The semantics of this are not" + , " fully defined yet." + , "" + , " If an optional filename value is omitted, the standard input" + , " or output stream is used, as appropriate." + , "" + , "Exit status codes:" + , "Success - operation completed successfully/graphs compare equal" + , "1 - graphs compare different" + , "2 - input data format error" + , "3 - file access problem" + , "4 - command line error" + , "5 - script file execution error" + , "" + , "Examples:" + , "" + , "swish -i=file" + , " read file as Notation3, and report any syntax errors." + , "swish -i=file1 -o=file2" + , " read file1 as Notation3, report any syntax errors, and output the" + , " resulting graph as reformatted Notation3 (the output format" + , " is not perfect but may be improved)." + , "swish -nt -i=file -n3 -o" + , " read file as NTriples and output as Notation3 to the screen." + , "swich -i=file1 -c=file2" + , " read file1 and file2 as notation3, report any syntax errors, and" + , " if both are OK, compare the resulting graphs to indicate whether" + , " or not they are equivalent." + ] + +-- | Write out the help for Swish +displaySwishHelp :: IO () +displaySwishHelp = mapM_ putStrLn usageText + +------------------------------------------------------------ +-- Swish command line interpreter +------------------------------------------------------------ +-- +-- This is a composite monad combining some state with an IO +-- Monad. lift allows a pure IO monad to be used as a step +-- of the computation. +-- + +-- | Return any arguments that need processing immediately, namely +-- the \"help\", \"quiet\" and \"version\" options. +-- +splitArguments :: [String] -> ([String], [String]) +splitArguments = partitionEithers . map splitArgument + +splitArgument :: String -> Either String String +splitArgument "-?" = Left "-h" +splitArgument "-h" = Left "-h" +splitArgument "-v" = Left "-v" +splitArgument "-q" = Left "-q" +splitArgument x = Right x + +-- | Represent a Swish action. At present there is no way to create these +-- actions other than 'validateCommands'. +-- +newtype SwishAction = SA (String, SwishStateIO ()) + +instance Show SwishAction where + show (SA (lbl,_)) = "SwishAction: " ++ lbl + +-- | Given a list of command-line arguments create the list of actions +-- to perform or a string and status value indicating an input error. +validateCommands :: [String] -> Either (String, SwishStatus) [SwishAction] +validateCommands args = + let (ls, rs) = partitionEithers (map validateCommand args) + in case ls of + (e:_) -> Left e + [] -> Right rs + +-- This allows you to say "-nt=foo" and currently ignores the values +-- passed through. This may change +-- +validateCommand :: String -> Either (String, SwishStatus) SwishAction +validateCommand cmd = + let (nam,more) = break (=='=') cmd + arg = drop 1 more + marg = if null arg then Nothing else Just arg + + wrap f = Right $ SA (cmd, f marg) + wrap1 f = Right $ SA (cmd, f) + + in case nam of + "-ttl" -> wrap1 $ swishFormat Turtle + "-nt" -> wrap1 $ swishFormat NT + "-n3" -> wrap1 $ swishFormat N3 + "-i" -> wrap swishInput + "-m" -> wrap swishMerge + "-c" -> wrap swishCompare + "-d" -> wrap swishGraphDiff + "-o" -> wrap swishOutput + "-b" -> validateBase cmd marg + "-s" -> wrap swishScript + _ -> Left ("Invalid command line argument: "++cmd, SwishArgumentError) + +-- | Execute the given set of actions. +swishCommands :: [SwishAction] -> SwishStateIO () +swishCommands = mapM_ swishCommand + +-- | Execute an action. +swishCommand :: SwishAction -> SwishStateIO () +swishCommand (SA (_,act)) = act + +validateBase :: String -> Maybe String -> Either (String, SwishStatus) SwishAction +validateBase arg Nothing = Right $ SA (arg, swishBase Nothing) +validateBase arg (Just b) = + case parseURI b >>= qnameFromURI of + j@(Just _) -> Right $ SA (arg, swishBase j) + _ -> Left ("Invalid base URI <" ++ b ++ ">", SwishArgumentError) + +------------------------------------------------------------ +-- Interactive test function (e.g. for use in ghci) +------------------------------------------------------------ + +-- this ignores the "flags" options, namely +-- -q / -h / -? / -v + +-- | Parse and run the given string as if given at the command +-- line. The \"quiet\", \"version\" and \"help\" options are +-- ignored. +-- +runSwish :: String -> IO ExitCode +runSwish cmdline = do + let args = breakAll isSpace cmdline + (_, cmds) = splitArguments args + + case validateCommands cmds of + Left (emsg, ecode) -> do + putStrLn $ "Swish exit: " ++ emsg + return $ ExitFailure $ fromEnum ecode + + Right acts -> do + ec <- runSwishActions acts + case ec of + SwishSuccess -> return ExitSuccess + _ -> do + putStrLn $ "Swish exit: " ++ show ec + return $ ExitFailure $ fromEnum ec + +-- |Break list into a list of sublists, separated by element +-- satisfying supplied condition. +breakAll :: (a -> Bool) -> [a] -> [[a]] +breakAll _ [] = [] +breakAll p s = let (h,s') = break p s + in h : breakAll p (drop 1 s') + +-- | Execute the given set of actions. +runSwishActions :: [SwishAction] -> IO SwishStatus +runSwishActions acts = exitcode `liftM` execStateT (swishCommands acts) emptyState + -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/Commands.hs b/src/Swish/Commands.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Commands.hs @@ -0,0 +1,406 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Commands +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- Functions to deal with indivudual Swish command options. +-- +-------------------------------------------------------------------------------- + +module Swish.Commands + ( swishFormat + , swishBase + -- , swishVerbose + , swishInput + , swishOutput + , swishMerge + , swishCompare + , swishGraphDiff + , swishScript + ) +where + +import Swish.GraphClass (LDGraph(..), Label(..)) +import Swish.GraphPartition (GraphPartition(..)) +import Swish.GraphPartition (partitionGraph, comparePartitions, partitionShowP) +import Swish.Monad (SwishStateIO, SwishState(..) + , SwishStatus(..), SwishFormat(..) + , setFormat, setBase, setGraph, resetInfo + , resetError, setStatus, swishError, reportLine) +import Swish.QName (QName, qnameFromURI, qnameFromFilePath, getQNameURI) +import Swish.Script (parseScriptFromText) + +import Swish.RDF.Graph (RDFGraph, merge) + +import qualified Swish.RDF.Formatter.Turtle as TTLF +import qualified Swish.RDF.Formatter.N3 as N3F +import qualified Swish.RDF.Formatter.NTriples as NTF + +import Swish.RDF.Parser.Turtle (parseTurtle) +import Swish.RDF.Parser.N3 (parseN3) +import Swish.RDF.Parser.NTriples (parseNT) +import Swish.RDF.Parser.Utils (appendURIs) + +import System.IO + ( Handle, IOMode(..) + , hPutStr, hPutStrLn, hClose + , hIsReadable, hIsWritable + , openFile, stdin, stdout + ) + +import Network.URI (parseURIReference) + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (modify, gets) +import Control.Monad (liftM, when) + +import qualified Data.Text.Lazy as T +import qualified Data.Text.Lazy.IO as IO + +import Data.Maybe (isJust, fromMaybe) + +import Control.Exception as CE + +-- | Set the file format. +-- +swishFormat :: SwishFormat -> SwishStateIO () +swishFormat = modify . setFormat + +-- | Set (or clear) the base URI. +swishBase :: Maybe QName -> SwishStateIO () +swishBase = modify . setBase + +-- | Read in a graph and make it the current graph. +swishInput :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard input. + -> SwishStateIO () +swishInput fnam = + swishReadGraph fnam >>= maybe (return ()) (modify . setGraph) + +-- | Read in a graph and merge it with the current graph. +swishMerge :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard input. + -> SwishStateIO () +swishMerge fnam = + swishReadGraph fnam >>= maybe (return ()) (modify . mergeGraph) + +mergeGraph :: RDFGraph -> SwishState -> SwishState +mergeGraph gr state = state { graph = newgr } + where + newgr = merge gr (graph state) + +-- | Read in a graph and compare it with the current graph. +swishCompare :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard input. + -> SwishStateIO () +swishCompare fnam = + swishReadGraph fnam >>= maybe (return ()) compareGraph + +compareGraph :: RDFGraph -> SwishStateIO () +compareGraph gr = do + oldGr <- gets graph + let exitCode = if gr == oldGr then SwishSuccess else SwishGraphCompareError + modify $ setStatus exitCode + +------------------------------------------------------------ +-- Display graph differences from named file +------------------------------------------------------------ + +-- | Read in a graph and display the differences to the current +-- graph to standard output. +swishGraphDiff :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard input. + -> SwishStateIO () +swishGraphDiff fnam = + swishReadGraph fnam >>= maybe (return ()) diffGraph + +diffGraph :: RDFGraph -> SwishStateIO () +diffGraph gr = do + oldGr <- gets graph + let p1 = partitionGraph (getArcs oldGr) + p2 = partitionGraph (getArcs gr) + diffs = comparePartitions p1 p2 + + swishWriteFile (swishOutputDiffs diffs) Nothing + +swishOutputDiffs :: (Label lb) => + [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] + -> Maybe String + -> Handle + -> SwishStateIO () +swishOutputDiffs diffs fnam hnd = do + lift $ hPutStrLn hnd ("Graph differences: "++show (length diffs)) + mapM_ (swishOutputDiff fnam hnd) (zip [1..] diffs) + +swishOutputDiff :: (Label lb) => + Maybe String + -> Handle + -> (Int,(Maybe (GraphPartition lb),Maybe (GraphPartition lb))) + -> SwishStateIO () +swishOutputDiff fnam hnd (diffnum,(part1,part2)) = do + lift $ hPutStrLn hnd ("---- Difference "++show diffnum++" ----") + lift $ hPutStr hnd "Graph 1:" + swishOutputPart fnam hnd part1 + lift $ hPutStr hnd "Graph 2:" + swishOutputPart fnam hnd part2 + +swishOutputPart :: (Label lb) => + Maybe String + -> Handle + -> Maybe (GraphPartition lb) + -> SwishStateIO () +swishOutputPart _ hnd part = + let out = maybe "\n(No arcs)" (partitionShowP "\n") part + in lift $ hPutStrLn hnd out + +------------------------------------------------------------ +-- Execute script from named file +------------------------------------------------------------ + +-- | Read in a script and execute it. +swishScript :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard input. + -> SwishStateIO () +swishScript fnam = swishReadScript fnam >>= mapM_ swishCheckResult + +swishReadScript :: Maybe String -> SwishStateIO [SwishStateIO ()] +swishReadScript = swishReadFile swishParseScript [] + +{-| +Calculate the base URI to use; it combines the file name +with any user-supplied base. + +If both the file name and user-supplied base are Nothing +then the value + + http://id.ninebynine.org/2003/Swish/ + +is used. + +Needs some work. +-} + +defURI :: QName +defURI = "http://id.ninebynine.org/2003/Swish/" + +calculateBaseURI :: + Maybe FilePath -- ^ file name + -> SwishStateIO QName -- ^ base URI +calculateBaseURI Nothing = fromMaybe defURI `liftM` gets base +calculateBaseURI (Just fnam) = + case parseURIReference fnam of + Just furi -> do + mbase <- gets base + case mbase of + Just buri -> case appendURIs (getQNameURI buri) furi of + Left emsg -> fail emsg -- TODO: think about this ... + Right res -> return $ fromMaybe defURI (qnameFromURI res) + Nothing -> lift $ qnameFromFilePath fnam + + Nothing -> fail $ "Unable to convert to URI: filepath=" ++ fnam + +swishParseScript :: + Maybe String -- file name (or "stdin" if Nothing) + -> T.Text -- script contents + -> SwishStateIO [SwishStateIO ()] +swishParseScript mfpath inp = do + buri <- calculateBaseURI mfpath + case parseScriptFromText (Just buri) inp of + Left err -> do + let inName = maybe "standard input" ("file " ++) mfpath + swishError ("Script syntax error in " ++ inName ++ ": "++err) SwishDataInputError + return [] + + Right scs -> return scs + +swishCheckResult :: SwishStateIO () -> SwishStateIO () +swishCheckResult swishcommand = do + swishcommand + er <- gets errormsg + case er of + Just x -> swishError x SwishExecutionError >> modify resetError + _ -> return () + + ms <- gets infomsg + case ms of + Just x -> reportLine x >> modify resetInfo + _ -> return () + +-- | Write out the current graph. +swishOutput :: + Maybe String -- ^ A filename or, if 'Nothing', then use standard output. + -> SwishStateIO () +swishOutput = swishWriteFile swishOutputGraph + +swishOutputGraph :: Maybe String -> Handle -> SwishStateIO () +swishOutputGraph _ hnd = do + fmt <- gets format + + let writeOut formatter = do + out <- gets $ formatter . graph + lift $ IO.hPutStrLn hnd out + + case fmt of + N3 -> writeOut N3F.formatGraphAsLazyText + NT -> writeOut NTF.formatGraphAsLazyText + Turtle -> writeOut TTLF.formatGraphAsLazyText + -- _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError + +------------------------------------------------------------ +-- Common input functions +------------------------------------------------------------ +-- +-- Keep the logic separate for reading file data and +-- parsing it to an RDF graph value. + +swishReadGraph :: Maybe String -> SwishStateIO (Maybe RDFGraph) +swishReadGraph = swishReadFile swishParse Nothing + +-- | Open a file (or stdin), read its contents, and process them. +-- +swishReadFile :: + (Maybe String -> T.Text -> SwishStateIO a) -- ^ Convert filename and contents into desired value + -> a -- ^ the value to use if the file can not be read in + -> Maybe String -- ^ the file name or @stdin@ if @Nothing@ + -> SwishStateIO a +swishReadFile conv errVal fnam = + let reader (h,f,i) = do + res <- conv fnam i + when f $ lift $ hClose h -- given that we use IO.hGetContents not sure the close is needed + return res + + in swishOpenFile fnam >>= maybe (return errVal) reader + +-- open a file in the SwishStateIO monad, catching +-- any errors +-- +sOpen :: FilePath -> IOMode -> SwishStateIO (Either IOError Handle) +sOpen fp fm = lift . CE.try $ openFile fp fm + +-- | Open and read file, returning its handle and content, or Nothing +-- WARNING: the handle must not be closed until input is fully evaluated +-- +swishOpenFile :: Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text)) +swishOpenFile Nothing = readFromHandle stdin Nothing +swishOpenFile (Just fnam) = do + o <- sOpen fnam ReadMode + case o of + Left _ -> do + swishError ("Cannot open file: "++fnam) SwishDataAccessError + return Nothing + + Right hnd -> readFromHandle hnd $ Just ("file: " ++ fnam) + +readFromHandle :: Handle -> Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text)) +readFromHandle hdl mlbl = do + hrd <- lift $ hIsReadable hdl + if hrd + then do + fc <- lift $ IO.hGetContents hdl + return $ Just (hdl, isJust mlbl, fc) + + else do + lbl <- case mlbl of + Just l -> lift (hClose hdl) >> return l + Nothing -> return "standard input" + swishError ("Cannot read from " ++ lbl) SwishDataAccessError + return Nothing + +swishParse :: + Maybe String -- ^ filename (if not stdin) + -> T.Text -- ^ contents of file + -> SwishStateIO (Maybe RDFGraph) +swishParse mfpath inp = do + fmt <- gets format + buri <- calculateBaseURI mfpath + + let toError eMsg = + swishError (show fmt ++ " syntax error in " ++ inName ++ ": " ++ eMsg) SwishDataInputError + >> return Nothing + + inName = maybe "standard input" ("file " ++) mfpath + + readIn reader = case reader inp of + Left eMsg -> toError eMsg + Right res -> return $ Just res + + case fmt of + Turtle -> readIn (`parseTurtle` Just (getQNameURI buri)) + N3 -> readIn (`parseN3` Just buri) + NT -> readIn parseNT + {- + _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError >> + return Nothing + -} + +swishWriteFile :: + (Maybe String -> Handle -> SwishStateIO ()) -- ^ given a file name and a handle, write to it + -> Maybe String + -> SwishStateIO () +swishWriteFile conv fnam = + let hdlr (h, c) = conv fnam h >> when c (lift $ hClose h) + in swishCreateWriteableFile fnam >>= maybe (return ()) hdlr + +-- | Open file for writing, returning its handle, or Nothing +-- Also returned is a flag indicating whether or not the +-- handled should be closed when writing is done (if writing +-- to standard output, the handle should not be closed as the +-- run-time system should deal with that). +swishCreateWriteableFile :: Maybe String -> SwishStateIO (Maybe (Handle,Bool)) +swishCreateWriteableFile Nothing = do + hwt <- lift $ hIsWritable stdout + if hwt + then return $ Just (stdout, False) + else do + swishError "Cannot write to standard output" SwishDataAccessError + return Nothing + +swishCreateWriteableFile (Just fnam) = do + o <- sOpen fnam WriteMode + case o of + Left _ -> do + swishError ("Cannot open file for writing: " ++ fnam) SwishDataAccessError + return Nothing + + Right hnd -> do + hwt <- lift $ hIsWritable hnd + if hwt + then return $ Just (hnd, True) + else do + lift $ hClose hnd + swishError ("Cannot write to file: "++fnam) SwishDataAccessError + return Nothing + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Datatype.hs b/src/Swish/Datatype.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Datatype.hs @@ -0,0 +1,1074 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Datatype +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : ExistentialQuantification, MultiParamTypeClasses, OverloadedStrings +-- +-- This module defines the structures used to represent and +-- manipulate datatypes. It is designed as a basis for handling datatyped +-- RDF literals, but the functions in this module are more generic. +-- +-------------------------------------------------------------------------------- + +-- Testing note: this module supports a number of specific datatypes. +-- It is intended that functionality in this module will be tested via +-- modules "Swish.RDF.RDFDatatype", +-- "Swish.RDF.ClassRestrictionRule" and +-- "Swish.RDF.RDFDatatypeXsdInteger". +-- See also module ClassRestrictionRuleTest for test cases. + +module Swish.Datatype + ( Datatype(..) + , typeName, typeRules, typeMkRules, typeMkModifiers, typeMkCanonicalForm + , getTypeAxiom, getTypeRule + , DatatypeVal(..) + , getDTMod + , getDTRel + , tvalMkCanonicalForm + , DatatypeMap(..) + , DatatypeRel(..), DatatypeRelFn, DatatypeRelPr + , altArgs + , UnaryFnDescr, UnaryFnTable, UnaryFnApply, unaryFnApp + , BinaryFnDescr, BinaryFnTable, BinaryFnApply, binaryFnApp + , BinMaybeFnDescr, BinMaybeFnTable, BinMaybeFnApply, binMaybeFnApp + , ListFnDescr, ListFnTable, ListFnApply, listFnApp + , DatatypeMod(..), ModifierFn + , ApplyModifier + , nullDatatypeMod + -- , applyDatatypeMod + , makeVmod11inv, makeVmod11 + , makeVmod21inv, makeVmod21 + , makeVmod20 + , makeVmod22 + , makeVmodN1 + , DatatypeSub(..) + ) +where + +import Swish.Namespace (ScopedName) +import Swish.Rule (Formula(..), Rule(..)) +import Swish.Ruleset (Ruleset(..)) +import Swish.Ruleset (getRulesetAxiom, getRulesetRule) +import Swish.VarBinding (VarBinding(..), VarBindingModify(..), OpenVarBindingModify) +import Swish.VarBinding (addVarBinding, nullVarBindingModify) + +import Swish.RDF.Vocabulary (swishName) + +import Swish.Utils.ListHelpers (flist) + +-- used to add Show instances for structures during debugging +-- but backed out again. +-- +-- import Swish.Utils.ShowM (ShowM(..)) + +import Control.Monad (join, liftM) + +import Data.LookupMap (LookupEntryClass(..), LookupMap(..), mapFindMaybe) +import Data.Maybe (isJust, catMaybes) + +import qualified Data.Text as T + +------------------------------------------------------------ +-- Datatype framework +------------------------------------------------------------ + +-- |Datatype wraps a 'DatatypeVal' value, hiding the value type that +-- is used only in implementations of the datatype. +-- Users see just the datatype name and associated ruleset. +-- +data Datatype ex lb vn = forall vt . Datatype (DatatypeVal ex vt lb vn) + +instance LookupEntryClass + (Datatype ex lb vn) ScopedName (Datatype ex lb vn) + where + newEntry (_,dt) = dt + keyVal dt = (typeName dt, dt) + +-- |Get type name from Datatype value +typeName :: Datatype ex lb vn -> ScopedName +typeName (Datatype dtv) = tvalName dtv + +-- |Get static rules from Datatype value +typeRules :: Datatype ex lb vn -> Ruleset ex +typeRules (Datatype dtv) = tvalRules dtv + +-- |Make rules for Datatype value based on supplied expression +typeMkRules :: Datatype ex lb vn -> ex -> [Rule ex] +typeMkRules (Datatype dtv) = tvalMkRules dtv + +-- |Make variable binding modifiers based on values supplied +typeMkModifiers :: Datatype ex lb vn -> [OpenVarBindingModify lb vn] +typeMkModifiers (Datatype dtv) = tvalMkMods dtv + +-- |Get the named axiom from a Datatype value. +getTypeAxiom :: ScopedName -> Datatype ex lb vn -> Maybe (Formula ex) +getTypeAxiom nam dt = getRulesetAxiom nam (typeRules dt) + +-- |Get the named rule from a Datatype value. +getTypeRule :: ScopedName -> Datatype ex lb vn -> Maybe (Rule ex) +getTypeRule nam dt = getRulesetRule nam (typeRules dt) + +-- |Get the canonical form of a datatype value. +typeMkCanonicalForm :: Datatype ex lb vn -> T.Text -> Maybe T.Text +typeMkCanonicalForm (Datatype dtv) = tvalMkCanonicalForm dtv + +------------------------------------------------------------ +-- DatatypeVal +------------------------------------------------------------ + +-- |DatatypeVal is a structure that defines a number of functions +-- and values that characterize the behaviour of a datatype. +-- +-- A datatype is specified with respect to (polymophic in) a given +-- type of (syntactic) expression with which it may be used, and +-- a value type (whose existence is hidden as an existential type +-- within `DatatypeMap`). +-- +-- (I tried hiding the value type with an internal existential +-- declaration, but that wouldn't wash. Hence this two-part +-- structure with `Datatype` in which the internal detail +-- of the value type is hidden from users of the `Datatype` class.) +-- +-- The datatype characteristic functions have two goals: +-- +-- (1) to support the general datatype entailment rules defined by +-- the RDF semantics specification, and +-- +-- (2) to define additional datatype-specific inference patterns by +-- means of which provide additional base functionality to +-- applications based on RDF inference. +-- +-- Datatype-specific inferences are provided using the `DatatypeRel` +-- structure for a datatype, which allows a number of named relations +-- to be defined on datatype values, and provides mechanisms to +-- calculate missing values in a partially-specified member of +-- a relation. +-- +-- Note that rules and variable binding modifiers that deal with +-- combined values of more than one datatype may be defined +-- separately. Definitions in this module are generally applicable +-- only when using a single datatype. +-- +-- An alternative model for datatype value calculations is inspired +-- by that introduced by CWM for arithmetic operations, e.g. +-- +-- > (1 2 3) math:sum ?x => ?x rdf:value 6 +-- +-- (where the bare integer @n@ here is shorthand for @\"n\"^^xsd:integer@). +-- +-- Datatype-specific inference patterns are provided in two ways: +-- +-- * by variable binding modifiers that can be combined with the +-- query results during forward- for backward-chaining of +-- inference rules, and +-- +-- * by the definition of inference rulesets that involve +-- datatype values. +-- +-- I believe the first method to be more flexible than the second, +-- in that it more readily supports forward and backward chaining, +-- but can be used only through the definition of new rules. +-- +-- Type parameters: +-- +-- [@ex@] is the type of expression with which the datatype may be used. +-- +-- [@vt@] is the internal value type with which the labels are associated. +-- +-- [@lb@] is the type of label that may be used as a variable in an +-- expression or rule. +-- +-- [@vn@] is the type of node that may be used to carry a value in an +-- expression or rule. +-- +data DatatypeVal ex vt lb vn = DatatypeVal + { tvalName :: ScopedName + -- ^Identifies the datatype, and also + -- its value space class. + , tvalRules :: Ruleset ex + -- ^A set of named expressions and rules + -- that are valid in in any theory that + -- recognizes the current datatype. + , tvalMkRules :: ex -> [Rule ex] + -- ^A function that accepts an expression + -- and devives some datatype-dependent + -- rules from it. This is provided as a + -- hook for creating datatyped class + -- restriction rules. + , tvalMkMods :: [OpenVarBindingModify lb vn] + -- ^Constructs a list of open variable + -- binding modifiers based on tvalMod, + -- but hiding the actual value type. + , tvalMap :: DatatypeMap vt + -- ^Lexical to value mapping, where @vt@ is + -- a datatype used within a Haskell program + -- to represent and manipulate values in + -- the datatype's value space + , tvalRel :: [DatatypeRel vt] + -- ^A set of named relations on datatype + -- values. Each relation accepts a list + -- of @Maybe vt@, and computes any + -- unspecified values that are in the + -- relation with values supplied. + , tvalMod :: [DatatypeMod vt lb vn] + -- ^A list of named values that are used to + -- construct variable binding modifiers, which + -- in turn may be used by a rule definition. + -- + -- TODO: In due course, this value may be + -- calculated automatically from the supplied + -- value for @tvalRel@. + } + +{- +instance ShowM ex => Show (DatatypeVal ex vt lb vn) where + show dv = "DatatypeVal: " ++ show (tvalName dv) ++ "\n -> rules:\n" ++ show (tvalRules dv) +-} + +-- Other accessor functions + +-- | Return the named datatype relation, if it exists. +getDTRel :: + ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt) +getDTRel nam dtv = + mapFindMaybe nam (LookupMap (tvalRel dtv)) + +-- | Return the named datatype value modifier, if it exists. +getDTMod :: + ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) +getDTMod nam dtv = + mapFindMaybe nam (LookupMap (tvalMod dtv)) + +-- |Get the canonical form of a datatype value, or @Nothing@. +-- +tvalMkCanonicalForm :: DatatypeVal ex vt lb vn -> T.Text -> Maybe T.Text +tvalMkCanonicalForm dtv str = can + where + dtmap = tvalMap dtv + val = mapL2V dtmap str + can = join $ liftM (mapV2L dtmap) val + +-- |DatatypeMap consists of methods that perform lexical-to-value +-- and value-to-canonical-lexical mappings for a datatype. +-- +-- The datatype mappings apply to string lexical forms which +-- are stored as `Data.Text`. +-- +data DatatypeMap vt = DatatypeMap + { mapL2V :: T.Text -> Maybe vt + -- ^ Function to map a lexical string to + -- the datatype value. This effectively + -- defines the lexical space of the + -- datatype to be all strings for which + -- yield a value other than @Nothing@. + , mapV2L :: vt -> Maybe T.Text + -- ^ Function to map a value to its canonical + -- lexical form, if it has such. + } + +-- |Type for a datatype relation inference function. +-- +-- A datatype relation defines tuples of values that satisfy some +-- relation. A datatype relation inference function calculates +-- values that complete a relation with values supplied. +-- +-- The function accepts a list of @Maybe vt@, where vt is the +-- datatype value type. It returns one of: +-- +-- * Just a list of lists, where each inner list returned is a +-- complete set of values, including the values supplied, that +-- are in the relation. +-- +-- * Just an empty list is returned if the supplied values are +-- insufficient to compute any complete sets of values in the +-- relation. +-- +-- * Nothing if the supplied values are not consistent with +-- the relation. +-- +type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] + +-- |Type for datatype relation predicate: accepts a list of values +-- and determines whether or not they satisfy the relation. +-- +type DatatypeRelPr vt = [vt] -> Bool + +-- |Datatype for a named relation on values of a datatype. +-- +data DatatypeRel vt = DatatypeRel + { dtRelName :: ScopedName + , dtRelFunc :: DatatypeRelFn vt + } + +instance LookupEntryClass (DatatypeRel vt) ScopedName (DatatypeRel vt) + where + newEntry (_,relf) = relf + keyVal dtrel = (dtRelName dtrel, dtrel) + +-- |Datatype value modifier functions type +-- +-- Each function accepts a list of values and returns a list of values. +-- The exact significance of the different values supplied and returned +-- depends on the variable binding pattern used (cf. 'ApplyModifier'), +-- but in all cases an empty list returned means that the corresponding +-- inputs are not consistent with the function and cannot be used. +-- +type ModifierFn vn = [vn] -> [vn] + +-- |Type of function used to apply a data value modifier to specified +-- variables in a supplied variable binding. It also accepts the +-- name of the datatype modifier and carries it into the resulting +-- variable binding modifier. +-- +-- (Note that @vn@ is not necessarily the same as @vt@, the datatype value +-- type: the modifier functions may be lifted or otherwise adapted +-- to operate on some other type from which the raw data values are +-- extracted.) +-- +type ApplyModifier lb vn = + ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + +-- |Wrapper for data type variable binding modifier included in +-- a datatype value. +-- +data DatatypeMod vt lb vn = DatatypeMod + { dmName :: ScopedName + , dmModf :: [ModifierFn vt] + , dmAppf :: ApplyModifier lb vn + } + +instance LookupEntryClass + (DatatypeMod vt lb vn) ScopedName (DatatypeMod vt lb vn) + where + newEntry (_,dmod) = dmod + keyVal dmod = (dmName dmod, dmod) + +-- |Null datatype value modifier +nullDatatypeMod :: DatatypeMod vt lb vn +nullDatatypeMod = DatatypeMod + { dmName = swishName "nullDatatypeMod" + , dmModf = [] + , dmAppf = nullAppf + } + where + -- nullAppf :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + nullAppf nam _ lbs = (nullVarBindingModify lbs) { vbmName = nam } + +{- +-- |Apply datatype variable binding modifier value to list of labels and +-- a variable binding. +applyDatatypeMod :: (Eq lb, Show lb, Eq vn, Show vn) + => DatatypeMod vt lb vn -> OpenVarBindingModify lb vn +applyDatatypeMod dtmod = dmAppf dtmod (dmName dtmod) (dmModf dtmod) +-} + +{- +dmName dtmod :: ScopedName +dmModf dtmod :: [ModifierFn vt] + :: [[vt] -> [vt]] +dmAppf dtmod :: ApplyModifier lb vn + :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + :: ScopedName -> [[vn] -> [vn]] -> OpenVarBindingModify lb vn +dmAppf dtmod (dmName dtmod) + :: [[vn] -> [vn]] -> OpenVarBindingModify lb vn +-} + +-------------------------------------------------------------- +-- Functions for creating datatype variable binding modifiers +-------------------------------------------------------------- + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @1->1@ function and inverse, such +-- as negate. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if @x@ and @y@ +-- are in the appropriate relationship. +-- +-- (1) is @[y] -> [x]@, used to perform the calculation in a forward +-- direction. +-- +-- (2) is @[x] -> [y]@, used to perform the calculation in a backward +-- direction. This may be the same as (2) (e.g. for negation) +-- or may be different (e.g. increment). +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. (The intent is that a variable-free +-- value can be generated as a Curried function, and instantiated +-- for particular variables as required.) +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod11inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod11inv nam [f0,f1,f2] lbs@(~[lb1,lb2]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1],[lb2]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind + app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2]) vbind + app2 [Just v1,Nothing] vbind = addv lb2 (f2 [v1]) vbind + app2 _ _ = [] +makeVmod11inv _ _ _ = + error "makeVmod11inv: requires 3 functions and 2 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases when +-- the value mapping is a non-invertable @1->1@ injection, such as +-- absolute value. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if @x@ and @y@ +-- are in the appropriate relationship. +-- +-- (1) is @[x]@ -> @[y]@, used to perform the calculation. +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod11 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod11 nam [f0,f1] lbs@(~[lb1,_]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind + app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2]) vbind + app2 _ _ = [] +makeVmod11 _ _ _ = + error "makeVmod11: requires 2 functions and 2 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @2->1@ invertable function, such as +-- addition or subtraction. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if +-- @x@, @y@ and @z@ are in the appropriate relationship. +-- +-- (2) is @[y,z] -> [x]@, used to perform the calculation in a +-- forward direction. +-- +-- (3) is @[x,z] -> [y]@, used to run the calculation backwards to +-- determine the first input argument +-- +-- (4) is @[x,y] -> [z]@, used to run the calculation backwards to +-- determine the second input argument +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod21inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod21inv nam [f0,f1,f2,f3] lbs@(~[lb1,lb2,lb3]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1],[lb2],[lb3]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind + app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind + app2 [Just v1,Nothing,Just v3] vbind = addv lb2 (f2 [v1,v3]) vbind + app2 [Just v1,Just v2,Nothing] vbind = addv lb3 (f3 [v1,v2]) vbind + app2 _ _ = [] +makeVmod21inv _ _ _ = + error "makeVmod21inv: requires 4 functions and 3 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @2->1@ non-invertable function, such as +-- logical @AND@ or @OR@. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if +-- @x@, @y@ and @z@ are in the appropriate relationship. +-- +-- (2) is @[y,z] -> [x]@, used to perform the calculation in a +-- forward direction. +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod21 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod21 nam [f0,f1] lbs@(~[lb1,_,_]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind + app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind + app2 _ _ = [] +makeVmod21 _ _ _ = + error "makeVmod21: requires 2 functions and 3 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a simple comparson of two values. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (1) is @[x,y] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if +-- @x@ and @y@ are in the appropriate relationship. +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod20 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod20 nam [f0] lbs@(~[_,_]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind + app2 _ _ = [] +makeVmod20 _ _ _ = + error "makeVmod20: requires 1 function and 2 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @2->2@ non-invertable function, such as +-- quotient/remainder +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (1) is @[w,x,y,z] -> [?]@, used as a filter (i.e. not creating +-- any new variable bindings), returning a non-empty list if +-- @w@, @x@, @y@ and @z@ are in the appropriate relationship. +-- +-- (2) is @[y,z] -> [w,x]@, used to perform the calculation given +-- two input values. +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +-- NOTE: this might be generalized to allow one of @w@ or @x@ to be +-- specified, and return null if it doesn't match the calculated value. +-- +makeVmod22 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod22 nam [f0,f1] lbs@(~[lb1,lb2,_,_]) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1,lb2]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 [Just v1,Just v2,Just v3,Just v4] vbind = + selv (f0 [v1,v2,v3,v4]) vbind + app2 [Nothing,Nothing,Just v3,Just v4] vbind = + addv2 lb1 lb2 (f1 [v3,v4]) vbind + app2 _ _ = [] +makeVmod22 _ _ _ = + error "makeVmod22: requires 2 functions and 4 labels" + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @N->1@ function, +-- such as Sigma (sum) of a vector. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (1) is @[x,y...] -> [?]@, used as a filter (i.e. not creating +-- any new variable bindings), returning a non-empty list if +-- @x@ and @y...@ are in the appropriate relationship. +-- +-- (2) is @[y...] -> [x]@, used to perform the calculation. +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmodN1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmodN1 nam [f0,f1] lbs@(~(lb1:_)) = VarBindingModify + { vbmName = nam + , vbmApply = concatMap app1 + , vbmVocab = lbs + , vbmUsage = [[],[lb1]] + } + where + app1 vbind = app2 (map (vbMap vbind) lbs) vbind + app2 vs@(v1:_) vbind + | isJust v1 && isJustvs = selv (f0 jvs) vbind + | isJustvs = addv lb1 (f1 jvs) vbind + | otherwise = [] + where + isJustvs = all isJust vs + jvs = catMaybes vs + app2 _ _ = error "app2 sent empty list" -- -Wall + +makeVmodN1 _ _ _ = + error "makeVmodN1: requires 2 functions and at 1 or more labels" + +-------------------------------------------------------- +-- Local helper functions for makeVmodXXX variants +-------------------------------------------------------- + +-- Add value to variable variable binding, if value is singleton list, +-- otherwise return empty list. +addv :: (Eq lb, Show lb, Eq vt, Show vt) + => lb -> [vt] -> VarBinding lb vt + -> [VarBinding lb vt] +addv lb [val] vbind = [addVarBinding lb val vbind] +addv _ _ _ = [] + +-- Add two entries to variable variable binding, if value supplied is +-- a doubleton list, otherwise return empty list. +addv2 :: (Eq lb, Show lb, Eq vt, Show vt) + => lb -> lb -> [vt] -> VarBinding lb vt + -> [VarBinding lb vt] +addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $ + addVarBinding lb2 val2 vbind] +addv2 _ _ _ _ = [] + +-- If supplied value is non-empty list return supplied variable binding, +-- otherwise return empty list. +selv :: [vt] -> varBinding lb vt -> [varBinding lb vt] +selv [] _ = [] +selv _ vbind = [vbind] + +-------------------------------------------------------------- +-- Functions for evaluating arguments in a datatype relation +-------------------------------------------------------------- +-- +-- altArgs is a generic function for evaluating datatype relation +-- values, based on suppied functions and argument values +-- +-- UnaryFnDescr, UnaryFnApply and unaryFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on unary functions (binary relations). +-- +-- BinaryFnDescr, BinaryFnApply and binaryFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on binary functions (3-way relations). +-- +-- ListFnDescr, ListFnApply and listFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on list functions (n-way relations), +-- where the first member of the list is the value of a +-- fold of a function over the rest of the list. +-- +-- See experimental module spike-altargs.hs for test cases and +-- development steps for this function. + +-- |Given a list of argument values and a list of functions for +-- calculating new values from supplied values, return a list +-- of argument values, or @Nothing@ if the supplied values are +-- inconsistent with the calculations specified. +-- +-- Each list of values returned corresponds to a set of values that +-- satisfy the relation, consistent with the values supplied. +-- +-- Functions are described as tuple consisting of: +-- +-- (a) a predicate that the argument is required to satisfy +-- +-- (b) a function to apply, +-- +-- (c) a function to apply function (b) to a list of arguments +-- +-- (d) argument list index values to which the function is applied. +-- +-- Each supplied argument is of the form @Maybe a@, where the argument +-- has value type a. @Nothing@ indicates arguments of unknown value. +-- +-- The basic idea is that, for each argument position in the relation, +-- a function may be supplied to calculate that argument's possible values +-- from some combination of the other arguments. The results calculated +-- in this way are compared with the original arguments provided: +-- if the values conflict then the relation is presumed to be +-- unsatisfiable with the supplied values, and @Nothing@ is returned; +-- if there are any calculated values for arguments supplied without +-- any values, then tbe calculated values are used. +-- If there are any arguments for which no values are supplied or +-- calculated, then the relation is presumed to be underdetermined, +-- and @Just []@ is returned. +-- +altArgs :: + (Eq vt) + => DatatypeRelPr vt + -> [(vt->Bool,[b])] + -- ^ a list of argument value predicates and + -- function descriptors. The predicate indicates any + -- additional constraints on argument values (e.g. the result + -- of abs must be positive). Use @(const True)@ for the predicate + -- associated with unconstrained relation arguments. + -- For each argument, a list of function descriptors is + -- supplied corresponding to alternative values (e.g. a square + -- relation would offer two alternative values for the root.) + + -> ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) + -- ^ a function that takes an argument value predicate, + -- a function descriptor and applies it to a supplied argument + -- list to return: + -- @Just a@ calculated list of one or more possible argument values, + -- @Just []@ indicating insufficient information provided, or + -- @Nothing@ indicating inconsistent information provided. + -- May be one of 'unaryFnApp', 'binaryFnApp', 'listFnApp' or + -- some other caller-supplied value. + + -> DatatypeRelFn vt + -- ^ The return value can be used as the + -- 'dtRelFunc' component of a 'DatatypeRel' value. + +altArgs pr fnss apfn args = cvals4 cvals3 + where + -- Calculate new value(s) for each argument from supplied values, and + -- lift inconsistency indicator (Just/Nothing) to outermost Monad. + -- cvals1 :: [Maybe [vt]] + cvals1 = flist (map (applyFdescToTuple apfn) fnss) args + -- Merge calculated values with supplied arguments, and again + -- lift inconsistency indicator (Just/Nothing) to outermost Monad. + -- cvals2 :: Maybe [[vt]] + cvals2 = sequence $ mergeTupleVals (map fst fnss) args cvals1 + -- Map list of alternative values for each tuple member to + -- a list of alternative tuples. + cvals3 = liftM sequence cvals2 + -- Check each tuple against the supplied predicate. + -- If any of the alternative tuples does not match the predicate + -- then signal an inconsistency. + cvals4 Nothing = Nothing + cvals4 cvs@(Just ts) = if all pr ts then cvs else Nothing + +-- Perform alternative calculations for single result value +-- Each result value is a list of zero or more alternatives +-- that can be calculated from available parameters, or +-- Nothing if the available parameters are inconsistent. +-- +-- apfn is the function that actually applies an element of +-- the function descriptor to a tuple of Maybe arguments +-- (where Nothing is used to indicate an unknown value) +-- (p,fns) is a pair consisting of a value-checking predicate +-- for the corresponding tuple member, and a list of +-- function descriptors that each return one or more +-- values the tuple member, calculated from other values +-- that are present. Just [] means no values are +-- calculated for this member, and Nothing means the +-- calculation has detected tuple values supplied that +-- are inconsistent with the datatype relation concerned. +-- args is a tuple of Maybe tuple elements, (where Nothing +-- indicates an unknown value). +-- +-- Returns Maybe a list of alternative values for the member, +-- Just [] to indicate insufficient information to calculate +-- any new values, and Nothing to indicate an inconsistency. +-- +applyFdescToTuple :: + ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) -> (vt->Bool,[b]) -> [Maybe vt] + -> Maybe [vt] +applyFdescToTuple apfn (p,fns) args = + liftM concat $ sequence cvals + where + -- cvals :: [Maybe [vt]] + cvals = flist (map (apfn p) fns) args + +-- Merge calculated tuple values with supplied tuple, checking for consistency. +-- +-- ps predicates used for isolated validation of each tuple member +-- args supplied tuple values, with Nothing for unknown values +-- cvals list of alternative calculated values for each tuple member, +-- or Nothing if an inconsistency has been detected by the +-- tuple-calculation functions. Note that this list may contain +-- more entries than args; the surplus entries are ignored +-- (see list functions for how this is used). +-- +-- Returns a tuple of Maybe lists of values for each tuple member, +-- containing Nothing if an inconsistency has been detected in the +-- supplied values. +-- +mergeTupleVals :: (Eq a) => [a->Bool] -> [Maybe a] -> [Maybe [a]] -> [Maybe [a]] +mergeTupleVals _ _ (Nothing:_) = [Nothing] +mergeTupleVals (_:ps) (Nothing:a1s) (Just a2s:a2ss) + = Just a2s:mergeTupleVals ps a1s a2ss +mergeTupleVals (p:ps) (Just a1:a1s) (Just []:a2ss) + | p a1 = Just [a1]:mergeTupleVals ps a1s a2ss + | otherwise = [Nothing] +mergeTupleVals (p:ps) (Just a1:a1s) (Just a2s:a2ss) + | p a1 && elem a1 a2s = Just [a1]:mergeTupleVals ps a1s a2ss + | otherwise = [Nothing] +mergeTupleVals _ [] _ = [] +mergeTupleVals _ _ _ = [Nothing] + +-- |'altArgs' support for unary functions: function descriptor type +type UnaryFnDescr a = (a->a,Int) + +-- |'altArgs' support for unary functions: function descriptor table type +type UnaryFnTable a = [(a->Bool,[UnaryFnDescr a])] + +-- |'altArgs' support for unary functions: function applicator type +type UnaryFnApply a = (a->Bool) -> UnaryFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for unary functions: function applicator +unaryFnApp :: UnaryFnApply a +unaryFnApp p (f1,n) args = apf (args!!n) + where + apf (Just a) = if p r then Just [r] else Nothing where r = f1 a + apf Nothing = Just [] + +-- |'altArgs' support for binary functions: function descriptor type +type BinaryFnDescr a = (a->a->a,Int,Int) + +-- |'altArgs' support for binary functions: function descriptor table type +type BinaryFnTable a = [(a->Bool,[BinaryFnDescr a])] + +-- |'altArgs' support for binary functions: function applicator type +type BinaryFnApply a = + (a->Bool) -> BinaryFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for binary functions: function applicator +binaryFnApp :: BinaryFnApply a +binaryFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) + where + apf (Just a1) (Just a2) = if p r then Just [r] else Nothing + where r = f a1 a2 + apf _ _ = Just [] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function descriptor type +type BinMaybeFnDescr a = (a->a->Maybe [a],Int,Int) + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function descriptor table type +type BinMaybeFnTable a = [(a->Bool,[BinMaybeFnDescr a])] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function applicator type +type BinMaybeFnApply a = + (a->Bool) -> BinMaybeFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function applicator +binMaybeFnApp :: BinMaybeFnApply a +binMaybeFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) + where + apf (Just a1) (Just a2) = if pm r then r else Nothing + where + r = f a1 a2 + pm Nothing = False + pm (Just x) = all p x + apf _ _ = Just [] + +-- |'altArgs' support for list functions (e.g. sum over list of args), +-- where first element of list is a fold over the rest of the list, +-- and remaining elements of list can be calculated in terms +-- of the result of the fold and the remaining elements +-- +-- List function descriptor is +-- +-- (a) list-fold function, f (e.g. (+) +-- +-- (b) list-fold identity, z (e.g. 0) +-- +-- (c) list-fold-function inverse, g (e.g. (-)) +-- +-- (d) index of element to evaluate +-- +-- such that: +-- +-- > (a `f` z) == (z `f` a) == a +-- > (a `g` c) == b <=> a == b `f` c +-- > (a `g` z) == a +-- > (a `g` a) == z +-- +-- and the result of the folded function does not depend on +-- the order that the list elements are processed. +-- +-- NOTE: the list of 'ListFnDescr' values supplied to 'altArgs' must +-- be at least as long as the argument list. In many cases, Haskell +-- lazy evaluation can be used to supply an arbitrarily long list. +-- See test cases in spike-altargs.hs for an example. +-- +-- Function descriptor type +type ListFnDescr a = (a->a->a,a,a->a->a,Int) + +-- |Function table type +type ListFnTable a = [(a->Bool,[ListFnDescr a])] + +-- |'altArgs' support for list functions: function applicator type +type ListFnApply a = (a->Bool) -> ListFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for list functions: function applicator +listFnApp :: ListFnApply a +listFnApp p (f,z,g,n) (a0:args) + | n == 0 = + app $ foldr (apf f) (Just [z]) args + | otherwise = + app $ apf g a0 (foldr (apf f) (Just [z]) (args `deleteIndex` (n-1))) + where + apf :: (a->a->a) -> Maybe a -> Maybe [a] -> Maybe [a] + apf fn (Just a1) (Just [a2]) = Just [fn a1 a2] + apf _ _ _ = Just [] + + -- app :: Maybe [a] -> Maybe [a] + app Nothing = Nothing + app r@(Just [a]) = if p a then r else Nothing + app _ = Just [] + +listFnApp _ _ [] = error "listFnApp called with an empty list" -- -Wall + +-- |Delete the n'th element of a list, returning the result +-- +-- If the list doesn't have an n'th element, return the list unchanged. +-- +deleteIndex :: [a] -> Int -> [a] +deleteIndex [] _ = [] +deleteIndex xxs@(x:xs) n + | n < 0 = xxs + | n == 0 = xs + | otherwise = x:deleteIndex xs (n-1) + +{- +testdi1 = deleteIndex [1,2,3,4] 0 == [2,3,4] +testdi2 = deleteIndex [1,2,3,4] 1 == [1,3,4] +testdi3 = deleteIndex [1,2,3,4] 2 == [1,2,4] +testdi4 = deleteIndex [1,2,3,4] 3 == [1,2,3] +testdi5 = deleteIndex [1,2,3,4] 4 == [1,2,3,4] +testdi6 = deleteIndex [1,2,3,4] (-1) == [1,2,3,4] +testdi = and + [ testdi1, testdi2, testdi3, testdi4, testdi5, testdi6 ] +-} + +-------------------------------------------------------- +-- Datatype sub/supertype description +-------------------------------------------------------- + +-- |Describe a subtype/supertype relationship between a pair of datatypes. +-- +-- Originally, I had this as a supertype field of the DatatypeVal structure, +-- but that suffered from some problems: +-- +-- * supertypes may be introduced retrospectively, +-- +-- * the relationship expressed with respect to a single datatype +-- cannot indicate how to do injections/restrictions between the +-- underlying value types. +-- +-- [@ex@] is the type of expression with which the datatype may be used. +-- +-- [@lb@] is the type of the variable labels used. +-- +-- [@vn@] is the type of value node used to contain a datatyped value +-- +-- [@supvt@] is the internal value type of the super-datatype +-- +-- [@subvt@] is the internal value type of the sub-datatype +-- +data DatatypeSub ex lb vn supvt subvt = DatatypeSub + { trelSup :: DatatypeVal ex supvt lb vn + -- ^ Datatype that is a supertype of @trelSub@, + -- having value space @supvt@. + , trelSub :: DatatypeVal ex subvt lb vn + -- ^ Datatype that is a subtype of @trelSup@, + -- having value space @supvt@. + , trelToSup :: subvt -> supvt + -- ^ Function that maps subtype value to + -- corresponding supertype value. + , trelToSub :: supvt -> Maybe subvt + -- ^ Function that maps supertype value to + -- corresponding subtype value, if there + -- is such a value. + } + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/GraphClass.hs b/src/Swish/GraphClass.hs new file mode 100644 --- /dev/null +++ b/src/Swish/GraphClass.hs @@ -0,0 +1,220 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphClass +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : DeriveFunctor, DeriveFoldable, DeriveTraversable, MultiParamTypeClasses +-- +-- This module defines a Labelled Directed Graph and Label classes, +-- and the Arc datatype. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Define LDGraph, arc and related classes and types +------------------------------------------------------------ + +module Swish.GraphClass + ( LDGraph(..) + , Label(..) + , Arc(..) + , Selector + , arc, arcToTriple, arcFromTriple + , hasLabel, arcLabels -- , arcNodes + ) +where + +import Data.Hashable (Hashable(..)) +import Data.List (foldl', union, (\\)) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +-- NOTE: I wanted to declare this as a subclass of Functor, but +-- the constraint on the label type seems to prevent that. +-- So I've just declared specific instances to be Functors. +-- + +{-| +Labelled Directed Graph class. + +Minimum required implementation: +'emptyGraph', 'setArcs', and 'getArcs'. +-} +class (Eq (lg lb), Eq lb ) => LDGraph lg lb where + -- | Create the empty graph. + emptyGraph :: lg lb + + -- | Replace the existing arcs in the graph. + setArcs :: lg lb -> [Arc lb] -> lg lb + + -- | Extract all the arcs from a graph + getArcs :: lg lb -> [Arc lb] + + -- | Extract those arcs that match the given `Selector`. + extract :: Selector lb -> lg lb -> lg lb + extract sel = update (filter sel) + + -- | Add the two graphs + addGraphs :: lg lb -> lg lb -> lg lb + addGraphs addg = update (union (getArcs addg)) + + -- | Remove those arcs in the first graph from the second + -- graph + delete :: lg lb -- ^ g1 + -> lg lb -- ^ g2 + -> lg lb -- ^ g2 - g1 -> g3 + delete delg = update (\\ getArcs delg) + + -- | Enumerate the distinct labels contained in a graph; + -- that is, any label that appears in the subject, + -- predicate or object position of an `Arc`. + labels :: lg lb -> [lb] + labels g = foldl' union [] (map arcLabels (getArcs g)) + + -- | Enumerate the distinct nodes contained in a graph; + -- that is, any label that appears in the subject + -- or object position of an `Arc`. + nodes :: lg lb -> [lb] + nodes g = foldl' union [] (map arcNodes (getArcs g)) + + -- | Update the arcs in a graph using a supplied function. + update :: ([Arc lb] -> [Arc lb]) -> lg lb -> lg lb + update f g = setArcs g ( f (getArcs g) ) + +-- | Label class +-- +-- A label may have a fixed binding, which means that the label identifies (is) a +-- particular graph node, and different such labels are always distinct nodes. +-- Alternatively, a label may be unbound (variable), which means that it is a +-- placeholder for an unknown node label. Unbound node labels are used as +-- graph-local identifiers for indicating when the same node appears in +-- several arcs. +-- +-- For the purposes of graph-isomorphism testing, fixed labels are matched when they +-- are the same. Variable labels may be matched with any other variable label. +-- Our definition of isomorphism (for RDF graphs) does not match variable labels +-- with fixed labels. + +class (Eq lb, Show lb, Ord lb) => Label lb where + + -- | Does this node have a variable binding? + labelIsVar :: lb -> Bool + + -- | Calculate the hash of the label using the supplied seed. + labelHash :: Int -> lb -> Int + + -- could provide a default of + -- labelHash = hashWithSalt + -- but this would then force a Hashable constraint + + -- | Extract the local id from a variable node. + getLocal :: lb -> String + + -- | Make a label value from a local id. + makeLabel :: String -> lb + + -- compare :: lb -> lb -> Ordering + -- compare l1 l2 = compare (show l1) (show l2) + +-- | Arc type. +-- +-- Prior to @0.7.0.0@ you could also use @asubj@, @apred@ and @aobj@ +-- to access the elements of the arc. +-- +data Arc lb = Arc + { arcSubj :: lb -- ^ The subject of the arc. + , arcPred :: lb -- ^ The predicate (property) of the arc. + , arcObj :: lb -- ^ The object of the arc. + } + deriving (Eq, Functor, F.Foldable, T.Traversable) + +instance (Hashable lb) => Hashable (Arc lb) where + hash (Arc s p o) = hash s `hashWithSalt` p `hashWithSalt` o + hashWithSalt salt (Arc s p o) = salt `hashWithSalt` s `hashWithSalt` p `hashWithSalt` o + +-- | Create an arc. +arc :: lb -- ^ The subject of the arc. + -> lb -- ^ The predicate of the arc. + -> lb -- ^ The object of the arc. + -> Arc lb +arc = Arc + +-- | Convert an Arc into a tuple. +arcToTriple :: Arc lb -> (lb,lb,lb) +arcToTriple (Arc s p o) = (s, p, o) + +-- | Create an Arc from a tuple. +arcFromTriple :: (lb,lb,lb) -> Arc lb +arcFromTriple (s,p,o) = Arc s p o + +instance Ord lb => Ord (Arc lb) where + compare (Arc s1 p1 o1) (Arc s2 p2 o2) + | cs /= EQ = cs + | cp /= EQ = cp + | otherwise = co + where + cs = compare s1 s2 + cp = compare p1 p2 + co = compare o1 o2 + + {- not needed + (Arc s1 p1 o1) <= (Arc s2 p2 o2) + | s1 /= s2 = s1 <= s2 + | p1 /= p2 = p1 <= p2 + | otherwise = o1 <= o2 + -} + +instance (Show lb) => Show (Arc lb) where + show (Arc lb1 lb2 lb3) = + "("++ show lb1 ++","++ show lb2 ++","++ show lb3 ++")" + +-- | Identify arcs. +type Selector lb = Arc lb -> Bool + +-- | Does the arc contain the label in any position (subject, predicate, or object)? +hasLabel :: (Eq lb) => lb -> Arc lb -> Bool +hasLabel lbv lb = lbv `elem` arcLabels lb + +-- | Return all the labels in an arc. +arcLabels :: Arc lb -> [lb] +arcLabels (Arc lb1 lb2 lb3) = [lb1,lb2,lb3] + +-- | Return just the subject and object labels in the arc. +arcNodes :: Arc lb -> [lb] +arcNodes (Arc lb1 _ lb3) = [lb1,lb3] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/GraphMatch.hs b/src/Swish/GraphMatch.hs new file mode 100644 --- /dev/null +++ b/src/Swish/GraphMatch.hs @@ -0,0 +1,675 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphMatch +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses +-- +-- This module contains graph-matching logic. +-- +-- The algorithm used is derived from a paper on RDF graph matching +-- by Jeremy Carroll . +-- +-------------------------------------------------------------------------------- + +module Swish.GraphMatch + ( graphMatch, + -- * Exported for testing + LabelMap, GenLabelMap(..), LabelEntry, GenLabelEntry(..), + ScopedLabel(..), makeScopedLabel, makeScopedArc, + LabelIndex, EquivalenceClass, nullLabelVal, emptyMap, + labelIsVar, labelHash, + mapLabelIndex, setLabelHash, newLabelMap, + graphLabels, assignLabelMap, newGenerationMap, + graphMatch1, graphMatch2, equivalenceClasses, reclassify + ) where + +import Swish.GraphClass (Arc(..), Label(..)) +import Swish.GraphClass (arcLabels, hasLabel, arcToTriple) + +import Swish.Utils.ListHelpers (equiv) + +import Control.Exception.Base (assert) +import Control.Arrow (second) + +import Data.Ord (comparing) +import Data.List (foldl', nub, sortBy, groupBy, partition) +import Data.LookupMap (LookupEntryClass(..), LookupMap(..)) +import Data.LookupMap (makeLookupMap, listLookupMap, mapFind, mapReplaceAll, + mapAddIfNew, mapReplaceMap, mapMerge) +import Data.Function (on) +import Data.Hashable (combine) +import Data.Word + +import qualified Data.List as L + +-------------------------- +-- Label index value type +-------------------------- +-- + +-- | LabelIndex is a unique value assigned to each label, such that +-- labels with different values are definitely different values +-- in the graph; e.g. do not map to each other in the graph +-- bijection. The first member is a generation counter that +-- ensures new values are distinct from earlier passes. + +type LabelIndex = (Word32, Word32) + +-- | The null, or empty, index value. +nullLabelVal :: LabelIndex +nullLabelVal = (0, 0) + +----------------------- +-- Label mapping types +----------------------- + +-- | A Mapping between a label and a value (e.g. an index +-- value). +data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv + +-- | A label associated with a 'LabelIndex' +type LabelEntry lb = GenLabelEntry lb LabelIndex + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => LookupEntryClass (GenLabelEntry lb lv) lb lv where + keyVal (LabelEntry k v) = (k,v) + newEntry (k,v) = LabelEntry k v + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => Show (GenLabelEntry lb lv) where + show = entryShow + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => Eq (GenLabelEntry lb lv) where + (==) = entryEq + +-- | Type for label->index lookup table +data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = + LabelMap Word32 (LookupMap (GenLabelEntry lb lv)) + +-- | A label lookup table specialized to 'LabelIndex' indices. +type LabelMap lb = GenLabelMap lb LabelIndex + +instance (Label lb) => Show (LabelMap lb) where + show = showLabelMap + +instance (Label lb) => Eq (LabelMap lb) where + LabelMap gen1 lmap1 == LabelMap gen2 lmap2 = + gen1 == gen2 && es1 `equiv` es2 + where + es1 = listLookupMap lmap1 + es2 = listLookupMap lmap2 + +-- | The empty label map table. +emptyMap :: (Label lb) => LabelMap lb +emptyMap = LabelMap 1 $ makeLookupMap [] + +-------------------------- +-- Equivalence class type +-------------------------- +-- + +-- | Type for equivalence class description +-- (An equivalence class is a collection of labels with +-- the same 'LabelIndex' value.) + +type EquivalenceClass lb = (LabelIndex, [lb]) + +{- +ecIndex :: EquivalenceClass lb -> LabelIndex +ecIndex = fst +-} + +ecLabels :: EquivalenceClass lb -> [lb] +ecLabels = snd + +{- +ecSize :: EquivalenceClass lb -> Int +ecSize = length . ecLabels +-} + +ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb +ecRemoveLabel xs l = second (L.delete l) xs + +------------------------------------------------------------ +-- Filter, ungroup, sort and group pairs by first member +------------------------------------------------------------ + +{- +pairSelect :: ((a,b) -> Bool) -> ((a,b) -> c) -> [(a,b)] -> [c] +pairSelect p f as = map f (filter p as) +-} + +-- | Ungroup the pairs. +pairUngroup :: + (a,[b]) -- ^ Given (a,bs) + -> [(a,b)] -- ^ Returns (a,b) for all b in bs +pairUngroup (a,bs) = [ (a,b) | b <- bs ] + +-- | Order the pairs based on the first argument. +pairSort :: (Ord a) => [(a,b)] -> [(a,b)] +pairSort = sortBy (comparing fst) + +-- | Group the pairs based on the first argument. +pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])] +pairGroup = map (factor . unzip) . groupBy eqFirst . pairSort + where + -- as is not [] by construction, but would be nice to have + -- this enforced by the types + factor (as, bs) = (head as, bs) + eqFirst = (==) `on` fst + +------------------------------------------------------------ +-- Augmented graph label value - for graph matching +------------------------------------------------------------ +-- +-- | This instance of class label adds a graph identifier to +-- each variable label, so that variable labels from +-- different graphs are always seen as distinct values. +-- +-- The essential logic added by this class instance is embodied +-- in the eq and hash functions. Note that variable label hashes +-- depend only on the graph in which they appear, and non-variable +-- label hashes depend only on the variable. Label hash values are +-- used when initializing a label equivalence-class map (and, for +-- non-variable labels, also for resolving hash collisions). + +data (Label lb) => ScopedLabel lb = ScopedLabel Int lb + +-- | Create a scoped label given an identifier and label. +makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb +makeScopedLabel = ScopedLabel + +-- | Create an arc containining a scoped label with the given identifier. +makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb) +makeScopedArc scope = fmap (ScopedLabel scope) + +instance (Label lb) => Label (ScopedLabel lb) where + getLocal lab = error $ "getLocal for ScopedLabel: "++show lab + makeLabel locnam = error $ "makeLabel for ScopedLabel: "++locnam + labelIsVar (ScopedLabel _ lab) = labelIsVar lab + labelHash seed (ScopedLabel scope lab) + | labelIsVar lab = seed `combine` scope -- MH.hash seed $ show scope ++ "???" + | otherwise = labelHash seed lab + +instance (Label lb) => Eq (ScopedLabel lb) where + (ScopedLabel s1 l1) == (ScopedLabel s2 l2) + = l1 == l2 && s1 == s2 + +instance (Label lb) => Show (ScopedLabel lb) where + show (ScopedLabel s1 l1) = show s1 ++ ":" ++ show l1 + +instance (Label lb) => Ord (ScopedLabel lb) where + compare (ScopedLabel s1 l1) (ScopedLabel s2 l2) = + case compare s1 s2 of + LT -> LT + EQ -> compare l1 l2 + GT -> GT + +-- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ? + +-- | Graph matching function accepting two lists of arcs and +-- returning a node map if successful +-- +graphMatch :: (Label lb) => + (lb -> lb -> Bool) + -- ^ a function that tests for additional constraints + -- that may prevent the matching of a supplied pair + -- of nodes. Returns `True` if the supplied nodes may be + -- matched. (Used in RDF graph matching for checking + -- that formula assignments are compatible.) + -> [Arc lb] -- ^ the first graph to be compared, as a list of arcs + -> [Arc lb] -- ^ the second graph to be compared, as a list of arcs + -> (Bool, LabelMap (ScopedLabel lb)) + -- ^ If the first element is `True` then the second element maps each label + -- to an equivalence class identifier, otherwise it is just + -- `emptyMap`. + -- +graphMatch matchable gs1 gs2 = + let + sgs1 = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1 + sgs2 = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2 + ls1 = {- traceShow "ls1 " $ -} graphLabels sgs1 + ls2 = {- traceShow "ls2 " $ -} graphLabels sgs2 + lmap = {- traceShow "lmap " $ -} + newGenerationMap $ + assignLabelMap ls1 $ + assignLabelMap ls2 emptyMap + ec1 = {- traceShow "ec1 " $ -} equivalenceClasses lmap ls1 + ec2 = {- traceShow "ec2 " $ -} equivalenceClasses lmap ls2 + ecpairs = zip (pairSort ec1) (pairSort ec2) + matchableScoped (ScopedLabel _ l1) (ScopedLabel _ l2) = matchable l1 l2 + match = graphMatch1 False matchableScoped sgs1 sgs2 lmap ecpairs + in + if length ec1 /= length ec2 then (False,emptyMap) else match + +-- TODO: +-- +-- * replace Equivalence class pair by @(index,[lb],[lb])@ ? +-- +-- * possible optimization: the @graphMapEq@ test should be +-- needed only if `graphMatch2` has been used to guess a +-- mapping; either: +-- a) supply flag saying guess has been used, or +-- b) move test to `graphMatch2` and use different +-- test to prevent rechecking for each guess used. +-- + +-- | Recursive graph matching function +-- +-- This function assumes that no variable label appears in both graphs. +-- (Function `graphMatch`, which calls this, ensures that all variable +-- labels are distinct.) +-- + +graphMatch1 :: + (Label lb) + => Bool + -- ^ `True` if a guess has been used before trying this comparison, + -- `False` if nodes are being matched without any guesswork + -> (lb -> lb -> Bool) + -- ^ Test for additional constraints that may prevent the matching + -- of a supplied pair of nodes. Returns `True` if the supplied + -- nodes may be matched. + -> [Arc lb] + -- ^ (@gs1@ argument) + -- first of two lists of arcs (triples) to be compared + -> [Arc lb] + -- ^ (@gs2@ argument) + -- secind of two lists of arcs (triples) to be compared + -> LabelMap lb + -- ^ the map so far used to map label values to equivalence class + -- values + -> [(EquivalenceClass lb,EquivalenceClass lb)] + -- ^ (the @ecpairs@ argument) list of pairs of corresponding + -- equivalence classes of nodes from @gs1@ and @gs2@ that have not + -- been confirmed in 1:1 correspondence with each other. Each + -- pair of equivalence classes contains nodes that must be placed + -- in 1:1 correspondence with each other. + -- + -> (Bool,LabelMap lb) + -- ^ the pair @(match, map)@ where @match@ is @True@ if the supplied + -- sets of arcs can be matched, in which case @map@ is a + -- corresponding map from labels to equivalence class identifiers. + -- When @match@ is @False@, @map@ is the most detailed equivalence + -- class map obtained before a mismatch was detected or a guess + -- was required -- this is intended to help identify where the + -- graph mismatch may be. +graphMatch1 guessed matchable gs1 gs2 lmap ecpairs = + let + (secs,mecs) = partition uniqueEc ecpairs + uniqueEc ( (_,[_]) , (_,[_]) ) = True + uniqueEc ( _ , _ ) = False + + doMatch ( (_,[l1]) , (_,[l2]) ) = labelMatch matchable lmap l1 l2 + doMatch x = error $ "doMatch failue: " ++ show x -- keep -Wall happy + + ecEqSize ( (_,ls1) , (_,ls2) ) = length ls1 == length ls2 + eSize ( (_,ls1) , _ ) = length ls1 + ecCompareSize = comparing eSize + (lmap',mecs',newEc,matchEc) = reclassify gs1 gs2 lmap mecs + match2 = graphMatch2 matchable gs1 gs2 lmap $ sortBy ecCompareSize mecs + in + -- trace ("graphMatch1\nsingle ECs:\n"++show secs++ + -- "\nmultiple ECs:\n"++show mecs++ + -- "\n\n") $ + -- if mismatch in singleton equivalence classes, fail + if not $ all doMatch secs then (False,lmap) + else + -- if no multi-member equivalence classes, + -- check and return label map supplied + -- trace ("graphMatch1\ngraphMapEq: "++show (graphMapEq lmap gs1 gs2)) $ + if null mecs then (graphMapEq lmap gs1 gs2,lmap) + else + -- if size mismatch in equivalence classes, fail + -- trace ("graphMatch1\nall ecEqSize mecs: "++show (all ecEqSize mecs)) $ + + -- invoke reclassification, and deal with result + if not (all ecEqSize mecs) || not matchEc + then (False, lmap) + else if newEc + then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' + -- if guess does not result in a match, return supplied label map + else if fst match2 then match2 else (False, lmap) + +{- + if not $ all ecEqSize mecs then (False,lmap) + else + if not matchEc then (False,lmap) + else + if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' + else + if fst match2 then match2 else (False,lmap) +-} + +-- | Auxiliary graph matching function +-- +-- This function is called when deterministic decomposition of node +-- mapping equivalence classes has run its course. +-- +-- It picks a pair of equivalence classes in ecpairs, and arbitrarily matches +-- pairs of nodes in those equivalence classes, recursively calling the +-- graph matching function until a suitable node mapping is discovered +-- (success), or until all such pairs have been tried (failure). +-- +-- This function represents a point to which arbitrary choices are backtracked. +-- The list comprehension 'glp' represents the alternative choices at the +-- point of backtracking +-- +-- The selected pair of nodes are placed in a new equivalence class based on their +-- original equivalence class value, but with a new NodeVal generation number. + +graphMatch2 :: (Label lb) => (lb -> lb -> Bool) + -> [Arc lb] -> [Arc lb] + -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] + -> (Bool,LabelMap lb) +graphMatch2 _ _ _ _ [] = error "graphMatch2 sent an empty list" -- To keep -Wall happy +graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) = + let + v1 = snd ev1 + -- Return any equivalence-mapping obtained by matching a pair + -- of labels in the supplied list, or Nothing. + try [] = (False,lmap) + try ((l1,l2):lps) = if isEquiv try1 l1 l2 then try1 else try lps + where + try1 = graphMatch1 True matchable gs1 gs2 lmap' ecpairs' + lmap' = newLabelMap lmap [(l1,v1),(l2,v1)] + ecpairs' = ((ev',[l1]),(ev',[l2])):ec':ecpairs + ev' = mapLabelIndex lmap' l1 + ec' = (ecRemoveLabel ec1 l1, ecRemoveLabel ec2 l2) + -- [[[TODO: replace this: if isJust try ?]]] + isEquiv (False,_) _ _ = False + isEquiv (True,lm) x1 x2 = + mapLabelIndex m1 x1 == mapLabelIndex m2 x2 + where + m1 = remapLabels gs1 lm [x1] + m2 = remapLabels gs2 lm [x2] + -- glp is a list of label-pair candidates for matching, + -- selected from the first label-equivalence class. + -- NOTE: final test is call of external matchable function + glp = [ (l1,l2) | l1 <- ls1 , l2 <- ls2 , matchable l1 l2 ] + in + assert (ev1==ev2) -- "GraphMatch2: Equivalence class value mismatch" $ + $ try glp + +-- this was in Swish.Utils.MiscHelpers along with a simple hash-based function +-- based on Sedgewick, Algorithms in C, p233. As we have now moved to using +-- Data.Hashable it is not clear whether this is still necessary or sensible. +-- +hashModulus :: Int +hashModulus = 16000001 + +-- | Returns a string representation of a LabelMap value +-- +showLabelMap :: (Label lb) => LabelMap lb -> String +showLabelMap (LabelMap gn lmap) = + "LabelMap gen="++ Prelude.show gn ++", map="++ + foldl' (++) "" (map (("\n "++) . Prelude.show) es) + where + es = listLookupMap lmap + +-- | Map a label to its corresponding label index value in the supplied LabelMap +-- +mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex +mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms + +-- | Confirm that a given pair of labels are matchable, and are +-- mapped to the same value by the supplied label map +-- +labelMatch :: (Label lb) + => (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool +labelMatch matchable lmap l1 l2 = + matchable l1 l2 && (mapLabelIndex lmap l1 == mapLabelIndex lmap l1) + +-- | Replace selected values in a label map with new values from the supplied +-- list of labels and new label index values. The generation number is +-- supplied from the current label map. The generation number in the +-- resulting label map is incremented. +-- +newLabelMap :: (Label lb) => LabelMap lb -> [(lb, Word32)] -> LabelMap lb +newLabelMap lmap [] = newGenerationMap lmap +newLabelMap lmap (lv:lvs) = setLabelHash (newLabelMap lmap lvs) lv + +-- | Replace a label and its associated value in a label map +-- with a new value using the supplied hash value and the current +-- `LabelMap` generation number. If the key is not found, then no change +-- is made to the label map. + +setLabelHash :: (Label lb) + => LabelMap lb -> (lb, Word32) -> LabelMap lb +setLabelHash (LabelMap g lmap) (lb,lh) = + LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) ) + +-- | Increment the generation of the label map. +-- +-- Returns a new label map identical to the supplied value +-- but with an incremented generation number. +-- +newGenerationMap :: (Label lb) => LabelMap lb -> LabelMap lb +newGenerationMap (LabelMap g lvs) = LabelMap (g+1) lvs + +-- | Scan label list, assigning initial label map values, +-- adding new values to the label map supplied. +-- +-- Label map values are assigned on the basis of the +-- label alone, without regard for it's connectivity in +-- the graph. (cf. `reclassify`). +-- +-- All variable node labels are assigned the same initial +-- value, as they may be matched with each other. +-- +assignLabelMap :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb +assignLabelMap ns lmap = foldl' (flip assignLabelMap1) lmap ns + +assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb +assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs' + where + lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab)) + +-- Calculate initial value for a node + +initVal :: (Label lb) => lb -> Word32 +initVal = fromIntegral . hashVal 0 + +hashVal :: (Label lb) => Int -> lb -> Int +hashVal seed lab = + if labelIsVar lab then seed `combine` 23 else labelHash seed lab + -- if labelIsVar lab then hash seed "???" else labelHash seed lab + +-- | Return the equivalence classes of the supplied nodes +-- using the label map. +equivalenceClasses :: + (Label lb) + => LabelMap lb -- ^ label map + -> [lb] -- ^ list of nodes to be reclassified + -> [EquivalenceClass lb] +equivalenceClasses lmap ls = + pairGroup $ map labelPair ls + where + labelPair l = (mapLabelIndex lmap l,l) + +-- | Reclassify labels +-- +-- Examines the supplied label equivalence classes (based on the supplied +-- label map), and evaluates new equivalence subclasses based on node +-- values and adjacency (for variable nodes) and rehashing +-- (for non-variable nodes). +-- +-- Note, assumes that all all equivalence classes supplied are +-- non-singletons; i.e. contain more than one label. +-- +reclassify :: + (Label lb) + => [Arc lb] + -- ^ (the @gs1@ argument) the first of two lists of arcs (triples) to perform a + -- basis for reclassifying the labels in the first equivalence + -- class in each pair of @ecpairs@. + -> [Arc lb] + -- ^ (the @gs2@ argument) the second of two lists of arcs (triples) to perform a + -- basis for reclassifying the labels in the second equivalence + -- class in each pair of the @ecpairs@ argument + -> LabelMap lb + -- ^ the label map used for classification of the labels in + -- the supplied equivalence classes + -> [(EquivalenceClass lb,EquivalenceClass lb)] + -- ^ (the @ecpairs@ argument) a list of pairs of corresponding equivalence classes of + -- nodes from @gs1@ and @gs2@ that have not been confirmed + -- in 1:1 correspondence with each other. + -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool) + -- ^ The output tuple consists of: + -- + -- 1) a revised label map reflecting the reclassification + -- + -- 2) a new list of equivalence class pairs based on the + -- new node map + -- + -- 3) if the reclassification partitions any of the + -- supplied equivalence classes then `True`, else `False` + -- + -- 4) if reclassification results in each equivalence class + -- being split same-sized equivalence classes in the two graphs, + -- then `True`, otherwise `False`. + +reclassify gs1 gs2 lmap@(LabelMap _ lm) ecpairs = + assert (gen1==gen2) -- "Label map generation mismatch" + (LabelMap gen1 lm',ecpairs',newPart,matchPart) + where + LabelMap gen1 lm1 = + remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs + LabelMap gen2 lm2 = + remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs + lm' = mapReplaceMap lm $ mapMerge lm1 lm2 + + tmap f (a,b) = (f a, f b) + + -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])] + ecGroups = map (tmap remapEc) ecpairs + ecpairs' = concatMap (uncurry zip) ecGroups + newPart = any pairG1 lenGroups + matchPart = all pairEq lenGroups + lenGroups = map (tmap length) ecGroups + pairEq = uncurry (==) + pairG1 (p1,p2) = p1 > 1 || p2 > 1 + remapEc = pairGroup . map (newIndex lm') . pairUngroup + newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab) + +-- | Calculate a new index value for a supplied list of labels based on the +-- supplied label map and adjacency calculations in the supplied graph +-- +remapLabels :: + (Label lb) + => [Arc lb] -- ^ arcs used for adjacency calculations when remapping + -> LabelMap lb -- ^ the current label index values + -> [lb] -- ^ the graph labels for which new mappings are to be created + -> LabelMap lb + -- ^ the updated label map containing recalculated label index values + -- for the given graph labels. The label map generation number is + -- incremented by 1. +remapLabels gs lmap@(LabelMap gen _) ls = + LabelMap gen' (LookupMap newEntries) + where + gen' = gen+1 + newEntries = [ newEntry (l, (gen', fromIntegral (newIndex l))) | l <- ls ] + newIndex l + | labelIsVar l = mapAdjacent l -- adjacency classifies variable labels + | otherwise = hashVal (fromIntegral gen) l -- otherwise rehash (to disentangle collisions) + -- mapAdjacent l = sum (sigsOver l) `rem` hashModulus + mapAdjacent l = sum (sigsOver l) `combine` hashModulus -- is this a sensible replacement for `rem` MH.hashModulus + sigsOver l = select (hasLabel l) gs (arcSignatures lmap gs) + +-- |Select is like filter, except that it tests one list to select +-- elements from a second list. +select :: ( a -> Bool ) -> [a] -> [b] -> [b] +select _ [] [] = [] +select f (e1:l1) (e2:l2) + | f e1 = e2 : select f l1 l2 + | otherwise = select f l1 l2 +select _ _ _ = error "select supplied with different length lists" + + +-- | Return list of distinct labels used in a graph + +graphLabels :: (Label lb) => [Arc lb] -> [lb] +graphLabels = nub . concatMap arcLabels + +-- TODO: worry about overflow? + +-- | Calculate a signature value for each arc that can be used in constructing an +-- adjacency based value for a node. The adjacancy value for a label is obtained +-- by summing the signatures of all statements containing that label. +-- +arcSignatures :: + (Label lb) + => LabelMap lb -- ^ the current label index values + -> [Arc lb] -- ^ calculate signatures for these arcs + -> [Int] -- ^ the signatures of the arcs +arcSignatures lmap = + map (sigCalc . arcToTriple) + where + sigCalc (s,p,o) = + fromIntegral ( labelVal2 s + + labelVal2 p * 3 + + labelVal2 o * 5 ) + `combine` hashModulus + -- `rem` hashModulus + + labelVal = mapLabelIndex lmap + labelVal2 = uncurry (*) . labelVal + +-- | Return a new graph that is supplied graph with every node/arc +-- mapped to a new value according to the supplied function. +-- +-- Used for testing for graph equivalence under a supplied +-- label mapping; e.g. +-- +-- > if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same) +-- +graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex] +graphMap = map . fmap . mapLabelIndex -- graphMapStmt + +-- | Compare a pair of graphs for equivalence under a given mapping +-- function. +-- +-- This is used to perform the ultimate test that two graphs are +-- indeed equivalent: guesswork in `graphMatch2` means that it is +-- occasionally possible to construct a node mapping that generates +-- the required singleton equivalence classes, but does not fully +-- reflect the topology of the graphs. + +graphMapEq :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc lb] -> Bool +graphMapEq lmap gs1 gs2 = graphMap lmap gs1 `equiv` graphMap lmap gs2 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/GraphMem.hs b/src/Swish/GraphMem.hs new file mode 100644 --- /dev/null +++ b/src/Swish/GraphMem.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphMem +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : DeriveFoldable, DeriveFunctor, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses +-- +-- This module defines a simple memory-based graph instance. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Simple labelled directed graph value +------------------------------------------------------------ + +module Swish.GraphMem + ( GraphMem(..) + , LabelMem(..) + , setArcs, getArcs, addGraphs, delete, extract, labels + , labelIsVar, labelHash + -- For debug/test: + , matchGraphMem + ) where + +import Swish.GraphClass +import Swish.GraphMatch + +import Data.Hashable (Hashable(..), combine) +import Data.Monoid (Monoid(..)) +import Data.Ord (comparing) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +-- | Simple memory-based graph type. + +data GraphMem lb = GraphMem { arcs :: [Arc lb] } + deriving (Functor, F.Foldable, T.Traversable) + +instance (Label lb) => LDGraph GraphMem lb where + emptyGraph = GraphMem [] + getArcs = arcs + setArcs g as = g { arcs=as } + +instance (Label lb) => Eq (GraphMem lb) where + (==) = graphEq + +instance (Label lb) => Show (GraphMem lb) where + show = graphShow + +instance (Label lb) => Monoid (GraphMem lb) where + mempty = emptyGraph + mappend = addGraphs + +graphShow :: (Label lb) => GraphMem lb -> String +graphShow g = "Graph:" ++ foldr ((++) . ("\n " ++) . show) "" (arcs g) + +{- +toGraph :: (Label lb) => [Arc lb] -> GraphMem lb +toGraph as = GraphMem { arcs=nub as } +-} + +-- | Return Boolean graph equality + +graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool +graphEq g1 g2 = fst ( matchGraphMem g1 g2 ) + +-- | GraphMem matching function accepting GraphMem value and returning +-- node map if successful +-- +matchGraphMem :: + (Label lb) + => GraphMem lb + -> GraphMem lb + -> (Bool,LabelMap (ScopedLabel lb)) + -- ^ if the first element is @True@ then the second value is a label + -- map that maps each label to an equivalence-class identifier, + -- otherwise `emptyMap`. + -- +matchGraphMem g1 g2 = + let + gs1 = arcs g1 + gs2 = arcs g2 + matchable l1 l2 + | labelIsVar l1 && labelIsVar l2 = True + | labelIsVar l1 || labelIsVar l2 = False + | otherwise = l1 == l2 + in + graphMatch matchable gs1 gs2 + +{- +-- | Return bijection between two graphs, or empty list +graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)] +graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2) + where + lmap = graphMatch g1 g2 + sortedls g = map snd $ + (sortBy indexComp) $ + equivalenceClasses (graphLabels $ arcs g) lmap + classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2) + indexComp (g1,v1) (g2,v2) + | g1 == g2 = compare v1 v2 + | otherwise = compare g1 g2 +-} + +-- | Minimal graph label value - for testing + +data LabelMem + = LF String + | LV String + +instance Hashable LabelMem where + hash (LF l) = 1 `hashWithSalt` l + hash (LV l) = 2 `hashWithSalt` l + hashWithSalt salt (LF l) = salt `combine` 1 `hashWithSalt` l + hashWithSalt salt (LV l) = salt `combine` 2 `hashWithSalt` l + +instance Label LabelMem where + labelIsVar (LV _) = True + labelIsVar _ = False + getLocal (LV loc) = loc + getLocal lab = error "getLocal of non-variable label: " ++ show lab + makeLabel = LV + labelHash = hashWithSalt + +instance Eq LabelMem where + (LF l1) == (LF l2) = l1 == l2 + (LV l1) == (LV l2) = l1 == l2 + _ == _ = False + +instance Show LabelMem where + show (LF l1) = '!' : l1 + show (LV l2) = '?' : l2 + +instance Ord LabelMem where + compare = comparing show + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/GraphPartition.hs b/src/Swish/GraphPartition.hs new file mode 100644 --- /dev/null +++ b/src/Swish/GraphPartition.hs @@ -0,0 +1,591 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphPartition +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains functions for partitioning a graph into subgraphs +-- that rooted from different subject nodes. +-- +-------------------------------------------------------------------------------- + +module Swish.GraphPartition + ( PartitionedGraph(..), getArcs, getPartitions + , GraphPartition(..), node, toArcs + , partitionGraph, comparePartitions + , partitionShowP + ) +where + +import Swish.GraphClass (Label(..), Arc(..)) + +import Control.Monad.State (MonadState(..), State) +import Control.Monad.State (evalState) + +import Data.List (foldl', partition) +import Data.List.NonEmpty (NonEmpty(..), (<|)) +import Data.Maybe (mapMaybe) + +import qualified Data.List.NonEmpty as NE + +------------------------------------------------------------ +-- Data type for a partitioned graph +------------------------------------------------------------ + +-- |Representation of a graph as a collection of (possibly nested) +-- partitions. Each node in the graph appears at least once as the +-- root value of a 'GraphPartition' value: +-- +-- * Nodes that are the subject of at least one statement appear as +-- the first value of exactly one 'PartSub' constructor, and may +-- also appear in any number of 'PartObj' constructors. +-- +-- * Nodes appearing only as objects of statements appear only in +-- 'PartObj' constructors. + +data PartitionedGraph lb = PartitionedGraph [GraphPartition lb] + deriving (Eq,Show) + +-- | Returns all the arcs in the partitioned graph. +getArcs :: PartitionedGraph lb -> [Arc lb] +getArcs (PartitionedGraph ps) = concatMap toArcs ps + +-- | Returns a list of partitions. +getPartitions :: PartitionedGraph lb -> [GraphPartition lb] +getPartitions (PartitionedGraph ps) = ps + +-- Note: do not use the LabelledPartition local type here since we do +-- not want it to appear in the documentation. + +-- | Represent a partition of a graph by a node and (optional) contents. +data GraphPartition lb + = PartObj lb + | PartSub lb (NonEmpty (lb,GraphPartition lb)) + +-- | Returns the node for the partition. +node :: GraphPartition lb -> lb +node (PartObj ob) = ob +node (PartSub sb _) = sb + +-- | Creates a list of arcs from the partition. The empty +-- list is returned for `PartObj`. +toArcs :: GraphPartition lb -> [Arc lb] +toArcs (PartObj _) = [] +toArcs (PartSub sb prs) = concatMap toArcs1 $ NE.toList prs + where + toArcs1 (pr,ob) = Arc sb pr (node ob) : toArcs ob + +-- | Equality is based on total structural equivalence +-- rather than graph equality. +instance (Label lb) => Eq (GraphPartition lb) where + (PartObj o1) == (PartObj o2) = o1 == o2 + (PartSub s1 p1) == (PartSub s2 p2) = s1 == s2 && p1 == p2 + _ == _ = False + +instance (Label lb) => Show (GraphPartition lb) where + show = partitionShow + +-- can we just say +-- partitionShow = partitionShowP "" +-- ? +partitionShow :: (Label lb) => GraphPartition lb -> String +partitionShow (PartObj ob) = show ob +partitionShow (PartSub sb (pr :| prs)) = + "("++ show sb ++ " " ++ showpr pr ++ concatMap ((" ; "++).showpr) prs ++ ")" + where + showpr (a,b) = show a ++ " " ++ show b + +-- only used in Swish.Commands + +-- | Convert a partition into a string with a leading separator string. +partitionShowP :: + (Label lb) => + String + -> GraphPartition lb + -> String +partitionShowP _ (PartObj ob) = show ob +partitionShowP pref (PartSub sb (pr :| prs)) = + pref++"("++ show sb ++ " " ++ showpr pr ++ concatMap (((pref++" ; ")++).showpr) prs ++ ")" + where + showpr (a,b) = show a ++ " " ++ partitionShowP (pref++" ") b + +------------------------------------------------------------ +-- Creating partitioned graphs +------------------------------------------------------------ +-- +-- |Turning a partitioned graph into a flat graph is easy. +-- The interesting challenge is to turn a flat graph into a +-- partitioned graph that is more useful for certain purposes. +-- Currently, I'm interested in: +-- +-- (1) isolating differences between graphs +-- +-- (2) pretty-printing graphs +-- +-- For (1), the goal is to separate subgraphs that are known +-- to be equivalent from subgraphs that are known to be different, +-- such that: +-- +-- * different sub-graphs are minimized, +-- +-- * different +-- sub-graphs are placed into 1:1 correspondence (possibly with null +-- subgraphs), and +-- +-- * only deterministic matching decisions are made. +-- +-- For (2), the goal is to decide when a subgraph is to be treated +-- as nested in another partition, or treated as a new top-level partition. +-- If a subgraph is referenced by exactly one graph partition, it should +-- be nested in that partition, otherwise it should be a new top-level +-- partition. +-- +-- Strategy. Examining just subject and object nodes: +-- +-- * all non-blank subject nodes are the root of a top-level partition +-- +-- * blank subject nodes that are not the object of exactly one statement +-- are the root of a top-level partition. +-- +-- * blank nodes referenced as the object of exactly 1 statement +-- of an existing partition are the root of a sub-partition of the +-- refering partition. +-- +-- * what remain are circular chains of blank nodes not referenced +-- elsewhere: for each such chain, pick a root node arbitrarily. +-- +partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb +partitionGraph [] = PartitionedGraph [] +partitionGraph arcs = + makePartitions fixs topv1 intv1 + where + (fixs,vars) = partition isNonVar $ collect arcSubj arcs + vars1 = collectMore arcObj arcs vars + (intv,topv) = partition objOnce vars1 + intv1 = map stripObj intv + topv1 = map stripObj topv + isNonVar = not . labelIsVar . fst + objOnce = isSingle . snd . snd + isSingle [_] = True + isSingle _ = False + stripObj (k,(s,_)) = (k,s) + +-- Local state type for partitioning function +type LabelledArcs lb = (lb, NonEmpty (Arc lb)) +type LabelledPartition lb = (lb, GraphPartition lb) +type MakePartitionState lb = ([LabelledArcs lb], [LabelledArcs lb], [LabelledArcs lb]) +type PState lb = State (MakePartitionState lb) + +makePartitions :: + (Eq lb) => + [LabelledArcs lb] + -> [LabelledArcs lb] + -> [LabelledArcs lb] + -> PartitionedGraph lb +makePartitions fixs topv intv = + PartitionedGraph $ evalState (makePartitions1 []) (fixs,topv,intv) + +-- Use a state monad to keep track of arcs that have been incorporated into +-- the resulting list of graph partitions. The collections of arcs used to +-- generate the list of partitions are supplied as the initial state of the +-- monad (see call of evalState above). +-- +makePartitions1 :: + (Eq lb) => + [LabelledArcs lb] + -> PState lb [GraphPartition lb] +makePartitions1 [] = do + s <- pickNextSubject + if null s then return [] else makePartitions1 s +makePartitions1 (sub:subs) = do + ph <- makePartitions2 sub + pt <- makePartitions1 subs + return $ ph++pt + +makePartitions2 :: + (Eq lb) => + LabelledArcs lb + -> PState lb [GraphPartition lb] +makePartitions2 subs = do + (part,moresubs) <- makeStatements subs + moreparts <- if null moresubs + then return [] + else makePartitions1 moresubs + return $ part:moreparts + +makeStatements :: + (Eq lb) => + LabelledArcs lb + -> PState lb (GraphPartition lb, [LabelledArcs lb]) +makeStatements (sub,stmts) = do + propmore <- mapM makeStatement (NE.toList stmts) + let (props,moresubs) = unzip propmore + return (PartSub sub (NE.fromList props), concat moresubs) + -- return (PartSub sub props, concat moresubs) + +makeStatement :: + (Eq lb) => + Arc lb + -> PState lb (LabelledPartition lb, [LabelledArcs lb]) +makeStatement (Arc _ prop obj) = do + intobj <- pickIntSubject obj + (gpobj, moresubs) <- if null intobj + then do + ms <- pickVarSubject obj + return (PartObj obj,ms) + else makeStatements (head intobj) + return ((prop,gpobj), moresubs) + +pickNextSubject :: PState lb [LabelledArcs lb] +pickNextSubject = do + (a1,a2,a3) <- get + let (s,st) = case (a1,a2,a3) of + (s1h:s1t,s2,s3) -> ([s1h],(s1t,s2,s3)) + ([],s2h:s2t,s3) -> ([s2h],([],s2t,s3)) + ([],[],s3h:s3t) -> ([s3h],([],[],s3t)) + ([],[],[]) -> ([] ,([],[],[] )) + put st + return s + +pickIntSubject :: (Eq lb) => + lb + -> PState lb [LabelledArcs lb] +pickIntSubject sub = do + (s1,s2,s3) <- get + let varsub = removeBy (\x->(x==).fst) sub s3 + case varsub of + Just (vs, s3new) -> put (s1,s2,s3new) >> return [vs] + Nothing -> return [] + +pickVarSubject :: + (Eq lb) => + lb -> + PState lb [LabelledArcs lb] +pickVarSubject sub = do + (s1,s2,s3) <- get + let varsub = removeBy (\x->(x==).fst) sub s2 + case varsub of + Just (vs, s2new) -> put (s1,s2new,s3) >> return [vs] + _ -> return [] + +------------------------------------------------------------ +-- Other useful functions +------------------------------------------------------------ + +-- | Create a list of pairs of corresponding Partitions that +-- are unequal. +comparePartitions :: (Label lb) => + PartitionedGraph lb + -> PartitionedGraph lb + -> [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))] +comparePartitions (PartitionedGraph gp1) (PartitionedGraph gp2) = + comparePartitions1 (reverse gp1) (reverse gp2) + +comparePartitions1 :: (Label lb) => + [GraphPartition lb] + -> [GraphPartition lb] + -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions1 pg1 pg2 = + ds ++ [ (Just r1p,Nothing) | r1p<-r1 ] + ++ [ (Nothing,Just r2p) | r2p<-r2 ] + where + (ds,r1,r2) = listDifferences comparePartitions2 pg1 pg2 + +-- Compare two graph partitions, with three possible outcomes: +-- Nothing -> no match +-- Just [] -> total match +-- Just [...] -> partial match, with mismatched sub-partitions listed. +-- +-- A partial match occurs when the leading nodes are non-variable and +-- equal, but something else in the partition does not match. +-- +-- A complete match can be achieved with variable nodes that have +-- different labels +-- +comparePartitions2 :: (Label lb) => + GraphPartition lb + -> GraphPartition lb + -> Maybe [(Maybe (GraphPartition lb), Maybe (GraphPartition lb))] +comparePartitions2 (PartObj l1) (PartObj l2) = + if matchNodes l1 l2 then Just [] else Nothing +comparePartitions2 pg1@(PartSub l1 p1s) pg2@(PartSub l2 p2s) = + if match then comp1 else Nothing + where + comp1 = case comparePartitions3 l1 l2 p1s p2s of + Nothing -> if matchVar then Nothing + else Just [(Just pg1,Just pg2)] + Just [] -> Just [] + Just ps -> {- if matchVar then Nothing else -} Just ps + matchVar = labelIsVar l1 && labelIsVar l2 + match = matchVar || l1 == l2 +comparePartitions2 pg1 pg2 = + if not (labelIsVar l1) && l1 == l2 + then Just [(Just pg1,Just pg2)] + else Nothing + where + l1 = node pg1 + l2 = node pg2 + +comparePartitions3 :: (Label lb) => + lb + -> lb + -> NonEmpty (LabelledPartition lb) + -> NonEmpty (LabelledPartition lb) + -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions3 l1 l2 s1s s2s = Just $ + ds ++ [ (Just (PartSub l1 (r1p :| [])),Nothing) | r1p<-r1 ] + ++ [ (Nothing,Just (PartSub l2 (r2p :| []))) | r2p<-r2 ] + where + (ds,r1,r2) = listDifferences + (comparePartitions4 l1 l2) + (NE.toList s1s) + (NE.toList s2s) + +comparePartitions4 :: (Label lb) => + lb + -> lb + -> LabelledPartition lb + -> LabelledPartition lb + -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions4 _ _ (p1,o1) (p2,o2) = + if matchNodes p1 p2 then comp1 else Nothing + where + comp1 = case comparePartitions2 o1 o2 of + Nothing -> Just [(Just o1,Just o2)] + ds -> ds + +matchNodes :: (Label lb) => lb -> lb -> Bool +matchNodes l1 l2 + | labelIsVar l1 = labelIsVar l2 + | otherwise = l1 == l2 + + +------------------------------------------------------------ +-- Helpers +------------------------------------------------------------ + +-- |Collect a list of items by some comparison of a selected component +-- or other derived value. +-- +-- cmp a comparison function that determines if a pair of values +-- should be grouped together +-- sel a function that selects a value from any item +-- +-- Example: collect fst [(1,'a'),(2,'b'),(1,'c')] = +-- [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])] +-- +collect :: (Eq b) => (a->b) -> [a] -> [(b, NonEmpty a)] +collect = collectBy (==) + +collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b, NonEmpty a)] +collectBy cmp sel = map reverseCollection . collectBy1 cmp sel [] + +collectBy1 :: (b->b->Bool) -> (a->b) -> [(b, NonEmpty a)] -> [a] -> [(b, NonEmpty a)] +collectBy1 _ _ sofar [] = sofar +collectBy1 cmp sel sofar (a:as) = + collectBy1 cmp sel (collectBy2 cmp sel a sofar) as + +collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b, NonEmpty a)] -> [(b, NonEmpty a)] +collectBy2 _ sel a [] = [(sel a, a :| [])] +collectBy2 cmp sel a (col@(k,as) : cols) + | cmp ka k = (k, a <| as) : cols + | otherwise = col : collectBy2 cmp sel a cols + where + ka = sel a + +reverseCollection :: (b, NonEmpty a) -> (b, NonEmpty a) +reverseCollection (k,as) = (k, NE.reverse as) + +{- +-- Example/test: +testCollect1 :: [(Int, [(Int, Char)])] +testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')] + +testCollect2 :: Bool +testCollect2 = testCollect1 + == [ (1,[(1,'a'),(1,'c'),(1,'d')]) + , (2,[(2,'b'),(2,'d')]) + , (3,[(3,'d')]) + ] +-} + +-- |Add new values to an existing list of collections. +-- The list of collections is not extended, but each collection is +-- augmented with a further list of values from the supplied list, +-- each of which are related to the existing collection in some way. +-- +-- NOTE: the basic pattern of @collect@ and @collectMore@ is similar, +-- and might be generalized into a common set of core functions. +-- +collectMore :: (Eq b) => (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] +collectMore = collectMoreBy (==) + +collectMoreBy :: + (b->b->Bool) -> (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] +collectMoreBy cmp sel as cols = + map reverseMoreCollection $ + collectMoreBy1 cmp sel as (map (\ (b,cs) -> (b,(cs,[])) ) cols) + +collectMoreBy1 :: + (b->b->Bool) -> (a->b) -> [a] -> [(b,(c,[a]))] -> [(b,(c,[a]))] +collectMoreBy1 _ _ [] cols = cols +collectMoreBy1 cmp sel (a:as) cols = + collectMoreBy1 cmp sel as (collectMoreBy2 cmp sel a cols) + +collectMoreBy2 :: + (b->b->Bool) -> (a->b) -> a -> [(b,(c,[a]))] -> [(b,(c,[a]))] +collectMoreBy2 _ _ _ [] = [] +collectMoreBy2 cmp sel a (col@(k,(b,as)):cols) + | cmp (sel a) k = (k,(b, a:as)):cols + | otherwise = col:collectMoreBy2 cmp sel a cols + +reverseMoreCollection :: (b,(c,[a])) -> (b,(c,[a])) +reverseMoreCollection (k,(c,as)) = (k,(c,reverse as)) + +{- +-- Example/test: +testCollectMore1 = + collectMore snd [(111,1),(112,1),(211,2),(311,3),(411,4)] testCollect1 + +testCollectMore2 :: Bool +testCollectMore2 = testCollectMore1 + == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)])) + , (2,([(2,'b'),(2,'d')],[(211,2)])) + , (3,([(3,'d')],[(311,3)])) + ] +-} + +-- |Remove supplied element from a list using the supplied test +-- function, and return Just the element removed and the +-- remaining list, or Nothing if no element was matched for removal. +-- +{- +remove :: (Eq a) => a -> [a] -> Maybe (a,[a]) +remove = removeBy (==) + +testRemove1 = remove 3 [1,2,3,4,5] +testRemove2 = testRemove1 == Just (3,[1,2,4,5]) +testRemove3 = remove 3 [1,2,4,5] +testRemove4 = testRemove3 == Nothing +testRemove5 = remove 5 [1,2,4,5] +testRemove6 = testRemove5 == Just (5,[1,2,4]) +testRemove7 = remove 1 [1,2,4] +testRemove8 = testRemove7 == Just (1,[2,4]) +testRemove9 = remove 2 [2] +testRemove10 = testRemove9 == Just (2,[]) + +-} + +removeBy :: (b->a->Bool) -> b -> [a] -> Maybe (a,[a]) +removeBy cmp a0 as = removeBy1 cmp a0 as [] + +removeBy1 :: (b->a->Bool) -> b -> [a] -> [a] -> Maybe (a,[a]) +removeBy1 _ _ [] _ = Nothing +removeBy1 cmp a0 (a:as) sofar + | cmp a0 a = Just (a,reverseTo sofar as) + | otherwise = removeBy1 cmp a0 as (a:sofar) + +-- |Reverse first argument, prepending the result to the second argument +-- +reverseTo :: [a] -> [a] -> [a] +reverseTo front back = foldl' (flip (:)) back front + +-- |Remove each element from a list, returning a list of pairs, +-- each of which is the element removed and the list remaining. +-- +removeEach :: [a] -> [(a,[a])] +removeEach [] = [] +removeEach (a:as) = (a,as):[ (a1,a:a1s) | (a1,a1s) <- removeEach as ] + +{- +testRemoveEach1 = removeEach [1,2,3,4,5] +testRemoveEach2 = testRemoveEach1 == + [ (1,[2,3,4,5]) + , (2,[1,3,4,5]) + , (3,[1,2,4,5]) + , (4,[1,2,3,5]) + , (5,[1,2,3,4]) + ] +-} + +-- |List differences between the members of two lists, where corresponding +-- elements may appear at arbitrary locations in the corresponding lists. +-- +-- Elements are compared using the function 'cmp', which returns: +-- * Nothing if the elements are completely unrelated +-- * Just [] if the elements are identical +-- * Just ds if the elements are related but not identical, in which case +-- ds is a list of values describing differences between them. +-- +-- Returns (ds,u1,u2), where: +-- ds is null if the related elements from each list are identical, +-- otherwise is a list of differences between the related elements. +-- u1 is a list of elements in a1 not related to elements in a2. +-- u2 is a list of elements in a2 not related to elements in a1. +-- +listDifferences :: (a->a->Maybe [d]) -> [a] -> [a] -> ([d],[a],[a]) +listDifferences _ [] a2s = ([],[],a2s) +listDifferences cmp (a1:a1t) a2s = + case mcomp of + Nothing -> morediffs [] [a1] a1t a2s + Just (ds,a2t) -> morediffs ds [] a1t a2t + where + -- mcomp finds identical match, if there is one, or + -- the first element in a2s related to a1, or Nothing + -- [choose was listToMaybe, + -- but that didn't handle repeated properties well] + mcomp = choose $ mapMaybe maybeResult comps + comps = [ (cmp a1 a2,a2t) | (a2,a2t) <- removeEach a2s ] + maybeResult (Nothing,_) = Nothing + maybeResult (Just ds,a2t) = Just (ds,a2t) + morediffs xds xa1h xa1t xa2t = (xds++xds1,xa1h++xa1r,xa2r) + where + (xds1,xa1r,xa2r) = listDifferences cmp xa1t xa2t + choose [] = Nothing + choose ds@(d:_) = choose1 d ds + choose1 _ (d@([],_):_) = Just d + choose1 d [] = Just d + choose1 d (_:ds) = choose1 d ds + +{- +testcmp (l1,h1) (l2,h2) + | (l1 >= h2) || (l2 >= h1) = Nothing + | (l1 == l2) && (h1 == h2) = Just [] + | otherwise = Just [((l1,h1),(l2,h2))] + +testdiff1 = listDifferences testcmp + [(12,15),(1,2),(3,4),(5,8),(10,11)] + [(10,11),(0,1),(3,4),(6,9),(13,15)] +testdiff2 = testdiff1 == ([((12,15),(13,15)),((5,8),(6,9))],[(1,2)],[(0,1)]) +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Monad.hs b/src/Swish/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Monad.hs @@ -0,0 +1,262 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Monad +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, MultiParamTypeClasses +-- +-- Composed state and IO monad for Swish +-- +-------------------------------------------------------------------------------- + +module Swish.Monad + ( SwishStateIO, SwishState(..), SwishStatus(..) + , SwishFormat(..) + , NamedGraph(..) + , NamedGraphMap + -- * Create and modify the Swish state + , emptyState + , setFormat, setBase, setGraph + , modGraphs, findGraph, findFormula + , modRules, findRule + , modRulesets, findRuleset + , findOpenVarModify, findDatatype + , setInfo, resetInfo, setError, resetError + , setStatus + -- , setVerbose + -- * Error handling + , swishError + , reportLine + ) +where + +import Swish.Namespace (ScopedName, getScopeNamespace) +import Swish.QName (QName) +import Swish.Ruleset (getMaybeContextAxiom, getMaybeContextRule) +import Swish.Rule(Formula(..)) + +import Swish.RDF.Datatype (RDFDatatype) +import Swish.RDF.Graph (RDFGraph, emptyRDFGraph) +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleMap, RDFRuleset, RDFRulesetMap) +import Swish.RDF.VarBinding (RDFOpenVarBindingModify) + +import Swish.RDF.BuiltIn (findRDFOpenVarBindingModifier, findRDFDatatype, rdfRulesetMap) + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (StateT(..), modify) + +import Data.LookupMap (LookupEntryClass(..), LookupMap(..)) +import Data.LookupMap (emptyLookupMap, mapFindMaybe, mapVals) + +import System.IO (hPutStrLn, stderr) + +{-| +The supported input and output formats. +-} +data SwishFormat = + Turtle -- ^ Turtle format + | N3 -- ^ N3 format + | NT -- ^ NTriples format + deriving Eq + +instance Show SwishFormat where + show N3 = "N3" + show NT = "Ntriples" + show Turtle = "Turtle" + -- show RDF = "RDF/XML" + +-- | The State for a Swish \"program\". + +data SwishState = SwishState + { format :: SwishFormat -- ^ format to use for I/O + , base :: Maybe QName -- ^ base to use rather than file name + , graph :: RDFGraph -- ^ current graph + , graphs :: NamedGraphMap -- ^ script processor named graphs + , rules :: RDFRuleMap -- ^ script processor named rules + , rulesets :: RDFRulesetMap -- ^ script processor rulesets + , infomsg :: Maybe String -- ^ information message, or Nothing + , errormsg :: Maybe String -- ^ error message, or Nothing + , exitcode :: SwishStatus -- ^ current status + } + +-- | Status of the processor +-- +data SwishStatus = + SwishSuccess -- ^ successful run + | SwishGraphCompareError -- ^ graphs do not compare + | SwishDataInputError -- ^ input data problem (ie format/syntax) + | SwishDataAccessError -- ^ data access error + | SwishArgumentError -- ^ command-line argument error + | SwishExecutionError -- ^ error executing a Swish script + deriving (Eq, Enum) + +instance Show SwishStatus where + show SwishSuccess = "Success." + show SwishGraphCompareError = "The graphs do not compare as equal." + show SwishDataInputError = "There was a format or syntax error in the input data." + show SwishDataAccessError = "There was a problem accessing data." + show SwishArgumentError = "Argument error: use -h or -? for help." + show SwishExecutionError = "There was a problem executing a Swish script." + +-- | The state monad used in executing Swish programs. +type SwishStateIO a = StateT SwishState IO a + +-- | The default state for Swish: no loaded graphs or rules, and format +-- set to 'N3'. +emptyState :: SwishState +emptyState = SwishState + { format = N3 + , base = Nothing + , graph = emptyRDFGraph + , graphs = emptyLookupMap + , rules = emptyLookupMap + , rulesets = rdfRulesetMap + , infomsg = Nothing + , errormsg = Nothing + , exitcode = SwishSuccess + } + +-- | Change the format. +setFormat :: SwishFormat -> SwishState -> SwishState +setFormat fm state = state { format = fm } + +-- | Change (or remove) the base URI. +setBase :: Maybe QName -> SwishState -> SwishState +setBase bs state = state { base = bs } + +-- | Change the current graph. +setGraph :: RDFGraph -> SwishState -> SwishState +setGraph gr state = state { graph = gr } + +-- | Modify the named graphs. +modGraphs :: + ( NamedGraphMap -> NamedGraphMap ) -> SwishState -> SwishState +modGraphs grmod state = state { graphs = grmod (graphs state) } + +-- | Find a named graph. +findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph] +findGraph nam state = mapFindMaybe nam (graphs state) + +-- | Find a formula. The search is first made in the named graphs +-- and then, if not found, the rulesets. +findFormula :: ScopedName -> SwishState -> Maybe RDFFormula +findFormula nam state = case findGraph nam state of + Nothing -> getMaybeContextAxiom nam (mapVals $ rulesets state) + Just [] -> Just $ Formula nam emptyRDFGraph + Just grs -> Just $ Formula nam (head grs) + +-- | Modify the named rules. +modRules :: + ( RDFRuleMap -> RDFRuleMap ) -> SwishState -> SwishState +modRules rlmod state = state { rules = rlmod (rules state) } + +-- | Find a named rule. +findRule :: ScopedName -> SwishState -> Maybe RDFRule +findRule nam state = + case mapFindMaybe nam (rules state) of + Nothing -> getMaybeContextRule nam $ mapVals $ rulesets state + justlr -> justlr + +-- | Modify the rule sets. +modRulesets :: + ( RDFRulesetMap -> RDFRulesetMap ) -> SwishState -> SwishState +modRulesets rsmod state = state { rulesets = rsmod (rulesets state) } + +-- | Find a rule set. +findRuleset :: + ScopedName -> SwishState -> Maybe RDFRuleset +findRuleset nam state = mapFindMaybe (getScopeNamespace nam) (rulesets state) + +-- | Find a modify rule. +findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify +findOpenVarModify nam _ = findRDFOpenVarBindingModifier nam + +-- | Find a data type declaration. +findDatatype :: ScopedName -> SwishState -> Maybe RDFDatatype +findDatatype nam _ = findRDFDatatype nam + +-- | Set the information message. +setInfo :: String -> SwishState -> SwishState +setInfo msg state = state { infomsg = Just msg } + +-- | Clear the information message. +resetInfo :: SwishState -> SwishState +resetInfo state = state { infomsg = Nothing } + +-- | Set the error message. +setError :: String -> SwishState -> SwishState +setError msg state = state { errormsg = Just msg } + +-- | Clear the error message. +resetError :: SwishState -> SwishState +resetError state = state { errormsg = Nothing } + +-- | Set the status. +setStatus :: SwishStatus -> SwishState -> SwishState +setStatus ec state = state { exitcode = ec } + +{- +setVerbose :: Bool -> SwishState -> SwishState +setVerbose f state = state { banner = f } +-} + +-- | The graphs dictionary contains named graphs and/or lists +-- of graphs that are created and used by script statements. + +data NamedGraph = NamedGraph + { ngName :: ScopedName + , ngGraph :: [RDFGraph] + } + +instance LookupEntryClass NamedGraph ScopedName [RDFGraph] + where + keyVal (NamedGraph k v) = (k,v) + newEntry (k,v) = NamedGraph k v + +-- | A LookupMap for the graphs dictionary. +type NamedGraphMap = LookupMap NamedGraph + +-- | Report error and set exit status code + +swishError :: String -> SwishStatus -> SwishStateIO () +swishError msg sts = do + mapM_ reportLine [msg, show sts ++ "\n"] + modify $ setStatus sts + +-- | Output the text to the standard error stream (a new line is +-- added to the output). +reportLine :: String -> SwishStateIO () +reportLine = lift . hPutStrLn stderr + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Namespace.hs b/src/Swish/Namespace.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Namespace.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Namespace +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TypeSynonymInstances +-- +-- This module defines algebraic datatypes for namespaces and scoped names. +-- +-- For these purposes, a namespace is a prefix and URI used to identify +-- a namespace (cf. XML namespaces), and a scoped name is a name that +-- is scoped by a specified namespace. +-- +-------------------------------------------------------------------------------- + +module Swish.Namespace + ( Namespace + , makeNamespace, makeNamespaceQName + , getNamespacePrefix, getNamespaceURI, getNamespaceTuple + -- , nullNamespace + , ScopedName + , getScopeNamespace, getScopeLocal + , getScopePrefix, getScopeURI + , getQName, getScopedNameURI + , matchName + , makeScopedName + , makeQNameScopedName + , makeURIScopedName + , makeNSScopedName + , nullScopedName + , namespaceToBuilder + ) + where + +import Swish.QName (QName, LName, newQName, getLName, emptyLName, getQNameURI, getNamespace, getLocalName) + +import Data.LookupMap (LookupEntryClass(..)) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) +import Data.String (IsString(..)) + +import Network.URI (URI(..), parseURIReference, nullURI) + +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Namespace, having a prefix and a URI +------------------------------------------------------------ + +-- |A NameSpace value consists of an optional prefix and a corresponding URI. +-- + +data Namespace = Namespace (Maybe T.Text) URI +-- data Namespace = Namespace (Maybe T.Text) !URI +-- TODO: look at interning the URI + +-- | Returns the prefix stored in the name space. +getNamespacePrefix :: Namespace -> Maybe T.Text +getNamespacePrefix (Namespace p _) = p + +-- | Returns the URI stored in the name space. +getNamespaceURI :: Namespace -> URI +getNamespaceURI (Namespace _ u) = u + +-- | Convert the name space to a (prefix, URI) tuple. +getNamespaceTuple :: Namespace -> (Maybe T.Text, URI) +getNamespaceTuple (Namespace p u) = (p, u) + +-- | Equality is defined by the URI, not by the prefix +-- (so the same URI with different prefixes will be +-- considered to be equal). +instance Eq Namespace where + (Namespace _ u1) == (Namespace _ u2) = u1 == u2 + +instance Show Namespace where + show (Namespace (Just p) u) = show p ++ ":<" ++ show u ++ ">" + show (Namespace _ u) = "<" ++ show u ++ ">" + +instance LookupEntryClass Namespace (Maybe T.Text) URI where + keyVal (Namespace pre uri) = (pre,uri) + newEntry (pre,uri) = Namespace pre uri + +-- | Create a name space from a URI and an optional prefix label. +makeNamespace :: + Maybe T.Text -- ^ optional prefix. + -> URI -- ^ URI. + -> Namespace +makeNamespace = Namespace + +-- | Create a qualified name by combining the URI from +-- the name space with a local component. +makeNamespaceQName :: + Namespace -- ^ The name space URI is used in the qualified name + -> LName -- ^ local component of the qualified name (can be 'emptyLName') + -> QName +makeNamespaceQName (Namespace _ uri) = newQName uri + +{- +nullNamespace :: Namespace +nullNamespace = Namespace Nothing "" +-} + +-- | Utility routine to create a \@prefix line (matching N3/Turtle) +-- grammar for this namespace. +-- +namespaceToBuilder :: Namespace -> B.Builder +namespaceToBuilder (Namespace pre uri) = + mconcat $ map B.fromText + [ "@prefix ", fromMaybe "" pre, ": <", T.pack (show uri), "> .\n"] + +------------------------------------------------------------ +-- ScopedName, made from a namespace and a local name +------------------------------------------------------------ + +-- | A full ScopedName value has a QName prefix, namespace URI +-- and a local part. ScopedName values may omit the prefix +-- (see 'Namespace') or the local part. +-- +-- Some applications may handle null namespace URIs as meaning +-- the local part is relative to some base URI. +-- +data ScopedName = ScopedName !QName Namespace LName + +-- | Returns the local part. +getScopeLocal :: ScopedName -> LName +getScopeLocal (ScopedName _ _ l) = l + +-- | Returns the namespace. +getScopeNamespace :: ScopedName -> Namespace +getScopeNamespace (ScopedName _ ns _) = ns + +-- | Returns the prefix of the namespace, if set. +getScopePrefix :: ScopedName -> Maybe T.Text +getScopePrefix = getNamespacePrefix . getScopeNamespace + +-- | Returns the URI of the namespace. +getScopeURI :: ScopedName -> URI +getScopeURI = getNamespaceURI . getScopeNamespace + +-- | This is not total since it will fail if the input string is not a valid URI. +instance IsString ScopedName where + fromString s = + maybe (error ("Unable to convert " ++ s ++ " into a ScopedName")) + makeURIScopedName (parseURIReference s) + +-- | Scoped names are equal if their corresponding QNames are equal +instance Eq ScopedName where + (ScopedName qn1 _ _) == (ScopedName qn2 _ _) = qn1 == qn2 + +-- | Scoped names are ordered by their QNames +instance Ord ScopedName where + (ScopedName qn1 _ _) <= (ScopedName qn2 _ _) = qn1 <= qn2 + +-- | If there is a namespace associated then the Show instance +-- uses @prefix:local@, otherwise @@. +instance Show ScopedName where + show (ScopedName qn n l) = case getNamespacePrefix n of + Just pre -> T.unpack $ mconcat [pre, ":", getLName l] + _ -> show qn -- "<" ++ show (getNamespaceURI n) ++ T.unpack l ++ ">" + +-- |Get the QName corresponding to a scoped name. +getQName :: ScopedName -> QName +getQName (ScopedName qn _ _) = qn + +-- |Get URI corresponding to a scoped name (using RDF conventions). +getScopedNameURI :: ScopedName -> URI +getScopedNameURI = getQNameURI . getQName + +-- |Test if supplied string matches the display form of a +-- scoped name. +matchName :: String -> ScopedName -> Bool +matchName str nam = str == show nam + +-- |Construct a ScopedName. +makeScopedName :: + Maybe T.Text -- ^ prefix for the namespace + -> URI -- ^ namespace + -> LName -- ^ local name + -> ScopedName +makeScopedName pre nsuri local = + ScopedName (newQName nsuri local) + (Namespace pre nsuri) + local + +-- |Construct a ScopedName from a QName. +makeQNameScopedName :: + Maybe T.Text -- ^ prefix + -> QName + -> ScopedName +makeQNameScopedName pre qn = ScopedName qn (Namespace pre (getNamespace qn)) (getLocalName qn) + +-- could use qnameFromURI to find a local name if there is one. + +-- | Construct a ScopedName for a bare URI (the label is set to \"\"). +makeURIScopedName :: URI -> ScopedName +makeURIScopedName uri = makeScopedName Nothing uri emptyLName + +-- | Construct a ScopedName. +makeNSScopedName :: + Namespace -- ^ namespace + -> LName -- ^ local component + -> ScopedName +makeNSScopedName ns local = + ScopedName (newQName (getNamespaceURI ns) local) ns local + +-- | This should never appear as a valid name +nullScopedName :: ScopedName +nullScopedName = makeURIScopedName nullURI + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Proof.hs b/src/Swish/Proof.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Proof.hs @@ -0,0 +1,293 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Proof +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines a framework for constructing proofs +-- over some expression form. It is intended to be used +-- with RDF graphs, but the structures aim to be quite +-- generic with respect to the expression forms allowed. +-- +-- It does not define any proof-finding strategy. +-- +-------------------------------------------------------------------------------- + +module Swish.Proof + ( Proof(..), Step(..) + , checkProof, explainProof, checkStep, showProof, showsProof, showsFormula ) +where + +import Swish.Rule (Expression(..), Formula(..), Rule(..)) +import Swish.Rule (showsFormula, showsFormulae) +import Swish.Ruleset (Ruleset(..)) + +import Swish.Utils.ListHelpers (subset) + +import Data.List (union, intersect, intercalate, foldl') +import Data.Maybe (catMaybes, isNothing) +import Data.String.ShowLines (ShowLines(..)) + +------------------------------------------------------------ +-- Proof framework +------------------------------------------------------------ + +-- |Step in proof chain +-- +-- The display name for a proof step comes from the display name of its +-- consequence formula. +data Step ex = Step + { stepRule :: Rule ex -- ^ Inference rule used + , stepAnt :: [Formula ex] -- ^ Antecedents of inference rule + , stepCon :: Formula ex -- ^ Named consequence of inference rule + } deriving Show + +-- |Proof is a structure that presents a chain of rule applications +-- that yield a result expression from a given expression +data Proof ex = Proof + { proofContext :: [Ruleset ex] -- ^ Proof context: list of rulesets, + -- each of which provides a number of + -- axioms and rules. + , proofInput :: Formula ex -- ^ Given expression + , proofResult :: Formula ex -- ^ Result expression + , proofChain :: [Step ex] -- ^ Chain of inference rule applications + -- progressing from input to result + } + +-- |Return a list of axioms from all the rulesets in a proof +proofAxioms :: Proof a -> [Formula a] +proofAxioms = concatMap rsAxioms . proofContext + +-- |Return a list of rules from all the rulesets in a proof +proofRules :: Proof a -> [Rule a] +proofRules = concatMap rsRules . proofContext + +-- |Return list of axioms actually referenced by a proof +proofAxiomsUsed :: Proof ex -> [Formula ex] +proofAxiomsUsed proof = foldl' union [] $ map stepAxioms (proofChain proof) + where + stepAxioms st = stepAnt st `intersect` proofAxioms proof + +-- |Check consistency of given proof. +-- The supplied rules and axioms are assumed to be correct. +checkProof :: (Expression ex) => Proof ex -> Bool +checkProof pr = + checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr + where + initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) + goalExpr = formExpr $ proofResult pr + +checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool +checkProof1 _ prev [] res = res `elem` prev +checkProof1 rules prev (st:steps) res = + checkStep rules prev st && + checkProof1 rules (formExpr (stepCon st):prev) steps res + +-- | A proof step is valid if rule is in list of rules +-- and the antecedents are sufficient to obtain the conclusion +-- and the antecedents are in the list of formulae already proven. +-- +-- Note: this function depends on the ruleName of any rule being +-- unique among all rules. In particular the name of the step rule +-- being in correspondence with the name of one of the indicated +-- valid rules of inference. +checkStep :: + (Expression ex) + => [Rule ex] -- ^ rules + -> [ex] -- ^ antecedants + -> Step ex -- ^ the step to validate + -> Bool -- ^ @True@ if the step is valid + +checkStep rules prev step = isNothing $ explainStep rules prev step + +{- + +Is the following an optimisation of the above? + +checkStep rules prev step = + -- Rule name is one of supplied rules, and + (ruleName srul `elem` map ruleName rules) && + -- Antecedent expressions are all previously accepted expressions + (sant `subset` prev) && + -- Inference rule yields concequence from antecendents + checkInference srul sant scon + where + -- Rule from proof step: + srul = stepRule step + -- Antecedent expressions from proof step: + sant = map formExpr $ stepAnt step + -- Consequentent expression from proof step: + scon = formExpr $ stepCon step +-} + + +{- + (formExpr (stepCon step) `elem` sfwd) + -- (or $ map (`subset` sant) sbwd) + where + -- Rule from proof step: + srul = stepRule step + -- Antecedent expressions from proof step: + sant = map formExpr $ stepAnt step + -- Forward chaining from antecedents of proof step + scon = map formExpr $ stepCon step + -- Forward chaining from antecedents of proof step + + sfwd = fwdApply srul sant + -- Backward chaining from consequent of proof step + -- (Does not work because of introduction of existentials) + sbwd = bwdApply srul (formExpr $ stepCon step) +-} + +-- |Check proof. If there is an error then return information +-- about the failing step. +explainProof :: + (Expression ex) => Proof ex -> Maybe String +explainProof pr = + explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr + where + initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) + goalExpr = formExpr $ proofResult pr + +explainProof1 :: + (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String +explainProof1 _ prev [] res = + if res `elem` prev then Nothing else Just "Result not demonstrated" +explainProof1 rules prev (st:steps) res = + case explainStep rules prev st of + Nothing -> explainProof1 rules (formExpr (stepCon st):prev) steps res + Just ex -> Just ("Invalid step: "++show (formName $ stepCon st)++": "++ex) + +-- | A proof step is valid if rule is in list of rules +-- and the antecedents are sufficient to obtain the conclusion +-- and the antecedents are in the list of formulae already proven. +-- +-- Note: this function depends on the ruleName of any rule being +-- unique among all rules. In particular the name of the step rule +-- being in correspondence with the name of one of the indicated +-- valid rules of inference. +-- +explainStep :: + (Expression ex) + => [Rule ex] -- ^ rules + -> [ex] -- ^ previous + -> Step ex -- ^ step + -> Maybe String -- ^ @Nothing@ if step is okay, otherwise a string indicating the error +explainStep rules prev step = + if null errors then Nothing else Just $ intercalate ", " errors + where + -- Rule from proof step: + srul = stepRule step + -- Antecedent expressions from proof step: + sant = map formExpr $ stepAnt step + -- Consequentent expression from proof step: + scon = formExpr $ stepCon step + -- Tests for step to be valid + errors = catMaybes + -- Rule name is one of supplied rules, and + [ require (ruleName srul `elem` map ruleName rules) + ("rule "++show (ruleName srul)++" not present") + -- Antecedent expressions are all previously accepted expressions + , require (sant `subset` prev) + "antecedent not axiom or previous result" + -- Inference rule yields consequence from antecedents + , require (checkInference srul sant scon) + "rule does not deduce consequence from antecedents" + ] + require b s = if b then Nothing else Just s + +-- |Create a displayable form of a proof, returned as a `ShowS` value. +-- +-- This function is intended to allow the calling function some control +-- of multiline displays by providing: +-- +-- (1) the first line of the proof is not preceded by any text, so +-- it may be appended to some preceding text on the same line, +-- +-- (2) the supplied newline string is used to separate lines of the +-- formatted text, and may include any desired indentation, and +-- +-- (3) no newline is output following the final line of text. +showsProof :: + (ShowLines ex) + => String -- ^ newline string + -> Proof ex + -> ShowS +showsProof newline proof = + if null axioms then shProof else shAxioms . shProof + where + axioms = proofAxiomsUsed proof + shAxioms = + showString ("Axioms:" ++ newline) . + showsFormulae newline (proofAxiomsUsed proof) newline + shProof = + showString ("Input:" ++ newline) . + showsFormula newline (proofInput proof) . + showString (newline ++ "Proof:" ++ newline) . + showsSteps newline (proofChain proof) + +-- |Returns a simple string representation of a proof. +showProof :: + (ShowLines ex) + => String -- ^ newline string + -> Proof ex + -> String +showProof newline proof = showsProof newline proof "" + +-- |Create a displayable form of a list of labelled proof steps +showsSteps :: (ShowLines ex) => String -> [Step ex] -> ShowS +showsSteps _ [] = id +showsSteps newline [s] = showsStep newline s +showsSteps newline (s:ss) = showsStep newline s . + showString newline . + showsSteps newline ss + +-- |Create a displayable form of a labelled proof step. +showsStep :: (ShowLines ex) => String -> Step ex -> ShowS +showsStep newline s = showsFormula newline (stepCon s) . + showString newline . + showString (" (by ["++rulename++"] from "++antnames++")") + where + rulename = show . ruleName $ stepRule s + antnames = showNames $ map (show . formName) (stepAnt s) + +-- |Return a string containing a list of names. +showNames :: [String] -> String +showNames [] = "" +showNames [n] = showName n +showNames [n1,n2] = showName n1 ++ " and " ++ showName n2 +showNames (n1:ns) = showName n1 ++ ", " ++ showNames ns + +-- |Return a string representing a single name. +showName :: String -> String +showName n = "["++n++"]" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/QName.hs b/src/Swish/QName.hs new file mode 100644 --- /dev/null +++ b/src/Swish/QName.hs @@ -0,0 +1,328 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : QName +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines an algebraic datatype for qualified names (QNames). +-- +-------------------------------------------------------------------------------- + +-- At present we support using URI references rather than forcing an absolute +-- URI. This is partly to support the existing tests (too lazy to resolve whether +-- the tests really should be using relative URIs in this case). + +module Swish.QName + ( QName + , LName + , emptyLName + , newLName + , getLName + , newQName + , qnameFromURI + , getNamespace + , getLocalName + , getQNameURI + , qnameFromFilePath + ) + where + +import Control.Monad (liftM) + +import Data.String (IsString(..)) +import Data.Maybe (fromMaybe) +import Data.Interned (intern, unintern) +import Data.Interned.URI (InternedURI) + +import Network.URI (URI(..), URIAuth(..), parseURIReference) + +import System.Directory (canonicalizePath) +import System.FilePath (splitFileName) + +import qualified Data.Text as T + +------------------------------------------------------------ +-- Qualified name +------------------------------------------------------------ +-- +-- These are RDF QNames rather than XML ones (as much as +-- RDF can claim to have them). +-- + + +{-| A local name, which can be empty. + +At present, the local name can not +contain spaces or the \'#\', \':\', or \'/\' characters. This restriction is +experimental. +-} +newtype LName = LName T.Text + deriving (Eq, Ord) + +instance Show LName where + show (LName t) = show t + +-- | This is not total since attempting to convert a string +-- containing invalid characters will cause an error. +instance IsString LName where + fromString s = + fromMaybe (error ("Invalid local name: " ++ s)) $ + newLName (T.pack s) + +-- | The empty local name. +emptyLName :: LName +emptyLName = LName "" + +-- | Create a local name. +newLName :: T.Text -> Maybe LName +newLName l = if T.any (`elem` " #:/") l then Nothing else Just (LName l) + +-- | Extract the local name. +getLName :: LName -> T.Text +getLName (LName l) = l + +{-| + +A qualified name, consisting of a namespace URI +and the local part of the identifier, which can be empty. +The serialisation of a QName is formed by concatanating the +two components. + +> Prelude> :set prompt "swish> " +> swish> :set -XOverloadedStrings +> swish> :m + Swish.QName +> swish> let qn1 = "http://example.com/" :: QName +> swish> let qn2 = "http://example.com/bob" :: QName +> swish> let qn3 = "http://example.com/bob/fred" :: QName +> swish> let qn4 = "http://example.com/bob/fred#x" :: QName +> swish> map getLocalName [qn1, qn2, qn3, qn4] +> ["","bob","fred","x"] +> swish> getNamespace qn1 +> http://example.com +> swish> getNamespace qn2 +> http://example.com +> swish> getNamespace qn3 +> http://example.com/bob/ +> swish> getNamespace qn4 +> http://example.com/bob/fred# + +-} + +{- +For now I have added in storing the actual URI +as well as the namespace component. This may or +may not be a good idea (space vs time saving). +-} + +data QName = QName !InternedURI URI LName + +-- | This is not total since it will fail if the input string is not a valid URI. +instance IsString QName where + fromString s = + fromMaybe (error ("QName conversion given an invalid URI: " ++ s)) + (parseURIReference s >>= qnameFromURI) + +-- | Equality is determined by a case sensitive comparison of the +-- URI. +instance Eq QName where + -- see qnEq comments below + (QName u1 _ _) == (QName u2 _ _) = u1 == u2 + +-- ugly, use show instance OR switch to the ordering of InternedURI + +-- | At present the ordering is based on a comparison of the @Show@ +-- instance of the URI. +instance Ord QName where + {- + (QName u1 l1) <= (QName u2 l2) = + if up1 /= up2 then up1 <= up2 else (ur1++l1) <= (ur2++l2) + where + n = min (length u1) (length u2) + (up1,ur1) = splitAt n u1 + (up2,ur2) = splitAt n u2 + -} + + -- TODO: which is faster? + -- Now we have changed to InternedURI, we could use the + -- Ord instance of it, but it is unclear to me what the + -- ordering means in that case, and whether the semantics + -- matter here? + (QName u1 _ _) <= (QName u2 _ _) = show u1 <= show u2 + + {- + (QName _ uri1 l1) <= (QName _ uri2 l2) = + if up1 /= up2 then up1 <= up2 else (ur1 ++ T.unpack l1) <= (ur2 ++ T.unpack l2) + where + u1 = show uri1 + u2 = show uri2 + + n = min (length u1) (length u2) + (up1,ur1) = splitAt n u1 + (up2,ur2) = splitAt n u2 + -} + +-- | The format used to display the URI is @\@. +instance Show QName where + show (QName u _ _) = "<" ++ show u ++ ">" + +{- +The assumption in QName is that the validation done in creating +the local name is sufficient to ensure that the combined +URI is syntactically valid. Is this in fact true? +-} + +-- | Create a new qualified name with an explicit local component. +-- +newQName :: + URI -- ^ Namespace + -> LName -- ^ Local component + -> QName +newQName ns l@(LName local) = + -- Until profiling shows that this is a time/space issue, we use + -- the following code rather than trying to deconstruct the URI + -- directly + let lstr = T.unpack local + uristr = show ns ++ lstr + in case parseURIReference uristr of + Just uri -> QName (intern uri) ns l + _ -> error $ "Unable to combine " ++ show ns ++ " with " ++ lstr + +{- + +old behavior + + splitQname "http://example.org/aaa#bbb" = ("http://example.org/aaa#","bbb") + splitQname "http://example.org/aaa/bbb" = ("http://example.org/aaa/","bbb") + splitQname "http://example.org/aaa/" = ("http://example.org/aaa/","") + +Should "urn:foo:bar" have a local name of "" or "foo:bar"? For now go +with the first option. + +-} + +-- | Create a new qualified name. +qnameFromURI :: + URI -- ^ The URI will be deconstructed to find if it contains a local component. + -> Maybe QName -- ^ The failure case may be removed. +qnameFromURI uri = + let uf = uriFragment uri + up = uriPath uri + q0 = Just $ QName iuri uri emptyLName + start = QName iuri + iuri = intern uri + in case uf of + "#" -> q0 + '#':xs -> start (uri {uriFragment = "#"}) `liftM` newLName (T.pack xs) + "" -> case break (=='/') (reverse up) of + ("",_) -> q0 -- path ends in / or is empty + (_,"") -> q0 -- path contains no / + (rlname,rpath) -> + start (uri {uriPath = reverse rpath}) `liftM` + newLName (T.pack (reverse rlname)) + + -- e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" + _ -> Nothing + +-- | Return the URI of the namespace stored in the QName. +-- This does not contain the local component. +-- +getNamespace :: QName -> URI +getNamespace (QName _ ns _) = ns + +-- | Return the local component of the QName. +getLocalName :: QName -> LName +getLocalName (QName _ _ l) = l + +-- | Returns the full URI of the QName (ie the combination of the +-- namespace and local components). +getQNameURI :: QName -> URI +getQNameURI (QName u _ _) = unintern u + +{- +Original used comparison of concatenated strings, +but that was very inefficient. The longer version below +does the comparison without constructing new values but is +no longer valid with the namespace being stored as a URI, +so for now just compare the overall URIs and we can +optimize this at a later date if needed. +qnEq :: QName -> QName -> Bool +qnEq (QName u1 _ _) (QName u2 _ _) = u1 == u2 + +qnEq (QName _ n1 l1) (QName _ n2 l2) = qnEq1 n1 n2 l1 l2 + where + qnEq1 (c1:ns1) (c2:ns2) ln1 ln2 = c1==c2 && qnEq1 ns1 ns2 ln1 ln2 + qnEq1 [] ns2 ln1@(_:_) ln2 = qnEq1 ln1 ns2 [] ln2 + qnEq1 ns1 [] ln1 ln2@(_:_) = qnEq1 ns1 ln2 ln1 [] + qnEq1 [] [] [] [] = True + qnEq1 _ _ _ _ = False +-} + +{-| +Convert a filepath to a file: URI stored in a QName. If the +input file path is relative then the current working directory is used +to convert it into an absolute path. + +If the input represents a directory then it *must* end in +the directory separator - so for Posix systems use +@\"\/foo\/bar\/\"@ rather than +@\"\/foo\/bar\"@. + +This has not been tested on Windows. +-} + +{- +NOTE: not sure why I say directories should end in the path +seperator since + +ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text" +"/Users/dburke/haskell/swish-text" +ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text/" +"/Users/dburke/haskell/swish-text" + +-} + +qnameFromFilePath :: FilePath -> IO QName +qnameFromFilePath fname = do + ipath <- canonicalizePath fname + let (dname, lname) = splitFileName ipath + nsuri = URI "file:" emptyAuth dname "" "" + uri = URI "file:" emptyAuth ipath "" "" + case lname of + "" -> return $ QName (intern nsuri) nsuri emptyLName + _ -> return $ QName (intern uri) nsuri (LName (T.pack lname)) + +emptyAuth :: Maybe URIAuth +emptyAuth = Just $ URIAuth "" "" "" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF.hs b/src/Swish/RDF.hs --- a/src/Swish/RDF.hs +++ b/src/Swish/RDF.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDF --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -11,17 +11,18 @@ -- Portability : FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances -- -- This module provides an in-memory RDF Graph (it re-exports --- "Swish.RDF.RDFGraph"). +-- "Swish.RDF.Graph"). -- -------------------------------------------------------------------------------- -module Swish.RDF (module Swish.RDF.RDFGraph) where +module Swish.RDF (module Swish.RDF.Graph) where -import Swish.RDF.RDFGraph +import Swish.RDF.Graph -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/BuiltIn.hs b/src/Swish/RDF/BuiltIn.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/BuiltIn.hs @@ -0,0 +1,53 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : BuiltIn +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- datatypes, variable binding modifiers and variable binding filters +-- built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltIn + ( findRDFOpenVarBindingModifier + , findRDFDatatype + , rdfRulesetMap + , allRulesets, allDatatypeRulesets + ) +where + +import Swish.RDF.BuiltIn.Datatypes +import Swish.RDF.BuiltIn.Rules + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/BuiltIn/Datatypes.hs b/src/Swish/RDF/BuiltIn/Datatypes.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/BuiltIn/Datatypes.hs @@ -0,0 +1,81 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Datatypes +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- datatypes built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltIn.Datatypes + ( allDatatypes, findRDFDatatype ) + where + +import Swish.Namespace (ScopedName) + +import Swish.RDF.Datatype (RDFDatatype) + +import Swish.RDF.Datatype.XSD.String (rdfDatatypeXsdString) +import Swish.RDF.Datatype.XSD.Integer (rdfDatatypeXsdInteger) +import Swish.RDF.Datatype.XSD.Decimal (rdfDatatypeXsdDecimal) + +import Data.LookupMap (LookupMap(..), mapFindMaybe) + +------------------------------------------------------------ +-- Declare datatype map +------------------------------------------------------------ + +-- | Al the data type declarations built into Swish. +allDatatypes :: [RDFDatatype] +allDatatypes = + [ rdfDatatypeXsdString + , rdfDatatypeXsdInteger + , rdfDatatypeXsdDecimal + ] + +-- | Look up a data type declaration. +findRDFDatatype :: ScopedName -> Maybe RDFDatatype +findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes) + +------------------------------------------------------------ +-- Declare datatype subtypes map +------------------------------------------------------------ + +{- +allDatatypeSubtypes :: [xxx] +allDatatypeSubtypes = [] +-- [[[details TBD]]] +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/BuiltIn/Rules.hs b/src/Swish/RDF/BuiltIn/Rules.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/BuiltIn/Rules.hs @@ -0,0 +1,153 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Rules +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- rulesets, variable binding modifiers and variable binding filters +-- built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltIn.Rules + ( findRDFOpenVarBindingModifier + , rdfRulesetMap + , allRulesets, allDatatypeRulesets + ) +where + +import Swish.Datatype (typeRules, typeMkModifiers) +import Swish.Namespace (ScopedName) +import Swish.VarBinding (nullVarBindingModify, makeVarFilterModify, varFilterEQ, varFilterNE) + +import Swish.RDF.BuiltIn.Datatypes (allDatatypes) +import Swish.RDF.Ruleset (RDFRuleset, RDFRulesetMap) +import Swish.RDF.ProofContext (rulesetRDF, rulesetRDFS, rulesetRDFD) + +import Swish.RDF.VarBinding + ( RDFOpenVarBindingModify + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) + +import Data.LookupMap (LookupMap(..), mapFindMaybe) + +------------------------------------------------------------ +-- Declare variable binding filters list +------------------------------------------------------------ + +-- |List of rdfOpenVarBindingModify values for predefined filters +-- +rdfVarBindingFilters :: [RDFOpenVarBindingModify] +rdfVarBindingFilters = + [ filter1 rdfVarBindingUriRef + , filter1 rdfVarBindingBlank + , filter1 rdfVarBindingLiteral + , filter1 rdfVarBindingUntypedLiteral + , filter1 rdfVarBindingTypedLiteral + , filter1 rdfVarBindingXMLLiteral + , filter1 rdfVarBindingMemberProp + , filter2 rdfVarBindingDatatyped + -- , filterN nullVarBindingModify + , filter2 varFilterEQ + , filter2 varFilterNE + ] + where + -- Swish.RDF.VarBinding.openVbmName seems to require that the label + -- list not be evaluated which means that we can not replace these + -- statements by ones like + -- + -- filter1 f (lb:_) = makeVarFilterModift $ f lb + -- + filter1 f lbs = makeVarFilterModify $ f (head lbs) + filter2 f lbs = makeVarFilterModify $ f (head lbs) (lbs!!1) + -- filterN f lbs = makeVarFilterModify $ f ... + +------------------------------------------------------------ +-- Declare variable binding modifiers map +------------------------------------------------------------ + +rdfVarBindingModifiers :: [RDFOpenVarBindingModify] +rdfVarBindingModifiers = + [ nullVarBindingModify + ] + +------------------------------------------------------------ +-- Find a named built-in OpenVarBindingModifier +------------------------------------------------------------ + +allOpenVarBindingModify :: [RDFOpenVarBindingModify] +allOpenVarBindingModify = + rdfVarBindingFilters ++ + rdfVarBindingModifiers ++ + dtsVarBindingModifiers + +dtsVarBindingModifiers :: [RDFOpenVarBindingModify] +-- dtsVarBindingModifiers = concatMap dtVarBindingModifiers allDatatypes +dtsVarBindingModifiers = concatMap typeMkModifiers allDatatypes + +{- +dtVarBindingModifiers dtval = + map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) +-} + +-- | Find the named open variable binding modifier. +findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify +findRDFOpenVarBindingModifier nam = + mapFindMaybe nam (LookupMap allOpenVarBindingModify) + +------------------------------------------------------------ +-- Lookup map for built-in rulesets +------------------------------------------------------------ + +-- | A 'LookupMap' of 'allRulesets'. +rdfRulesetMap :: RDFRulesetMap +rdfRulesetMap = LookupMap allRulesets + +-- | All the rule sets known to Swish. +allRulesets :: [RDFRuleset] +allRulesets = + [ rulesetRDF + , rulesetRDFS + , rulesetRDFD + ] + ++ allDatatypeRulesets + +-- | The data type rule sets known to Swish. +allDatatypeRulesets :: [RDFRuleset] +allDatatypeRulesets = map typeRules allDatatypes + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/BuiltInDatatypes.hs b/src/Swish/RDF/BuiltInDatatypes.hs deleted file mode 100644 --- a/src/Swish/RDF/BuiltInDatatypes.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInDatatypes --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module collects references and provides access to all of the --- datatypes built in to Swish. --- --------------------------------------------------------------------------------- - -module Swish.RDF.BuiltInDatatypes - ( allDatatypes, findRDFDatatype ) - where - -import Swish.RDF.RDFDatatype (RDFDatatype) - -import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe) -import Swish.Utils.Namespace (ScopedName) -import Swish.RDF.RDFDatatypeXsdString (rdfDatatypeXsdString) -import Swish.RDF.RDFDatatypeXsdInteger (rdfDatatypeXsdInteger) -import Swish.RDF.RDFDatatypeXsdDecimal (rdfDatatypeXsdDecimal) - ------------------------------------------------------------- --- Declare datatype map ------------------------------------------------------------- - -allDatatypes :: [RDFDatatype] -allDatatypes = - [ rdfDatatypeXsdString - , rdfDatatypeXsdInteger - , rdfDatatypeXsdDecimal - ] - -findRDFDatatype :: ScopedName -> Maybe RDFDatatype -findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes) - ------------------------------------------------------------- --- Declare datatype subtypes map ------------------------------------------------------------- - -{- -allDatatypeSubtypes :: [xxx] -allDatatypeSubtypes = [] --- [[[details TBD]]] --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/BuiltInMap.hs b/src/Swish/RDF/BuiltInMap.hs deleted file mode 100644 --- a/src/Swish/RDF/BuiltInMap.hs +++ /dev/null @@ -1,52 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInMap --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module collects references and provides access to all of the --- datatypes, variable binding modifiers and variable binding filters --- built in to Swish. --- --------------------------------------------------------------------------------- - -module Swish.RDF.BuiltInMap - ( findRDFOpenVarBindingModifier - , findRDFDatatype - , rdfRulesetMap - , allRulesets, allDatatypeRulesets - ) -where - -import Swish.RDF.BuiltInDatatypes -import Swish.RDF.BuiltInRules - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/BuiltInRules.hs b/src/Swish/RDF/BuiltInRules.hs deleted file mode 100644 --- a/src/Swish/RDF/BuiltInRules.hs +++ /dev/null @@ -1,157 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInRules --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module collects references and provides access to all of the --- rulesets, variable binding modifiers and variable binding filters --- built in to Swish. --- --------------------------------------------------------------------------------- - -module Swish.RDF.BuiltInRules - ( findRDFOpenVarBindingModifier - , rdfRulesetMap - , allRulesets, allDatatypeRulesets - ) -where - -import Swish.RDF.BuiltInDatatypes (allDatatypes) - -import Swish.RDF.RDFVarBinding - ( RDFOpenVarBindingModify - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.RDF.RDFRuleset (RDFRuleset, RDFRulesetMap) - -import Swish.RDF.RDFProofContext - ( rulesetRDF - , rulesetRDFS - , rulesetRDFD ) - -import Swish.RDF.VarBinding - ( nullVarBindingModify - , makeVarFilterModify - , varFilterEQ, varFilterNE - ) - -import Swish.RDF.Datatype (typeRules, typeMkModifiers) -import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe) -import Swish.Utils.Namespace (ScopedName) - ------------------------------------------------------------- --- Declare variable binding filters list ------------------------------------------------------------- - --- |List of rdfOpenVarBindingModify values for predefined filters --- -rdfVarBindingFilters :: [RDFOpenVarBindingModify] -rdfVarBindingFilters = - [ filter1 rdfVarBindingUriRef - , filter1 rdfVarBindingBlank - , filter1 rdfVarBindingLiteral - , filter1 rdfVarBindingUntypedLiteral - , filter1 rdfVarBindingTypedLiteral - , filter1 rdfVarBindingXMLLiteral - , filter1 rdfVarBindingMemberProp - , filter2 rdfVarBindingDatatyped - -- , filterN nullVarBindingModify - , filter2 varFilterEQ - , filter2 varFilterNE - ] - where - -- Swish.RDF.VarBinding.openVbmName seems to require that the label - -- list not be evaluated which means that we can not replace these - -- statements by ones like - -- - -- filter1 f (lb:_) = makeVarFilterModift $ f lb - -- - filter1 f lbs = makeVarFilterModify $ f (head lbs) - filter2 f lbs = makeVarFilterModify $ f (head lbs) (lbs!!1) - -- filterN f lbs = makeVarFilterModify $ f ... - ------------------------------------------------------------- --- Declare variable binding modifiers map ------------------------------------------------------------- - -rdfVarBindingModifiers :: [RDFOpenVarBindingModify] -rdfVarBindingModifiers = - [ nullVarBindingModify - ] - ------------------------------------------------------------- --- Find a named built-in OpenVarBindingModifier ------------------------------------------------------------- - -allOpenVarBindingModify :: [RDFOpenVarBindingModify] -allOpenVarBindingModify = - rdfVarBindingFilters ++ - rdfVarBindingModifiers ++ - dtsVarBindingModifiers - -dtsVarBindingModifiers :: [RDFOpenVarBindingModify] --- dtsVarBindingModifiers = concatMap dtVarBindingModifiers allDatatypes -dtsVarBindingModifiers = concatMap typeMkModifiers allDatatypes - -{- -dtVarBindingModifiers dtval = - map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) --} - -findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify -findRDFOpenVarBindingModifier nam = - mapFindMaybe nam (LookupMap allOpenVarBindingModify) - ------------------------------------------------------------- --- Lookup map for built-in rulesets ------------------------------------------------------------- - -rdfRulesetMap :: RDFRulesetMap -rdfRulesetMap = LookupMap allRulesets - -allRulesets :: [RDFRuleset] -allRulesets = - [ rulesetRDF - , rulesetRDFS - , rulesetRDFD - ] - ++ allDatatypeRulesets - -allDatatypeRulesets :: [RDFRuleset] -allDatatypeRulesets = map typeRules allDatatypes - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/ClassRestrictionRule.hs b/src/Swish/RDF/ClassRestrictionRule.hs --- a/src/Swish/RDF/ClassRestrictionRule.hs +++ b/src/Swish/RDF/ClassRestrictionRule.hs @@ -1,11 +1,12 @@ -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : ClassRestrictionRule --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -26,7 +27,12 @@ ) where -import Swish.RDF.RDFGraph +import Swish.Datatype (DatatypeVal(..), DatatypeRel(..), DatatypeRelFn) +import Swish.Namespace (Namespace, ScopedName, namespaceToBuilder) +import Swish.Rule (Rule(..), bwdCheckInference) +import Swish.VarBinding (VarBinding(..)) + +import Swish.RDF.Graph ( RDFLabel(..) , getScopedName , RDFGraph @@ -38,37 +44,25 @@ , resRdfdMaxCardinality ) -import Swish.RDF.RDFRuleset (RDFRule, makeRDFGraphFromN3Builder) -import Swish.RDF.RDFDatatype (RDFDatatypeVal, fromRDFLabel, toRDFLabel) +import Swish.RDF.Datatype (RDFDatatypeVal, fromRDFLabel, toRDFLabel) +import Swish.RDF.Ruleset (RDFRule, makeRDFGraphFromN3Builder) -import Swish.RDF.RDFQuery +import Swish.RDF.Query ( rdfQueryFind , rdfFindValSubj, rdfFindPredVal, rdfFindPredInt , rdfFindList ) -import Swish.RDF.RDFVarBinding (RDFVarBinding) -import Swish.RDF.Datatype (DatatypeVal(..), DatatypeRel(..), DatatypeRelFn) -import Swish.RDF.Rule ( Rule(..), bwdCheckInference) -import Swish.RDF.VarBinding (VarBinding(..)) +import Swish.RDF.VarBinding (RDFVarBinding) import Swish.RDF.Vocabulary (namespaceRDFD) -import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder) -import Swish.Utils.PartOrderedCollection - ( minima, maxima - , partCompareEq, partComparePair - , partCompareListMaybe - , partCompareListSubset - ) - -import Swish.Utils.LookupMap (LookupEntryClass(..), LookupMap(..),mapFindMaybe) -import Swish.Utils.ListHelpers (powerSet) - import Control.Monad (liftM) -import Data.Monoid (Monoid (..)) +import Data.List (delete, nub, (\\), subsequences) +import Data.LookupMap (LookupEntryClass(..), LookupMap(..),mapFindMaybe) import Data.Maybe (fromJust, fromMaybe, mapMaybe) -import Data.List (delete, nub, (\\)) +import Data.Monoid (Monoid (..)) +import Data.Ord.Partial (minima, maxima, partCompareEq, partComparePair, partCompareListMaybe, partCompareListSubset) import qualified Data.Text.Lazy.Builder as B @@ -86,6 +80,7 @@ , crFunc :: ClassRestrictionFn } +-- | Equality of class restrictions is based on the name of the restriction. instance Eq ClassRestriction where cr1 == cr2 = crName cr1 == crName cr2 @@ -146,11 +141,16 @@ , " rdfd:constraint ?r . " ] --- Placeholder false graph for now. +-- | The graph +-- +-- > _:a _:b . +-- +-- Exported for testing. falseGraph :: RDFGraph falseGraph = makeRDFGraphFromN3Builder $ mkPrefix namespaceRDFD `mappend` falseGraphStr +-- | Exported for testing. falseGraphStr :: B.Builder falseGraphStr = "_:a rdfd:false _:b . " @@ -471,7 +471,7 @@ coverSets pvs dts = minima partCompareListSubset $ map (map fst) ctss where - ctss = filter coverspvs $ powerSet cts + ctss = filter coverspvs $ tail $ subsequences cts cts = minima (partComparePair partCompareListMaybe partCompareEq) dts coverspvs cs = coversVals delete (map snd cs) pvs @@ -511,9 +511,7 @@ deleteMaybe Nothing as = as deleteMaybe (Just a) as = delete a as ------------------------------------------------------------- --- Make restriction rules from supplied datatype and graph ------------------------------------------------------------- +-- | Make restriction rules from the supplied datatype and graph. makeRDFDatatypeRestrictionRules :: RDFDatatypeVal vt -> RDFGraph -> [RDFRule] makeRDFDatatypeRestrictionRules dtval = @@ -523,7 +521,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/Datatype.hs b/src/Swish/RDF/Datatype.hs --- a/src/Swish/RDF/Datatype.hs +++ b/src/Swish/RDF/Datatype.hs @@ -1,1047 +1,187 @@ -{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Datatype --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : ExistentialQuantification, MultiParamTypeClasses, OverloadedStrings --- --- This module defines the structures used by Swish to represent and --- manipulate datatypes. It is designed as a basis for handling datatyped --- RDF literals, but the functions in this module are more generic. --- --------------------------------------------------------------------------------- - --- Testing note: this module supports a number of specific datatypes. --- It is intended that functionality in this module will be tested via --- modules "Swish.RDF.RDFDatatype", --- "Swish.RDF.ClassRestrictionRule" and --- "Swish.RDF.RDFDatatypeXsdInteger". --- See also module ClassRestrictionRuleTest for test cases. - -module Swish.RDF.Datatype - ( Datatype(..) - , typeName, typeRules, typeMkRules, typeMkModifiers, typeMkCanonicalForm - , getTypeAxiom, getTypeRule - , DatatypeVal(..) - , getDTMod - , getDTRel - , tvalMkCanonicalForm - , DatatypeMap(..) - , DatatypeRel(..), DatatypeRelFn, DatatypeRelPr - , altArgs - , UnaryFnDescr, UnaryFnTable, UnaryFnApply, unaryFnApp - , BinaryFnDescr, BinaryFnTable, BinaryFnApply, binaryFnApp - , BinMaybeFnDescr, BinMaybeFnTable, BinMaybeFnApply, binMaybeFnApp - , ListFnDescr, ListFnTable, ListFnApply, listFnApp - , DatatypeMod(..), ModifierFn - , ApplyModifier - , nullDatatypeMod - -- , applyDatatypeMod - , makeVmod11inv, makeVmod11 - , makeVmod21inv, makeVmod21 - , makeVmod20 - , makeVmod22 - , makeVmodN1 - , DatatypeSub(..) - ) -where - -import Swish.RDF.Ruleset - ( Ruleset(..) - , getRulesetAxiom, getRulesetRule - ) - -import Swish.RDF.Rule - ( Formula(..) - , Rule(..) - ) - -import Swish.RDF.Vocabulary (swishName) -import Swish.Utils.Namespace (ScopedName) - -import Swish.RDF.VarBinding - ( VarBinding(..) - , addVarBinding - , VarBindingModify(..), OpenVarBindingModify, nullVarBindingModify - ) - -import Swish.Utils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFindMaybe - ) - -import Swish.Utils.ListHelpers - ( flist - , deleteIndex - ) - --- used to add Show instances for structures during debugging --- but backed out again. --- --- import Swish.Utils.ShowM (ShowM(..)) - -import Data.Maybe( isJust, catMaybes ) - -import Control.Monad( join, liftM ) - -import qualified Data.Text as T - ------------------------------------------------------------- --- Datatype framework ------------------------------------------------------------- - --- |Datatype wraps a 'DatatypeVal' value, hiding the value type that --- is used only in implementations of the datatype. --- Users see just the datatype name and associated ruleset. --- -data Datatype ex lb vn = forall vt . Datatype (DatatypeVal ex vt lb vn) - -instance LookupEntryClass - (Datatype ex lb vn) ScopedName (Datatype ex lb vn) - where - newEntry (_,dt) = dt - keyVal dt = (typeName dt, dt) - --- |Get type name from Datatype value -typeName :: Datatype ex lb vn -> ScopedName -typeName (Datatype dtv) = tvalName dtv - --- |Get static rules from Datatype value -typeRules :: Datatype ex lb vn -> Ruleset ex -typeRules (Datatype dtv) = tvalRules dtv - --- |Make rules for Datatype value based on supplied expression -typeMkRules :: Datatype ex lb vn -> ex -> [Rule ex] -typeMkRules (Datatype dtv) = tvalMkRules dtv - --- |Make variable binding modifiers based on values supplied -typeMkModifiers :: Datatype ex lb vn -> [OpenVarBindingModify lb vn] -typeMkModifiers (Datatype dtv) = tvalMkMods dtv - --- |Get the named axiom from a Datatype value. -getTypeAxiom :: ScopedName -> Datatype ex lb vn -> Maybe (Formula ex) -getTypeAxiom nam dt = getRulesetAxiom nam (typeRules dt) - --- |Get the named rule from a Datatype value. -getTypeRule :: ScopedName -> Datatype ex lb vn -> Maybe (Rule ex) -getTypeRule nam dt = getRulesetRule nam (typeRules dt) - --- |Get the canonical form of a datatype value. -typeMkCanonicalForm :: Datatype ex lb vn -> T.Text -> Maybe T.Text -typeMkCanonicalForm (Datatype dtv) = tvalMkCanonicalForm dtv - ------------------------------------------------------------- --- DatatypeVal ------------------------------------------------------------- - --- |DatatypeVal is a structure that defines a number of functions --- and values that characterize the behaviour of a datatype. --- --- A datatype is specified with respect to (polymophic in) a given --- type of (syntactic) expression with which it may be used, and --- a value type (whose existence is hidden as an existential type --- within `DatatypeMap`). --- --- (I tried hiding the value type with an internal existential --- declaration, but that wouldn't wash. Hence this two-part --- structure with `Datatype` in which the internal detail --- of the value type is hidden from users of the `Datatype` class.) --- --- The datatype characteristic functions have two goals: --- --- (1) to support the general datatype entailment rules defined by --- the RDF semantics specification, and --- --- (2) to define additional datatype-specific inference patterns by --- means of which provide additional base functionality to --- applications based on RDF inference. --- --- Datatype-specific inferences are provided using the `DatatypeRel` --- structure for a datatype, which allows a number of named relations --- to be defined on datatype values, and provides mechanisms to --- calculate missing values in a partially-specified member of --- a relation. --- --- Note that rules and variable binding modifiers that deal with --- combined values of more than one datatype may be defined --- separately. Definitions in this module are generally applicable --- only when using a single datatype. --- --- An alternative model for datatype value calculations is inspired --- by that introduced by CWM for arithmetic operations, e.g. --- --- > (1 2 3) math:sum ?x => ?x rdf:value 6 --- --- (where the bare integer @n@ here is shorthand for @\"n\"^^xsd:integer@). --- --- Datatype-specific inference patterns are provided in two ways: --- --- * by variable binding modifiers that can be combined with the --- query results during forward- for backward-chaining of --- inference rules, and --- --- * by the definition of inference rulesets that involve --- datatype values. --- --- I believe the first method to be more flexible than the second, --- in that it more readily supports forward and backward chaining, --- but can be used only through the definition of new rules. --- --- Type parameters: --- --- [@ex@] is the type of expression with which the datatype may be used. --- --- [@vt@] is the internal value type with which the labels are associated. --- --- [@lb@] is the type of label that may be used as a variable in an --- expression or rule. --- --- [@vn@] is the type of node that may be used to carry a value in an --- expression or rule. --- -data DatatypeVal ex vt lb vn = DatatypeVal - { tvalName :: ScopedName - -- ^Identifies the datatype, and also - -- its value space class. - , tvalRules :: Ruleset ex - -- ^A set of named expressions and rules - -- that are valid in in any theory that - -- recognizes the current datatype. - , tvalMkRules :: ex -> [Rule ex] - -- ^A function that accepts an expression - -- and devives some datatype-dependent - -- rules from it. This is provided as a - -- hook for creating datatyped class - -- restriction rules. - , tvalMkMods :: [OpenVarBindingModify lb vn] - -- ^Constructs a list of open variable - -- binding modifiers based on tvalMod, - -- but hiding the actual value type. - , tvalMap :: DatatypeMap vt - -- ^Lexical to value mapping, where @vt@ is - -- a datatype used within a Haskell program - -- to represent and manipulate values in - -- the datatype's value space - , tvalRel :: [DatatypeRel vt] - -- ^A set of named relations on datatype - -- values. Each relation accepts a list - -- of @Maybe vt@, and computes any - -- unspecified values that are in the - -- relation with values supplied. - , tvalMod :: [DatatypeMod vt lb vn] - -- ^A list of named values that are used to - -- construct variable binding modifiers, which - -- in turn may be used by a rule definition. - -- - -- TODO: In due course, this value may be - -- calculated automatically from the supplied - -- value for @tvalRel@. - } - -{- -instance ShowM ex => Show (DatatypeVal ex vt lb vn) where - show dv = "DatatypeVal: " ++ show (tvalName dv) ++ "\n -> rules:\n" ++ show (tvalRules dv) --} - --- Other accessor functions - -getDTRel :: - ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt) -getDTRel nam dtv = - mapFindMaybe nam (LookupMap (tvalRel dtv)) - -getDTMod :: - ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) -getDTMod nam dtv = - mapFindMaybe nam (LookupMap (tvalMod dtv)) - --- |Get the canonical form of a datatype value, or @Nothing@. --- -tvalMkCanonicalForm :: DatatypeVal ex vt lb vn -> T.Text -> Maybe T.Text -tvalMkCanonicalForm dtv str = can - where - dtmap = tvalMap dtv - val = mapL2V dtmap str - can = join $ liftM (mapV2L dtmap) val - --- |DatatypeMap consists of methods that perform lexical-to-value --- and value-to-canonical-lexical mappings for a datatype. --- --- The datatype mappings apply to string lexical forms which --- are stored as `Data.Text`. --- -data DatatypeMap vt = DatatypeMap - { mapL2V :: T.Text -> Maybe vt - -- ^ Function to map a lexical string to - -- the datatype value. This effectively - -- defines the lexical space of the - -- datatype to be all strings for which - -- yield a value other than @Nothing@. - , mapV2L :: vt -> Maybe T.Text - -- ^ Function to map a value to its canonical - -- lexical form, if it has such. - } - --- |Type for a datatype relation inference function. --- --- A datatype relation defines tuples of values that satisfy some --- relation. A datatype relation inference function calculates --- values that complete a relation with values supplied. --- --- The function accepts a list of @Maybe vt@, where vt is the --- datatype value type. It returns one of: --- --- * Just a list of lists, where each inner list returned is a --- complete set of values, including the values supplied, that --- are in the relation. --- --- * Just an empty list is returned if the supplied values are --- insufficient to compute any complete sets of values in the --- relation. --- --- * Nothing if the supplied values are not consistent with --- the relation. --- -type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] - --- |Type for datatype relation predicate: accepts a list of values --- and determines whether or not they satisfy the relation. --- -type DatatypeRelPr vt = [vt] -> Bool - --- |Datatype for a named relation on values of a datatype. --- -data DatatypeRel vt = DatatypeRel - { dtRelName :: ScopedName - , dtRelFunc :: DatatypeRelFn vt - } - -instance LookupEntryClass (DatatypeRel vt) ScopedName (DatatypeRel vt) - where - newEntry (_,relf) = relf - keyVal dtrel = (dtRelName dtrel, dtrel) - --- |Datatype value modifier functions type --- --- Each function accepts a list of values and returns a list of values. --- The exact significance of the different values supplied and returned --- depends on the variable binding pattern used (cf. 'ApplyModifier'), --- but in all cases an empty list returned means that the corresponding --- inputs are not consistent with the function and cannot be used. --- -type ModifierFn vn = [vn] -> [vn] - --- |Type of function used to apply a data value modifier to specified --- variables in a supplied variable binding. It also accepts the --- name of the datatype modifier and carries it into the resulting --- variable binding modifier. --- --- (Note that @vn@ is not necessarily the same as @vt@, the datatype value --- type: the modifier functions may be lifted or otherwise adapted --- to operate on some other type from which the raw data values are --- extracted.) --- -type ApplyModifier lb vn = - ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - --- |Wrapper for data type variable binding modifier included in --- a datatype value. --- -data DatatypeMod vt lb vn = DatatypeMod - { dmName :: ScopedName - , dmModf :: [ModifierFn vt] - , dmAppf :: ApplyModifier lb vn - } - -instance LookupEntryClass - (DatatypeMod vt lb vn) ScopedName (DatatypeMod vt lb vn) - where - newEntry (_,dmod) = dmod - keyVal dmod = (dmName dmod, dmod) - --- |Null datatype value modifier -nullDatatypeMod :: DatatypeMod vt lb vn -nullDatatypeMod = DatatypeMod - { dmName = swishName "nullDatatypeMod" - , dmModf = [] - , dmAppf = nullAppf - } - where - -- nullAppf :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - nullAppf nam _ lbs = (nullVarBindingModify lbs) { vbmName = nam } - -{- --- |Apply datatype variable binding modifier value to list of labels and --- a variable binding. -applyDatatypeMod :: (Eq lb, Show lb, Eq vn, Show vn) - => DatatypeMod vt lb vn -> OpenVarBindingModify lb vn -applyDatatypeMod dtmod = dmAppf dtmod (dmName dtmod) (dmModf dtmod) --} - -{- -dmName dtmod :: ScopedName -dmModf dtmod :: [ModifierFn vt] - :: [[vt] -> [vt]] -dmAppf dtmod :: ApplyModifier lb vn - :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - :: ScopedName -> [[vn] -> [vn]] -> OpenVarBindingModify lb vn -dmAppf dtmod (dmName dtmod) - :: [[vn] -> [vn]] -> OpenVarBindingModify lb vn --} - --------------------------------------------------------------- --- Functions for creating datatype variable binding modifiers --------------------------------------------------------------- - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a @1->1@ function and inverse, such --- as negate. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any --- new variable bindings), returning a non-empty list if @x@ and @y@ --- are in the appropriate relationship. --- --- (1) is @[y] -> [x]@, used to perform the calculation in a forward --- direction. --- --- (2) is @[x] -> [y]@, used to perform the calculation in a backward --- direction. This may be the same as (2) (e.g. for negation) --- or may be different (e.g. increment). --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. (The intent is that a variable-free --- value can be generated as a Curried function, and instantiated --- for particular variables as required.) --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmod11inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod11inv nam [f0,f1,f2] lbs@(~[lb1,lb2]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1],[lb2]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind - app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2]) vbind - app2 [Just v1,Nothing] vbind = addv lb2 (f2 [v1]) vbind - app2 _ _ = [] -makeVmod11inv _ _ _ = - error "makeVmod11inv: requires 3 functions and 2 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases when --- the value mapping is a non-invertable @1->1@ injection, such as --- absolute value. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any --- new variable bindings), returning a non-empty list if @x@ and @y@ --- are in the appropriate relationship. --- --- (1) is @[x]@ -> @[y]@, used to perform the calculation. --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmod11 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod11 nam [f0,f1] lbs@(~[lb1,_]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind - app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2]) vbind - app2 _ _ = [] -makeVmod11 _ _ _ = - error "makeVmod11: requires 2 functions and 2 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a @2->1@ invertable function, such as --- addition or subtraction. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any --- new variable bindings), returning a non-empty list if --- @x@, @y@ and @z@ are in the appropriate relationship. --- --- (2) is @[y,z] -> [x]@, used to perform the calculation in a --- forward direction. --- --- (3) is @[x,z] -> [y]@, used to run the calculation backwards to --- determine the first input argument --- --- (4) is @[x,y] -> [z]@, used to run the calculation backwards to --- determine the second input argument --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmod21inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod21inv nam [f0,f1,f2,f3] lbs@(~[lb1,lb2,lb3]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1],[lb2],[lb3]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind - app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind - app2 [Just v1,Nothing,Just v3] vbind = addv lb2 (f2 [v1,v3]) vbind - app2 [Just v1,Just v2,Nothing] vbind = addv lb3 (f3 [v1,v2]) vbind - app2 _ _ = [] -makeVmod21inv _ _ _ = - error "makeVmod21inv: requires 4 functions and 3 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a @2->1@ non-invertable function, such as --- logical @AND@ or @OR@. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any --- new variable bindings), returning a non-empty list if --- @x@, @y@ and @z@ are in the appropriate relationship. --- --- (2) is @[y,z] -> [x]@, used to perform the calculation in a --- forward direction. --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmod21 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod21 nam [f0,f1] lbs@(~[lb1,_,_]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind - app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind - app2 _ _ = [] -makeVmod21 _ _ _ = - error "makeVmod21: requires 2 functions and 3 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a simple comparson of two values. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (1) is @[x,y] -> [?]@, used as a filter (i.e. not creating any --- new variable bindings), returning a non-empty list if --- @x@ and @y@ are in the appropriate relationship. --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmod20 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod20 nam [f0] lbs@(~[_,_]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind - app2 _ _ = [] -makeVmod20 _ _ _ = - error "makeVmod20: requires 1 function and 2 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a @2->2@ non-invertable function, such as --- quotient/remainder --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (1) is @[w,x,y,z] -> [?]@, used as a filter (i.e. not creating --- any new variable bindings), returning a non-empty list if --- @w@, @x@, @y@ and @z@ are in the appropriate relationship. --- --- (2) is @[y,z] -> [w,x]@, used to perform the calculation given --- two input values. --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- --- NOTE: this might be generalized to allow one of @w@ or @x@ to be --- specified, and return null if it doesn't match the calculated value. --- -makeVmod22 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod22 nam [f0,f1] lbs@(~[lb1,lb2,_,_]) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1,lb2]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 [Just v1,Just v2,Just v3,Just v4] vbind = - selv (f0 [v1,v2,v3,v4]) vbind - app2 [Nothing,Nothing,Just v3,Just v4] vbind = - addv2 lb1 lb2 (f1 [v3,v4]) vbind - app2 _ _ = [] -makeVmod22 _ _ _ = - error "makeVmod22: requires 2 functions and 4 labels" - --- |'ApplyModifier' function for use with 'DatatypeMod' in cases --- when the value mapping is a @N->1@ function, --- such as Sigma (sum) of a vector. --- --- [@nam@] is the name from the 'DatatypeMod' value that is carried into --- the resulting variable binding modifier. --- --- [@fns@] are functions used to implement details of the variable --- binding modifier: --- --- (1) is @[x,y...] -> [?]@, used as a filter (i.e. not creating --- any new variable bindings), returning a non-empty list if --- @x@ and @y...@ are in the appropriate relationship. --- --- (2) is @[y...] -> [x]@, used to perform the calculation. --- --- [@lbs@] is a list of specific label values for which a variable binding --- modifier will be generated. --- --- Note: an irrefutable pattern match for @lbs@ is used so that a name --- for the 'VarBindingModify' value can be extracted using an undefined --- label value. --- -makeVmodN1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmodN1 nam [f0,f1] lbs@(~(lb1:_)) = VarBindingModify - { vbmName = nam - , vbmApply = concatMap app1 - , vbmVocab = lbs - , vbmUsage = [[],[lb1]] - } - where - app1 vbind = app2 (map (vbMap vbind) lbs) vbind - app2 vs@(v1:_) vbind - | isJust v1 && isJustvs = selv (f0 jvs) vbind - | isJustvs = addv lb1 (f1 jvs) vbind - | otherwise = [] - where - isJustvs = all isJust vs - jvs = catMaybes vs - app2 _ _ = error "app2 sent empty list" -- -Wall - -makeVmodN1 _ _ _ = - error "makeVmodN1: requires 2 functions and at 1 or more labels" - --------------------------------------------------------- --- Local helper functions for makeVmodXXX variants --------------------------------------------------------- - --- Add value to variable variable binding, if value is singleton list, --- otherwise return empty list. -addv :: (Eq lb, Show lb, Eq vt, Show vt) - => lb -> [vt] -> VarBinding lb vt - -> [VarBinding lb vt] -addv lb [val] vbind = [addVarBinding lb val vbind] -addv _ _ _ = [] - --- Add two entries to variable variable binding, if value supplied is --- a doubleton list, otherwise return empty list. -addv2 :: (Eq lb, Show lb, Eq vt, Show vt) - => lb -> lb -> [vt] -> VarBinding lb vt - -> [VarBinding lb vt] -addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $ - addVarBinding lb2 val2 vbind] -addv2 _ _ _ _ = [] - --- If supplied value is non-empty list return supplied variable binding, --- otherwise return empty list. -selv :: [vt] -> varBinding lb vt -> [varBinding lb vt] -selv [] _ = [] -selv _ vbind = [vbind] - --------------------------------------------------------------- --- Functions for evaluating arguments in a datatype relation --------------------------------------------------------------- --- --- altArgs is a generic function for evaluating datatype relation --- values, based on suppied functions and argument values --- --- UnaryFnDescr, UnaryFnApply and unaryFnApp: --- are support types and function for using altArgs to --- evaluate relations on unary functions (binary relations). --- --- BinaryFnDescr, BinaryFnApply and binaryFnApp: --- are support types and function for using altArgs to --- evaluate relations on binary functions (3-way relations). --- --- ListFnDescr, ListFnApply and listFnApp: --- are support types and function for using altArgs to --- evaluate relations on list functions (n-way relations), --- where the first member of the list is the value of a --- fold of a function over the rest of the list. --- --- See experimental module spike-altargs.hs for test cases and --- development steps for this function. - --- |Given a list of argument values and a list of functions for --- calculating new values from supplied values, return a list --- of argument values, or @Nothing@ if the supplied values are --- inconsistent with the calculations specified. --- --- Each list of values returned corresponds to a set of values that --- satisfy the relation, consistent with the values supplied. --- --- Functions are described as tuple consisting of: --- --- (a) a predicate that the argument is required to satisfy --- --- (b) a function to apply, --- --- (c) a function to apply function (b) to a list of arguments --- --- (d) argument list index values to which the function is applied. --- --- Each supplied argument is of the form @Maybe a@, where the argument --- has value type a. @Nothing@ indicates arguments of unknown value. --- --- The basic idea is that, for each argument position in the relation, --- a function may be supplied to calculate that argument's possible values --- from some combination of the other arguments. The results calculated --- in this way are compared with the original arguments provided: --- if the values conflict then the relation is presumed to be --- unsatisfiable with the supplied values, and @Nothing@ is returned; --- if there are any calculated values for arguments supplied without --- any values, then tbe calculated values are used. --- If there are any arguments for which no values are supplied or --- calculated, then the relation is presumed to be underdetermined, --- and @Just []@ is returned. --- -altArgs :: - (Eq vt) - => DatatypeRelPr vt - -> [(vt->Bool,[b])] - -- ^ a list of argument value predicates and - -- function descriptors. The predicate indicates any - -- additional constraints on argument values (e.g. the result - -- of abs must be positive). Use @(const True)@ for the predicate - -- associated with unconstrained relation arguments. - -- For each argument, a list of function descriptors is - -- supplied corresponding to alternative values (e.g. a square - -- relation would offer two alternative values for the root.) - - -> ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) - -- ^ a function that takes an argument value predicate, - -- a function descriptor and applies it to a supplied argument - -- list to return: - -- @Just a@ calculated list of one or more possible argument values, - -- @Just []@ indicating insufficient information provided, or - -- @Nothing@ indicating inconsistent information provided. - -- May be one of 'unaryFnApp', 'binaryFnApp', 'listFnApp' or - -- some other caller-supplied value. - - -> DatatypeRelFn vt - -- ^ The return value can be used as the - -- 'dtRelFunc' component of a 'DatatypeRel' value. - -altArgs pr fnss apfn args = cvals4 cvals3 - where - -- Calculate new value(s) for each argument from supplied values, and - -- lift inconsistency indicator (Just/Nothing) to outermost Monad. - -- cvals1 :: [Maybe [vt]] - cvals1 = flist (map (applyFdescToTuple apfn) fnss) args - -- Merge calculated values with supplied arguments, and again - -- lift inconsistency indicator (Just/Nothing) to outermost Monad. - -- cvals2 :: Maybe [[vt]] - cvals2 = sequence $ mergeTupleVals (map fst fnss) args cvals1 - -- Map list of alternative values for each tuple member to - -- a list of alternative tuples. - cvals3 = liftM sequence cvals2 - -- Check each tuple against the supplied predicate. - -- If any of the alternative tuples does not match the predicate - -- then signal an inconsistency. - cvals4 Nothing = Nothing - cvals4 cvs@(Just ts) = if all pr ts then cvs else Nothing - --- Perform alternative calculations for single result value --- Each result value is a list of zero or more alternatives --- that can be calculated from available parameters, or --- Nothing if the available parameters are inconsistent. --- --- apfn is the function that actually applies an element of --- the function descriptor to a tuple of Maybe arguments --- (where Nothing is used to indicate an unknown value) --- (p,fns) is a pair consisting of a value-checking predicate --- for the corresponding tuple member, and a list of --- function descriptors that each return one or more --- values the tuple member, calculated from other values --- that are present. Just [] means no values are --- calculated for this member, and Nothing means the --- calculation has detected tuple values supplied that --- are inconsistent with the datatype relation concerned. --- args is a tuple of Maybe tuple elements, (where Nothing --- indicates an unknown value). --- --- Returns Maybe a list of alternative values for the member, --- Just [] to indicate insufficient information to calculate --- any new values, and Nothing to indicate an inconsistency. --- -applyFdescToTuple :: - ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) -> (vt->Bool,[b]) -> [Maybe vt] - -> Maybe [vt] -applyFdescToTuple apfn (p,fns) args = - liftM concat $ sequence cvals - where - -- cvals :: [Maybe [vt]] - cvals = flist (map (apfn p) fns) args - --- Merge calculated tuple values with supplied tuple, checking for consistency. --- --- ps predicates used for isolated validation of each tuple member --- args supplied tuple values, with Nothing for unknown values --- cvals list of alternative calculated values for each tuple member, --- or Nothing if an inconsistency has been detected by the --- tuple-calculation functions. Note that this list may contain --- more entries than args; the surplus entries are ignored --- (see list functions for how this is used). --- --- Returns a tuple of Maybe lists of values for each tuple member, --- containing Nothing if an inconsistency has been detected in the --- supplied values. --- -mergeTupleVals :: (Eq a) => [a->Bool] -> [Maybe a] -> [Maybe [a]] -> [Maybe [a]] -mergeTupleVals _ _ (Nothing:_) = [Nothing] -mergeTupleVals (_:ps) (Nothing:a1s) (Just a2s:a2ss) - = Just a2s:mergeTupleVals ps a1s a2ss -mergeTupleVals (p:ps) (Just a1:a1s) (Just []:a2ss) - | p a1 = Just [a1]:mergeTupleVals ps a1s a2ss - | otherwise = [Nothing] -mergeTupleVals (p:ps) (Just a1:a1s) (Just a2s:a2ss) - | p a1 && elem a1 a2s = Just [a1]:mergeTupleVals ps a1s a2ss - | otherwise = [Nothing] -mergeTupleVals _ [] _ = [] -mergeTupleVals _ _ _ = [Nothing] - --- |'altArgs' support for unary functions: function descriptor type -type UnaryFnDescr a = (a->a,Int) - --- |'altArgs' support for unary functions: function descriptor table type -type UnaryFnTable a = [(a->Bool,[UnaryFnDescr a])] - --- |'altArgs' support for unary functions: function applicator type -type UnaryFnApply a = (a->Bool) -> UnaryFnDescr a -> [Maybe a] -> Maybe [a] - --- |'altArgs' support for unary functions: function applicator -unaryFnApp :: UnaryFnApply a -unaryFnApp p (f1,n) args = apf (args!!n) - where - apf (Just a) = if p r then Just [r] else Nothing where r = f1 a - apf Nothing = Just [] - --- |'altArgs' support for binary functions: function descriptor type -type BinaryFnDescr a = (a->a->a,Int,Int) - --- |'altArgs' support for binary functions: function descriptor table type -type BinaryFnTable a = [(a->Bool,[BinaryFnDescr a])] - --- |'altArgs' support for binary functions: function applicator type -type BinaryFnApply a = - (a->Bool) -> BinaryFnDescr a -> [Maybe a] -> Maybe [a] - --- |'altArgs' support for binary functions: function applicator -binaryFnApp :: BinaryFnApply a -binaryFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) - where - apf (Just a1) (Just a2) = if p r then Just [r] else Nothing - where r = f a1 a2 - apf _ _ = Just [] - --- |'altArgs' support for binary function with provision for indicating --- inconsistent supplied values: function descriptor type -type BinMaybeFnDescr a = (a->a->Maybe [a],Int,Int) - --- |'altArgs' support for binary function with provision for indicating --- inconsistent supplied values: function descriptor table type -type BinMaybeFnTable a = [(a->Bool,[BinMaybeFnDescr a])] - --- |'altArgs' support for binary function with provision for indicating --- inconsistent supplied values: function applicator type -type BinMaybeFnApply a = - (a->Bool) -> BinMaybeFnDescr a -> [Maybe a] -> Maybe [a] - --- |'altArgs' support for binary function with provision for indicating --- inconsistent supplied values: function applicator -binMaybeFnApp :: BinMaybeFnApply a -binMaybeFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) - where - apf (Just a1) (Just a2) = if pm r then r else Nothing - where - r = f a1 a2 - pm Nothing = False - pm (Just x) = all p x - apf _ _ = Just [] - --- |'altArgs' support for list functions (e.g. sum over list of args), --- where first element of list is a fold over the rest of the list, --- and remaining elements of list can be calculated in terms --- of the result of the fold and the remaining elements --- --- List function descriptor is --- --- (a) list-fold function, f (e.g. (+) --- --- (b) list-fold identity, z (e.g. 0) --- --- (c) list-fold-function inverse, g (e.g. (-)) --- --- (d) index of element to evaluate --- --- such that: --- --- > (a `f` z) == (z `f` a) == a --- > (a `g` c) == b <=> a == b `f` c --- > (a `g` z) == a --- > (a `g` a) == z --- --- and the result of the folded function does not depend on --- the order that the list elements are processed. --- --- NOTE: the list of 'ListFnDescr' values supplied to 'altArgs' must --- be at least as long as the argument list. In many cases, Haskell --- lazy evaluation can be used to supply an arbitrarily long list. --- See test cases in spike-altargs.hs for an example. --- --- Function descriptor type -type ListFnDescr a = (a->a->a,a,a->a->a,Int) - --- |Function table type -type ListFnTable a = [(a->Bool,[ListFnDescr a])] - --- |'altArgs' support for list functions: function applicator type -type ListFnApply a = (a->Bool) -> ListFnDescr a -> [Maybe a] -> Maybe [a] - --- |'altArgs' support for list functions: function applicator -listFnApp :: ListFnApply a -listFnApp p (f,z,g,n) (a0:args) - | n == 0 = - app $ foldr (apf f) (Just [z]) args - | otherwise = - app $ apf g a0 (foldr (apf f) (Just [z]) (args `deleteIndex` (n-1))) - where - apf :: (a->a->a) -> Maybe a -> Maybe [a] -> Maybe [a] - apf fn (Just a1) (Just [a2]) = Just [fn a1 a2] - apf _ _ _ = Just [] - - -- app :: Maybe [a] -> Maybe [a] - app Nothing = Nothing - app r@(Just [a]) = if p a then r else Nothing - app _ = Just [] - -listFnApp _ _ [] = error "listFnApp called with an empty list" -- -Wall - --------------------------------------------------------- --- Datatype sub/supertype description --------------------------------------------------------- - --- |Describe a subtype/supertype relationship between a pair of datatypes. --- --- Originally, I had this as a supertype field of the DatatypeVal structure, --- but that suffered from some problems: --- --- * supertypes may be introduced retrospectively, --- --- * the relationship expressed with respect to a single datatype --- cannot indicate how to do injections/restrictions between the --- underlying value types. --- --- [@ex@] is the type of expression with which the datatype may be used. --- --- [@lb@] is the type of the variable labels used. --- --- [@vn@] is the type of value node used to contain a datatyped value --- --- [@supvt@] is the internal value type of the super-datatype --- --- [@subvt@] is the internal value type of the sub-datatype --- -data DatatypeSub ex lb vn supvt subvt = DatatypeSub - { trelSup :: DatatypeVal ex supvt lb vn - -- ^ Datatype that is a supertype of @trelSub@, - -- having value space @supvt@. - , trelSub :: DatatypeVal ex subvt lb vn - -- ^ Datatype that is a subtype of @trelSup@, - -- having value space @supvt@. - , trelToSup :: subvt -> supvt - -- ^ Function that maps subtype value to - -- corresponding supertype value. - , trelToSub :: supvt -> Maybe subvt - -- ^ Function that maps supertype value to - -- corresponding subtype value, if there - -- is such a value. - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Datatype +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines the structures used by Swish to represent and +-- manipulate RDF datatypes. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Datatype + ( RDFDatatype + , RDFDatatypeVal + , RDFDatatypeMod + , RDFModifierFn, RDFApplyModifier + , makeRdfDtOpenVarBindingModify, makeRdfDtOpenVarBindingModifiers + , applyRDFDatatypeMod + , RDFDatatypeSub + , fromRDFLabel, toRDFLabel, makeDatatypedLiteral + ) +where + +import Swish.Datatype + ( Datatype + , DatatypeVal(..) + , DatatypeMap(..) + , DatatypeMod(..), ModifierFn + , ApplyModifier + , DatatypeSub(..) + ) +import Swish.Namespace (ScopedName) +import Swish.VarBinding (VarBindingModify(..)) + +import Swish.RDF.Graph + ( RDFLabel(..) + , isDatatyped + , getLiteralText + , RDFGraph + ) + +import Swish.RDF.VarBinding (RDFVarBinding, RDFOpenVarBindingModify) + +import Control.Monad (liftM) +import Data.Maybe (fromMaybe, isJust, fromJust) + +import qualified Data.Text as T + +------------------------------------------------------------ +-- Specialize datatype framework types for use with RDF +------------------------------------------------------------ + +-- |RDF datatype wrapper used with RDF graph values +-- +type RDFDatatype = Datatype RDFGraph RDFLabel RDFLabel + +-- |RDF datatype value used with RDF graph values +-- +type RDFDatatypeVal vt = DatatypeVal RDFGraph vt RDFLabel RDFLabel + +-- |RDF datatype modifier used with RDF graph values +-- +type RDFDatatypeMod vt = DatatypeMod vt RDFLabel RDFLabel + +-- |Describe a subtype/supertype relationship between a pair +-- of RDF datatypes. +-- +type RDFDatatypeSub supvt subvt = DatatypeSub RDFGraph RDFLabel RDFLabel supvt subvt + +-- |RDF value modifier function type +-- +-- This indicates a modifier function that operates on 'RDFLabel' values. +-- +type RDFModifierFn = ModifierFn RDFLabel + +-- |RDF value modifier application function type +-- +-- This indicates a function that applies RDFModifierFn functions. +-- +type RDFApplyModifier = ApplyModifier RDFLabel RDFLabel + +-------------------------------------------------------------- +-- Functions for creating datatype variable binding modifiers +-------------------------------------------------------------- + +-- |Create an 'RDFOpenVarBindingModify' value. +-- +-- The key purpose of this function is to lift the supplied +-- variable constraint functions from operating on data values directly +-- to a corresponding list of functions that operate on values contained +-- in RDF graph labels (i.e. RDF literal nodes). It also applies +-- node type checking, such that if the actual RDF nodes supplied do +-- not contain appropriate values then the variable binding is not +-- accepted. +-- +makeRdfDtOpenVarBindingModify :: + RDFDatatypeVal vt + -- ^ is an 'RDFDatatype' value containing details of the datatype + -- for which a variable binding modifier is created. + -> RDFDatatypeMod vt + -- ^ is the data value modifier value that defines the calculations + -- that are used to implement a variable binding modifier. + -> RDFOpenVarBindingModify +makeRdfDtOpenVarBindingModify dtval dtmod = + dmAppf dtmod (dmName dtmod) $ map (makeRDFModifierFn dtval) (dmModf dtmod) + +-- |Create all RDFOpenVarBindingModify values for a given datatype value. +-- See 'makeRdfDtOpenVarBindingModify'. +-- +makeRdfDtOpenVarBindingModifiers :: + RDFDatatypeVal vt + -- ^ is an 'RDFDatatype' value containing details of the datatype + -- for which variable binding modifiers are created. + -> [RDFOpenVarBindingModify] +makeRdfDtOpenVarBindingModifiers dtval = + map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) + +-- |Apply a datatype modifier using supplied RDF labels to a supplied +-- RDF variable binding. +-- +applyRDFDatatypeMod :: + RDFDatatypeVal vt -> RDFDatatypeMod vt -> [RDFLabel] -> [RDFVarBinding] + -> [RDFVarBinding] +applyRDFDatatypeMod dtval dtmod lbs = + vbmApply (makeRdfDtOpenVarBindingModify dtval dtmod lbs) + +-- |Given details of a datatype and a single value constraint function, +-- return a new constraint function that operates on 'RDFLabel' values. +-- +-- The returned constraint function incorporates checks for appropriately +-- typed literal nodes, and returns similarly typed literal nodes. +-- +makeRDFModifierFn :: + RDFDatatypeVal vt -> ModifierFn vt -> RDFModifierFn +makeRDFModifierFn dtval fn ivs = + let + ivals = mapM (fromRDFLabel dtval) ivs + ovals | isJust ivals = fn (fromJust ivals) + | otherwise = [] + in + fromMaybe [] $ mapM (toRDFLabel dtval) ovals + +------------------------------------------------------------ +-- Helpers to map between datatype values and RDFLabels +------------------------------------------------------------ + +-- | Convert from a typed literal to a Haskell value, +-- with the possibility of failure. +fromRDFLabel :: + RDFDatatypeVal vt -> RDFLabel -> Maybe vt +fromRDFLabel dtv lab + | isDatatyped dtnam lab = mapL2V dtmap $ getLiteralText lab + | otherwise = Nothing + where + dtnam = tvalName dtv + dtmap = tvalMap dtv + +-- | Convert a Haskell value to a typed literal (label), +-- with the possibility of failure. +toRDFLabel :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel +toRDFLabel dtv = + liftM (makeDatatypedLiteral dtnam) . mapV2L dtmap + where + dtnam = tvalName dtv + dtmap = tvalMap dtv + +-- | Create a typed literal. No conversion is made to the +-- string representation. +makeDatatypedLiteral :: + ScopedName -- ^ data type + -> T.Text -- ^ string form of the value + -> RDFLabel +makeDatatypedLiteral = flip TypedLit + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/Datatype/XSD/Decimal.hs b/src/Swish/RDF/Datatype/XSD/Decimal.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Datatype/XSD/Decimal.hs @@ -0,0 +1,486 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Decimal +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011 William Waites, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines the structures used to represent and +-- manipulate RDF @xsd:decimal@ datatyped literals. +-- +-- Note that in versions @0.6.4@ and @0.6.5@, this module was a mixture +-- of support for @xsd:decimal@ and @xsd:double@. In @0.7.0@ the module +-- has been changed to @xsd:decimal@, but this may change. +-- +-------------------------------------------------------------------------------- + +-- NOTE: William's code is half about xsd:decimal and half xsd:double. +-- I have changed it all to xsd:decimal since the rules do not handle some +-- of the xsd:double specific conditions (e.g. NaN/Inf values). However, +-- the values are mapped to Haskell Double values, which is not a good match +-- for xsd:decimal. + +module Swish.RDF.Datatype.XSD.Decimal + ( rdfDatatypeXsdDecimal + , rdfDatatypeValXsdDecimal + , typeNameXsdDecimal, namespaceXsdDecimal + , axiomsXsdDecimal, rulesXsdDecimal + ) +where + +import Swish.Datatype + ( Datatype(..) + , DatatypeVal(..) + , DatatypeRel(..), DatatypeRelPr + , altArgs + , UnaryFnTable, unaryFnApp + , BinaryFnTable, binaryFnApp + , DatatypeMod(..) + , makeVmod11inv, makeVmod11 + , makeVmod21inv, makeVmod21 + , makeVmod20 + ) +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (namespaceToBuilder, makeNSScopedName) +import Swish.QName (LName) +import Swish.Ruleset (makeRuleset) + +import Swish.RDF.Datatype (RDFDatatype, RDFDatatypeVal, RDFDatatypeMod) +import Swish.RDF.Datatype (makeRdfDtOpenVarBindingModifiers) +import Swish.RDF.Datatype.XSD.MapDecimal (mapXsdDecimal) + +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) +import Swish.RDF.Ruleset (makeRDFGraphFromN3Builder, makeRDFFormula) + +import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + ) + +import Data.Monoid(Monoid(..)) + +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +nameXsdDecimal :: LName +nameXsdDecimal = "decimal" + +-- |Type name for @xsd:decimal@ datatype. +typeNameXsdDecimal :: ScopedName +typeNameXsdDecimal = makeNSScopedName namespaceXSD nameXsdDecimal + +-- | Namespace for @xsd:decimal@ datatype functions. +namespaceXsdDecimal :: Namespace +namespaceXsdDecimal = namespaceXsdType nameXsdDecimal + +-- | The RDFDatatype value for @xsd:decimal@. +rdfDatatypeXsdDecimal :: RDFDatatype +rdfDatatypeXsdDecimal = Datatype rdfDatatypeValXsdDecimal + +-- |Define Datatype value for @xsd:decimal@. +-- +-- Members of this datatype decimal values. +-- +-- The lexical form consists of an optional @+@ or @-@ +-- followed by a sequence of decimal digits, an optional +-- decimal point and a sequence of decimal digits. +-- +-- The canonical lexical form has leading zeros and @+@ sign removed. +-- +rdfDatatypeValXsdDecimal :: RDFDatatypeVal Double +rdfDatatypeValXsdDecimal = DatatypeVal + { tvalName = typeNameXsdDecimal + , tvalRules = rdfRulesetXsdDecimal -- Ruleset RDFGraph + , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdDecimal + -- RDFGraph -> [RDFRules] + , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdDecimal + , tvalMap = mapXsdDecimal -- DatatypeMap Double + , tvalRel = relXsdDecimal -- [DatatypeRel Double] + , tvalMod = modXsdDecimal -- [DatatypeMod Double] + } + +-- |relXsdDecimal contains arithmetic and other relations for xsd:decimal values. +-- +-- The functions are inspired by those defined by CWM as math: properties +-- (). +-- +relXsdDecimal :: [DatatypeRel Double] +relXsdDecimal = + [ relXsdDecimalAbs + , relXsdDecimalNeg + , relXsdDecimalSum + , relXsdDecimalDiff + , relXsdDecimalProd + , relXsdDecimalPower + , relXsdDecimalEq + , relXsdDecimalNe + , relXsdDecimalLt + , relXsdDecimalLe + , relXsdDecimalGt + , relXsdDecimalGe + ] + +mkDecRel2 :: + LName -> DatatypeRelPr Double -> UnaryFnTable Double + -> DatatypeRel Double +mkDecRel2 nam pr fns = DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdDecimal nam + , dtRelFunc = altArgs pr fns unaryFnApp + } + +mkDecRel3 :: + LName -> DatatypeRelPr Double -> BinaryFnTable Double + -> DatatypeRel Double +mkDecRel3 nam pr fns = DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdDecimal nam + , dtRelFunc = altArgs pr fns binaryFnApp + } + +relXsdDecimalAbs :: DatatypeRel Double +relXsdDecimalAbs = mkDecRel2 "abs" (const True) + [ ( (>=0), [ (abs,1) ] ) + , ( const True, [ (id,0), (negate,0) ] ) + ] + +relXsdDecimalNeg :: DatatypeRel Double +relXsdDecimalNeg = mkDecRel2 "neg" (const True) + [ ( const True, [ (negate,1) ] ) + , ( const True, [ (negate,0) ] ) + ] + +relXsdDecimalSum :: DatatypeRel Double +relXsdDecimalSum = mkDecRel3 "sum" (const True) + [ ( const True, [ ((+),1,2) ] ) + , ( const True, [ ((-),0,2) ] ) + , ( const True, [ ((-),0,1) ] ) + ] + +relXsdDecimalDiff :: DatatypeRel Double +relXsdDecimalDiff = mkDecRel3 "diff" (const True) + [ ( const True, [ ((-),1,2) ] ) + , ( const True, [ ((+),0,2) ] ) + , ( const True, [ ((-),1,0) ] ) + ] + +relXsdDecimalProd :: DatatypeRel Double +relXsdDecimalProd = mkDecRel3 "prod" (const True) + [ ( const True, [ ((*),1,2) ] ) + , ( const True, [ ((/),0,2) ] ) + , ( const True, [ ((/),0,1) ] ) + ] + +relXsdDecimalPower :: DatatypeRel Double +relXsdDecimalPower = mkDecRel3 "power" (const True) + [ ( const True, [ ((**),1,2) ] ) + , ( const True, [ ] ) + , ( (>=0), [ ] ) + ] + +liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool +liftL2 p i1 i2 as = p (i1 as) (i2 as) + +lcomp :: (a->a->Bool) -> [a] -> Bool +lcomp p = liftL2 p head (head . tail) + +-- eq + +relXsdDecimalEq :: DatatypeRel Double +relXsdDecimalEq = mkDecRel2 "eq" (lcomp (==)) + ( repeat (const True, []) ) + +-- ne + +relXsdDecimalNe :: DatatypeRel Double +relXsdDecimalNe = mkDecRel2 "ne" (lcomp (/=)) + ( repeat (const True, []) ) + +-- lt + +relXsdDecimalLt :: DatatypeRel Double +relXsdDecimalLt = mkDecRel2 "lt" (lcomp (<)) + ( repeat (const True, []) ) + +-- le + +relXsdDecimalLe :: DatatypeRel Double +relXsdDecimalLe = mkDecRel2 "le" (lcomp (<=)) + ( repeat (const True, []) ) + +-- gt + +relXsdDecimalGt :: DatatypeRel Double +relXsdDecimalGt = mkDecRel2 "gt" (lcomp (>)) + ( repeat (const True, []) ) + +-- ge + +relXsdDecimalGe :: DatatypeRel Double +relXsdDecimalGe = mkDecRel2 "ge" (lcomp (>=)) + ( repeat (const True, []) ) + +-- |modXsdDecimal contains variable binding modifiers for xsd:decimal values. +-- +-- The functions are selected from those defined by CWM as math: +-- properties +-- (). +-- +modXsdDecimal :: [RDFDatatypeMod Double] +modXsdDecimal = + [ modXsdDecimalAbs + , modXsdDecimalNeg + , modXsdDecimalSum + , modXsdDecimalDiff + , modXsdDecimalProd + , modXsdDecimalPower + , modXsdDecimalEq + , modXsdDecimalNe + , modXsdDecimalLt + , modXsdDecimalLe + , modXsdDecimalGt + , modXsdDecimalGe + ] + +modXsdDecimalAbs :: RDFDatatypeMod Double +modXsdDecimalAbs = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "abs" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod11 + } + where + f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] + f0 _ = [] + f1 [v2] = [abs v2] + f1 _ = [] + +modXsdDecimalNeg :: RDFDatatypeMod Double +modXsdDecimalNeg = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "neg" + , dmModf = [ f0, f1, f1 ] + , dmAppf = makeVmod11inv + } + where + f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] + f0 _ = [] + f1 [vi] = [-vi] + f1 _ = [] + +modXsdDecimalSum :: RDFDatatypeMod Double +modXsdDecimalSum = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "sum" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2+v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2+v3] + f1 _ = [] + f2 [v1,vi] = [v1-vi] + f2 _ = [] + +modXsdDecimalDiff :: RDFDatatypeMod Double +modXsdDecimalDiff = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "diff" + , dmModf = [ f0, f1, f2, f3 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2-v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2-v3] + f1 _ = [] + f2 [v1,v3] = [v1+v3] + f2 _ = [] + f3 [v1,v2] = [v2-v1] + f3 _ = [] + +modXsdDecimalProd :: RDFDatatypeMod Double +modXsdDecimalProd = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "prod" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2*v3] + f1 _ = [] + f2 [v1,vi] = [v1/vi] + f2 _ = [] + +modXsdDecimalPower :: RDFDatatypeMod Double +modXsdDecimalPower = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal "power" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod21 + } + where + f0 vs@[v1,v2,v3] = if v1 == (v2**v3 :: Double) then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2**v3 :: Double] + f1 _ = [] + +modXsdDecimalEq, modXsdDecimalNe, modXsdDecimalLt, modXsdDecimalLe, modXsdDecimalGt, modXsdDecimalGe :: RDFDatatypeMod Double +modXsdDecimalEq = modXsdDecimalCompare "eq" (==) +modXsdDecimalNe = modXsdDecimalCompare "ne" (/=) +modXsdDecimalLt = modXsdDecimalCompare "lt" (<) +modXsdDecimalLe = modXsdDecimalCompare "le" (<=) +modXsdDecimalGt = modXsdDecimalCompare "gt" (>) +modXsdDecimalGe = modXsdDecimalCompare "ge" (>=) + +modXsdDecimalCompare :: + LName -> (Double->Double->Bool) -> RDFDatatypeMod Double +modXsdDecimalCompare nam rel = DatatypeMod + { dmName = makeNSScopedName namespaceXsdDecimal nam + , dmModf = [ f0 ] + , dmAppf = makeVmod20 + } + where + f0 vs@[v1,v2] = if rel v1 v2 then vs else [] + f0 _ = [] + +-- |rulesetXsdDecimal contains rules and axioms that allow additional +-- deductions when xsd:decimal values appear in a graph. +-- +-- The rules defined here are concerned with basic decimal arithmetic +-- operations: +, -, *, /, ** +-- +-- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +-- +rdfRulesetXsdDecimal :: RDFRuleset +rdfRulesetXsdDecimal = + makeRuleset namespaceXsdDecimal axiomsXsdDecimal rulesXsdDecimal + +prefixXsdDecimal :: B.Builder +prefixXsdDecimal = + mconcat $ map namespaceToBuilder + [ namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdDecimal + ] + +mkAxiom :: LName -> B.Builder -> RDFFormula +mkAxiom local gr = + makeRDFFormula namespaceXsdDecimal local (prefixXsdDecimal `mappend` gr) + +-- | The axioms for @xsd:decimal@, which are +-- +-- > xsd:decimal a rdfs:Datatype . +-- +axiomsXsdDecimal :: [RDFFormula] +axiomsXsdDecimal = + [ mkAxiom "dt" + "xsd:decimal rdf:type rdfs:Datatype ." + -- "xsd:double rdf:type rdfs:Datatype ." + ] + +-- | The rules for @xsd:decimal@. +-- +rulesXsdDecimal :: [RDFRule] +rulesXsdDecimal = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdDecimal gr + where + gr = makeRDFGraphFromN3Builder rulesXsdDecimalBuilder + +--- I have removed the newline which was added between each line +--- to improve the clarity of parser errors. +--- +rulesXsdDecimalBuilder :: B.Builder +rulesXsdDecimalBuilder = + mconcat + [ prefixXsdDecimal + , "xsd_decimal:Abs a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:abs ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Neg a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:neg ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Sum a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_decimal:sum ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Diff a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_decimal:diff ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Prod a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_decimal:prod ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:DivMod a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; " + , " rdfd:constraint xsd_decimal:divmod ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Power a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_decimal:power ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Eq a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:eq ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Ne a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:ne ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Lt a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:lt ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Le a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:le ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Gt a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:gt ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_decimal:Ge a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_decimal:ge ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + ] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011 William Waites, 2011, 2012 Douglas Burke, +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Datatype/XSD/Integer.hs b/src/Swish/RDF/Datatype/XSD/Integer.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Datatype/XSD/Integer.hs @@ -0,0 +1,530 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Integer +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines the structures used to represent and +-- manipulate RDF @xsd:integer@ datatyped literals. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Datatype.XSD.Integer + ( rdfDatatypeXsdInteger + , rdfDatatypeValXsdInteger + , typeNameXsdInteger, namespaceXsdInteger + , axiomsXsdInteger, rulesXsdInteger + ) +where + +import Swish.Datatype + ( Datatype(..) + , DatatypeVal(..) + , DatatypeRel(..), DatatypeRelPr + , altArgs + , UnaryFnTable, unaryFnApp + , BinaryFnTable, binaryFnApp + , BinMaybeFnTable, binMaybeFnApp + , DatatypeMod(..) + , makeVmod11inv, makeVmod11 + , makeVmod21inv, makeVmod21 + , makeVmod20 + , makeVmod22 + ) +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (namespaceToBuilder, makeNSScopedName) +import Swish.QName (LName) +import Swish.Ruleset (makeRuleset) + +import Swish.RDF.Datatype (RDFDatatype, RDFDatatypeVal, RDFDatatypeMod) +import Swish.RDF.Datatype (makeRdfDtOpenVarBindingModifiers) +import Swish.RDF.Datatype.XSD.MapInteger (mapXsdInteger) + +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) +import Swish.RDF.Ruleset (makeRDFGraphFromN3Builder, makeRDFFormula) + +import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + ) + +import Data.Monoid(Monoid(..)) +import Control.Monad (liftM) +import Data.Maybe (maybeToList) + +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +-- Local name for Integer datatype +nameXsdInteger :: LName +nameXsdInteger = "integer" + +-- |Type name for @xsd:integer@ datatype. +typeNameXsdInteger :: ScopedName +typeNameXsdInteger = makeNSScopedName namespaceXSD nameXsdInteger + +-- |Namespace for @xsd:integer@ datatype functions. +namespaceXsdInteger :: Namespace +namespaceXsdInteger = namespaceXsdType nameXsdInteger + +-- | The RDFDatatype value for @xsd:integer@. +rdfDatatypeXsdInteger :: RDFDatatype +rdfDatatypeXsdInteger = Datatype rdfDatatypeValXsdInteger + +-- Integer power (exponentiation) function +-- returns Nothing if exponent is negative. +-- +intPower :: Integer -> Integer -> Maybe Integer +intPower a b = if b < 0 then Nothing else Just (intPower1 a b) + where + intPower1 x y + | q == 1 = atopsq*x + | p == 0 = 1 + | otherwise = atopsq + where + (p,q) = y `divMod` 2 + atop = intPower1 x p + atopsq = atop*atop + +------------------------------------------------------------ +-- Implmentation of RDFDatatypeVal for xsd:integer +------------------------------------------------------------ + +-- |Define Datatype value for @xsd:integer@. +-- +-- Members of this datatype are positive or negative integer values. +-- +-- The lexical form consists of an optional @+@ or @-@ +-- followed by a sequence of decimal digits. +-- +-- The canonical lexical form has leading zeros and @+@ sign removed. +-- +rdfDatatypeValXsdInteger :: RDFDatatypeVal Integer +rdfDatatypeValXsdInteger = DatatypeVal + { tvalName = typeNameXsdInteger + , tvalRules = rdfRulesetXsdInteger -- Ruleset RDFGraph + , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger + -- RDFGraph -> [RDFRules] + , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdInteger + , tvalMap = mapXsdInteger -- DatatypeMap Integer + , tvalRel = relXsdInteger -- [DatatypeRel Integer] + , tvalMod = modXsdInteger -- [DatatypeMod Integer] + } + +-- |relXsdInteger contains arithmetic and other relations for xsd:Integer values. +-- +-- The functions are inspired by those defined by CWM as math: properties +-- (). +-- +relXsdInteger :: [DatatypeRel Integer] +relXsdInteger = + [ relXsdIntegerAbs + , relXsdIntegerNeg + , relXsdIntegerSum + , relXsdIntegerDiff + , relXsdIntegerProd + , relXsdIntegerDivMod + , relXsdIntegerPower + , relXsdIntegerEq + , relXsdIntegerNe + , relXsdIntegerLt + , relXsdIntegerLe + , relXsdIntegerGt + , relXsdIntegerGe + ] + +mkIntRel2 :: + LName -> DatatypeRelPr Integer -> UnaryFnTable Integer + -> DatatypeRel Integer +mkIntRel2 nam pr fns = DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns unaryFnApp + } + +mkIntRel3 :: + LName -> DatatypeRelPr Integer -> BinaryFnTable Integer + -> DatatypeRel Integer +mkIntRel3 nam pr fns = DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns binaryFnApp + } + +mkIntRel3maybe :: + LName -> DatatypeRelPr Integer -> BinMaybeFnTable Integer + -> DatatypeRel Integer +mkIntRel3maybe nam pr fns = DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns binMaybeFnApp + } + +relXsdIntegerAbs :: DatatypeRel Integer +relXsdIntegerAbs = mkIntRel2 "abs" (const True) + [ ( (>=0), [ (abs,1) ] ) + , ( const True, [ (id,0), (negate,0) ] ) + ] + +relXsdIntegerNeg :: DatatypeRel Integer +relXsdIntegerNeg = mkIntRel2 "neg" (const True) + [ ( const True, [ (negate,1) ] ) + , ( const True, [ (negate,0) ] ) + ] + +relXsdIntegerSum :: DatatypeRel Integer +relXsdIntegerSum = mkIntRel3 "sum" (const True) + [ ( const True, [ ((+),1,2) ] ) + , ( const True, [ ((-),0,2) ] ) + , ( const True, [ ((-),0,1) ] ) + ] + +relXsdIntegerDiff :: DatatypeRel Integer +relXsdIntegerDiff = mkIntRel3 "diff" (const True) + [ ( const True, [ ((-),1,2) ] ) + , ( const True, [ ((+),0,2) ] ) + , ( const True, [ ((-),1,0) ] ) + ] + +relXsdIntegerProd :: DatatypeRel Integer +relXsdIntegerProd = mkIntRel3 "prod" (const True) + [ ( const True, [ ((*),1,2) ] ) + , ( const True, [ (div,0,2) ] ) + , ( const True, [ (div,0,1) ] ) + ] + +relXsdIntegerDivMod :: DatatypeRel Integer +relXsdIntegerDivMod = mkIntRel3 "divmod" (const True) + [ ( const True, [ (div,2,3) ] ) + , ( const True, [ (mod,2,3) ] ) + , ( const True, [ ] ) + , ( const True, [ ] ) + ] + +-- Compose with function of two arguments +c2 :: (b -> c) -> (a -> d -> b) -> a -> d -> c +c2 = (.) . (.) + +relXsdIntegerPower :: DatatypeRel Integer +relXsdIntegerPower = mkIntRel3maybe "power" (const True) + [ ( const True, [ (liftM (:[]) `c2` intPower,1,2) ] ) + , ( const True, [ ] ) + , ( (>=0), [ ] ) + ] + +liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool +liftL2 p i1 i2 as = p (i1 as) (i2 as) + +lcomp :: (a->a->Bool) -> [a] -> Bool +lcomp p = liftL2 p head (head . tail) + +-- eq + +relXsdIntegerEq :: DatatypeRel Integer +relXsdIntegerEq = mkIntRel2 "eq" (lcomp (==)) + ( repeat (const True, []) ) + +-- ne + +relXsdIntegerNe :: DatatypeRel Integer +relXsdIntegerNe = mkIntRel2 "ne" (lcomp (/=)) + ( repeat (const True, []) ) + +-- lt + +relXsdIntegerLt :: DatatypeRel Integer +relXsdIntegerLt = mkIntRel2 "lt" (lcomp (<)) + ( repeat (const True, []) ) + +-- le + +relXsdIntegerLe :: DatatypeRel Integer +relXsdIntegerLe = mkIntRel2 "le" (lcomp (<=)) + ( repeat (const True, []) ) + +-- gt + +relXsdIntegerGt :: DatatypeRel Integer +relXsdIntegerGt = mkIntRel2 "gt" (lcomp (>)) + ( repeat (const True, []) ) + +-- ge + +relXsdIntegerGe :: DatatypeRel Integer +relXsdIntegerGe = mkIntRel2 "ge" (lcomp (>=)) + ( repeat (const True, []) ) + +-- |modXsdInteger contains variable binding modifiers for xsd:Integer values. +-- +-- The functions are selected from those defined by CWM as math: +-- properties +-- (). +-- +modXsdInteger :: [RDFDatatypeMod Integer] +modXsdInteger = + [ modXsdIntegerAbs + , modXsdIntegerNeg + , modXsdIntegerSum + , modXsdIntegerDiff + , modXsdIntegerProd + , modXsdIntegerDivMod + , modXsdIntegerPower + , modXsdIntegerEq + , modXsdIntegerNe + , modXsdIntegerLt + , modXsdIntegerLe + , modXsdIntegerGt + , modXsdIntegerGe + ] + +modXsdIntegerAbs :: RDFDatatypeMod Integer +modXsdIntegerAbs = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "abs" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod11 + } + where + f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] + f0 _ = [] + f1 [v2] = [abs v2] + f1 _ = [] + +modXsdIntegerNeg :: RDFDatatypeMod Integer +modXsdIntegerNeg = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "neg" + , dmModf = [ f0, f1, f1 ] + , dmAppf = makeVmod11inv + } + where + f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] + f0 _ = [] + f1 [vi] = [-vi] + f1 _ = [] + +modXsdIntegerSum :: RDFDatatypeMod Integer +modXsdIntegerSum = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "sum" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2+v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2+v3] + f1 _ = [] + f2 [v1,vi] = [v1-vi] + f2 _ = [] + +modXsdIntegerDiff :: RDFDatatypeMod Integer +modXsdIntegerDiff = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "diff" + , dmModf = [ f0, f1, f2, f3 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2-v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2-v3] + f1 _ = [] + f2 [v1,v3] = [v1+v3] + f2 _ = [] + f3 [v1,v2] = [v2-v1] + f3 _ = [] + +modXsdIntegerProd :: RDFDatatypeMod Integer +modXsdIntegerProd = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "prod" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod21inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2*v3] + f1 _ = [] + f2 [v1,vi] = if r == 0 then [q] else [] + where (q,r) = quotRem v1 vi + f2 _ = [] + +modXsdIntegerDivMod :: RDFDatatypeMod Integer +modXsdIntegerDivMod = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "divmod" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod22 + } + where + f0 vs@[v1,v2,v3,v4] = if (v1,v2) == divMod v3 v4 then vs else [] + f0 _ = [] + f1 [v3,v4] = [v1,v2] where (v1,v2) = divMod v3 v4 + f1 _ = [] + +modXsdIntegerPower :: RDFDatatypeMod Integer +modXsdIntegerPower = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger "power" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod21 + } + where + f0 vs@[v1,v2,v3] = if Just v1 == intPower v2 v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = maybeToList (intPower v2 v3) + f1 _ = [] + +modXsdIntegerEq, modXsdIntegerNe, modXsdIntegerLt, modXsdIntegerLe, modXsdIntegerGt, modXsdIntegerGe :: RDFDatatypeMod Integer +modXsdIntegerEq = modXsdIntegerCompare "eq" (==) +modXsdIntegerNe = modXsdIntegerCompare "ne" (/=) +modXsdIntegerLt = modXsdIntegerCompare "lt" (<) +modXsdIntegerLe = modXsdIntegerCompare "le" (<=) +modXsdIntegerGt = modXsdIntegerCompare "gt" (>) +modXsdIntegerGe = modXsdIntegerCompare "ge" (>=) + +modXsdIntegerCompare :: + LName -> (Integer->Integer->Bool) -> RDFDatatypeMod Integer +modXsdIntegerCompare nam rel = DatatypeMod + { dmName = makeNSScopedName namespaceXsdInteger nam + , dmModf = [ f0 ] + , dmAppf = makeVmod20 + } + where + f0 vs@[v1,v2] = if rel v1 v2 then vs else [] + f0 _ = [] + +-- |rulesetXsdInteger contains rules and axioms that allow additional +-- deductions when xsd:integer values appear in a graph. +-- +-- The rules defined here are concerned with basic integer arithmetic +-- operations: +, -, *, div, rem +-- +-- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +-- +rdfRulesetXsdInteger :: RDFRuleset +rdfRulesetXsdInteger = + makeRuleset namespaceXsdInteger axiomsXsdInteger rulesXsdInteger + +prefixXsdInteger :: B.Builder +prefixXsdInteger = + mconcat $ map namespaceToBuilder + [ namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdInteger + ] + +mkAxiom :: LName -> B.Builder -> RDFFormula +mkAxiom local gr = + makeRDFFormula namespaceXsdInteger local (prefixXsdInteger `mappend` gr) + +-- | The axioms for @xsd:integer@, which are +-- +-- > xsd:integer a rdfs:Datatype . +-- +axiomsXsdInteger :: [RDFFormula] +axiomsXsdInteger = + [ mkAxiom "dt" "xsd:integer rdf:type rdfs:Datatype ." + ] + +-- | The rules for @xsd:integer@. +rulesXsdInteger :: [RDFRule] +rulesXsdInteger = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr + where + gr = makeRDFGraphFromN3Builder rulesXsdIntegerBuilder + +--- I have removed the newline which was added between each line +--- to improve the clarity of parser errors. +--- +rulesXsdIntegerBuilder :: B.Builder +rulesXsdIntegerBuilder = + mconcat + [ prefixXsdInteger + , "xsd_integer:Abs a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:abs ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Neg a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:neg ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Sum a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_integer:sum ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Diff a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_integer:diff ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Prod a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_integer:prod ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:DivMod a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; " + , " rdfd:constraint xsd_integer:divmod ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Power a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + , " rdfd:constraint xsd_integer:power ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Eq a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:eq ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Ne a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:ne ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Lt a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:lt ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Le a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:le ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Gt a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:gt ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_integer:Ge a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_integer:ge ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + ] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Datatype/XSD/MapDecimal.hs b/src/Swish/RDF/Datatype/XSD/MapDecimal.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Datatype/XSD/MapDecimal.hs @@ -0,0 +1,72 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : MapDecimal +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011 William Waites, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines the datatytpe mapping and relation values +-- used for RDF dataype @xsd:decimal@. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Datatype.XSD.MapDecimal (mapXsdDecimal) where + +import Swish.Datatype (DatatypeMap(..)) + +import qualified Data.Text as T +import qualified Data.Text.Read as T + +------------------------------------------------------------ +-- Implementation of DatatypeMap for xsd:decimal +------------------------------------------------------------ + +-- | Functions that perform lexical-to-value +-- and value-to-canonical-lexical mappings for @xsd:decimal@ values. +-- +mapXsdDecimal :: DatatypeMap Double +mapXsdDecimal = DatatypeMap + { -- mapL2V :: T.Text -> Maybe Double + mapL2V = \txt -> case T.double txt of + Right (val, "") -> Just val + _ -> Nothing + + -- mapV2L :: Double -> Maybe T.Text + -- TODO: for now convert via String as issues with text-format + -- (inability to use with ghci) + , mapV2L = Just . T.pack . show + } + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011 William Waites, 2011, 2012 Douglas Burke +-- +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Datatype/XSD/MapInteger.hs b/src/Swish/RDF/Datatype/XSD/MapInteger.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Datatype/XSD/MapInteger.hs @@ -0,0 +1,70 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : MapInteger +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines the datatytpe mapping and relation values +-- used for RDF dataype @xsd:integer@. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Datatype.XSD.MapInteger (mapXsdInteger) where + +import Swish.Datatype (DatatypeMap(..)) + +import qualified Data.Text as T +import qualified Data.Text.Read as T + +------------------------------------------------------------ +-- Implementation of DatatypeMap for xsd:integer +------------------------------------------------------------ + +-- | Functions that perform lexical-to-value +-- and value-to-canonical-lexical mappings for @xsd:integer@ values. +-- +mapXsdInteger :: DatatypeMap Integer +mapXsdInteger = DatatypeMap + { -- mapL2V :: T.Text -> Maybe Integer + mapL2V = \txt -> case T.signed T.decimal txt of + Right (val, "") -> Just val + _ -> Nothing + + -- mapV2L :: Integer -> Maybe T.Text + -- TODO: for now convert via String as issues with text-format + -- (inability to use with ghci) + , mapV2L = Just . T.pack . show + } + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Datatype/XSD/String.hs b/src/Swish/RDF/Datatype/XSD/String.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Datatype/XSD/String.hs @@ -0,0 +1,327 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : String +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module defines the structures used to represent and +-- manipulate RDF @xsd:string@ datatyped literals. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Datatype.XSD.String + ( rdfDatatypeXsdString + , rdfDatatypeValXsdString + , typeNameXsdString, namespaceXsdString + , axiomsXsdString, rulesXsdString + ) + where + +import Swish.Datatype + ( Datatype(..) + , DatatypeVal(..) + , DatatypeMap(..) + , DatatypeRel(..), DatatypeRelPr + , altArgs + , UnaryFnTable, unaryFnApp + , DatatypeMod(..) + , makeVmod20 + ) + +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (namespaceToBuilder, makeNSScopedName) +import Swish.QName (LName) +import Swish.Ruleset (makeRuleset) +import Swish.VarBinding (VarBinding(..), VarBindingModify(..)) +import Swish.VarBinding (addVarBinding) + +import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) +import Swish.RDF.Datatype (RDFDatatype, RDFDatatypeVal, RDFDatatypeMod) +import Swish.RDF.Datatype (makeRdfDtOpenVarBindingModifiers ) +import Swish.RDF.Graph (RDFLabel(..)) +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) +import Swish.RDF.Ruleset (makeRDFGraphFromN3Builder, makeRDFFormula, makeN3ClosureRule) +import Swish.RDF.VarBinding (RDFVarBindingModify) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + ) + +import Data.Monoid(Monoid(..)) + +import qualified Data.Text as T +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +-- Local name for Integer datatype +nameXsdString :: LName +nameXsdString = "string" + +-- | Type name for @xsd:string@ datatype +typeNameXsdString :: ScopedName +typeNameXsdString = makeNSScopedName namespaceXSD nameXsdString + +-- | Namespace for @xsd:string@ datatype functions +namespaceXsdString :: Namespace +namespaceXsdString = namespaceXsdType nameXsdString + +-- | The RDFDatatype value for @xsd:string@. +rdfDatatypeXsdString :: RDFDatatype +rdfDatatypeXsdString = Datatype rdfDatatypeValXsdString + +------------------------------------------------------------ +-- Implmentation of RDFDatatypeVal for xsd:integer +------------------------------------------------------------ + +-- |Define Datatype value for @xsd:string@. +-- +rdfDatatypeValXsdString :: RDFDatatypeVal T.Text +rdfDatatypeValXsdString = DatatypeVal + { tvalName = typeNameXsdString + , tvalRules = rdfRulesetXsdString + , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString + , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdString + , tvalMap = mapXsdString + , tvalRel = relXsdString + , tvalMod = modXsdString + } + +-- |mapXsdString contains functions that perform lexical-to-value +-- and value-to-canonical-lexical mappings for @xsd:string@ values +-- +-- These are identity mappings. +-- +mapXsdString :: DatatypeMap T.Text +mapXsdString = DatatypeMap + { mapL2V = Just + , mapV2L = Just + } + +-- |relXsdString contains useful relations for @xsd:string@ values. +-- +relXsdString :: [DatatypeRel T.Text] +relXsdString = + [ relXsdStringEq + , relXsdStringNe + ] + +mkStrRel2 :: + LName -> DatatypeRelPr T.Text -> UnaryFnTable T.Text + -> DatatypeRel T.Text +mkStrRel2 nam pr fns = + DatatypeRel + { dtRelName = makeNSScopedName namespaceXsdString nam + , dtRelFunc = altArgs pr fns unaryFnApp + } + +{- +mkStrRel3 :: + String -> DatatypeRelPr String -> BinaryFnTable String + -> DatatypeRel String +mkStrRel3 nam pr fns = DatatypeRel + { dtRelName = ScopedName namespaceXsdString nam + , dtRelFunc = altArgs pr fns binaryFnApp + } + +mkStrRel3maybe :: + String -> DatatypeRelPr String -> BinMaybeFnTable String + -> DatatypeRel String +mkStrRel3maybe nam pr fns = DatatypeRel + { dtRelName = ScopedName namespaceXsdString nam + , dtRelFunc = altArgs pr fns binMaybeFnApp + } +-} + +liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool +liftL2 p i1 i2 as = p (i1 as) (i2 as) + +lcomp :: (a->a->Bool) -> [a] -> Bool +lcomp p = liftL2 p head (head . tail) + +-- eq + +relXsdStringEq :: DatatypeRel T.Text +relXsdStringEq = mkStrRel2 "eq" (lcomp (==)) + ( repeat (const True, []) ) + +-- ne + +relXsdStringNe :: DatatypeRel T.Text +relXsdStringNe = mkStrRel2 "ne" (lcomp (/=)) + ( repeat (const True, []) ) + +-- |modXsdString contains variable binding modifiers for @xsd:string@ values. +-- +modXsdString :: [RDFDatatypeMod T.Text] +modXsdString = + [ modXsdStringEq + , modXsdStringNe + ] + +modXsdStringEq, modXsdStringNe :: RDFDatatypeMod T.Text +modXsdStringEq = modXsdStringCompare "eq" (==) +modXsdStringNe = modXsdStringCompare "ne" (/=) + +modXsdStringCompare :: + LName -> (T.Text->T.Text->Bool) -> RDFDatatypeMod T.Text +modXsdStringCompare nam rel = DatatypeMod + { dmName = makeNSScopedName namespaceXsdString nam + , dmModf = [ f0 ] + , dmAppf = makeVmod20 + } + where + f0 vs@[v1,v2] = if rel v1 v2 then vs else [] + f0 _ = [] + +-- |rulesetXsdString contains rules and axioms that allow additional +-- deductions when xsd:string values appear in a graph. +-- +-- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +-- +rdfRulesetXsdString :: RDFRuleset +rdfRulesetXsdString = + makeRuleset namespaceXsdString axiomsXsdString rulesXsdString + +mkPrefix :: Namespace -> B.Builder +mkPrefix = namespaceToBuilder + +prefixXsdString :: B.Builder +prefixXsdString = + mconcat + [ mkPrefix namespaceRDF + , mkPrefix namespaceRDFS + , mkPrefix namespaceRDFD + , mkPrefix namespaceXSD + , mkPrefix namespaceXsdString + ] + +mkAxiom :: LName -> B.Builder -> RDFFormula +mkAxiom local gr = + makeRDFFormula namespaceXsdString local (prefixXsdString `mappend` gr) + +-- | The axioms for @xsd:string@, which are +-- +-- > xsd:string a rdfs:Datatype . +-- +axiomsXsdString :: [RDFFormula] +axiomsXsdString = + [ mkAxiom "dt" "xsd:string rdf:type rdfs:Datatype ." + ] + +-- | The rules for @xsd:string@. +rulesXsdString :: [RDFRule] +rulesXsdString = rulesXsdStringClosure ++ rulesXsdStringRestriction + +rulesXsdStringRestriction :: [RDFRule] +rulesXsdStringRestriction = + makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString gr + where + gr = makeRDFGraphFromN3Builder rulesXsdStringBuilder + +rulesXsdStringBuilder :: B.Builder +rulesXsdStringBuilder = + mconcat + [ prefixXsdString + , "xsd_string:Eq a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_string:eq ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + , "xsd_string:Ne a rdfd:GeneralRestriction ; " + , " rdfd:onProperties (rdf:_1 rdf:_2) ; " + , " rdfd:constraint xsd_string:ne ; " + , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + ] + +rulesXsdStringClosure :: [RDFRule] +rulesXsdStringClosure = + [ xsdstrls + , xsdstrsl + ] + +-- Infer string from plain literal +xsdstrls :: RDFRule +xsdstrls = makeN3ClosureRule namespaceXsdString "ls" + "?a ?p ?l ." + "?a ?p ?s ." + (stringPlain "s" "l") + +-- Infer plain literal from string +xsdstrsl :: RDFRule +xsdstrsl = makeN3ClosureRule namespaceXsdString "sl" + "?a ?p ?s ." + "?a ?p ?l ." + (stringPlain "s" "l") + +-- Map between string and plain literal values +stringPlain :: String -> String -> RDFVarBindingModify +stringPlain svar lvar = stringPlainValue (Var svar) (Var lvar) + +-- Variable binding modifier to create new binding to a canonical +-- form of a datatyped literal. +stringPlainValue :: + RDFLabel -> RDFLabel -> RDFVarBindingModify +stringPlainValue svar lvar = VarBindingModify + { vbmName = makeNSScopedName namespaceRDFD "stringPlain" + , vbmApply = concatMap app1 + , vbmVocab = [svar,lvar] + , vbmUsage = [[svar],[lvar],[]] + } + where + app1 vbind = app2 (vbMap vbind svar) (vbMap vbind lvar) vbind + + -- Going to assume can only get TypedLit here, and assume LangLit + -- can be ignored. + app2 (Just (TypedLit s _)) + (Just (Lit l)) + vbind + | s == l + = [vbind] + app2 (Just (TypedLit s _)) + Nothing + vbind + = [addVarBinding lvar (Lit s) vbind] + app2 Nothing + (Just (Lit l)) + vbind + = [addVarBinding svar (TypedLit l typeNameXsdString) vbind] + app2 _ _ _ = [] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Formatter/N3.hs b/src/Swish/RDF/Formatter/N3.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Formatter/N3.hs @@ -0,0 +1,943 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3 +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Notation 3 formatter +-- for an 'RDFGraph' value. +-- +-- REFERENCES: +-- +-- - \"Notation3 (N3): A readable RDF syntax\", +-- W3C Team Submission 14 January 2008, +-- +-- +-- - Tim Berners-Lee's design issues series notes and description, +-- +-- +-- - Notation 3 Primer by Sean Palmer, +-- +-- +-- TODO: +-- +-- * Initial prefix list to include nested formulae; +-- then don't need to update prefix list for these. +-- +-- * correct output of strings containing unsupported escape +-- characters (such as @\\q@) +-- +-- * more flexible terminator generation for formatted formulae +-- (for inline blank nodes.) +-- +-------------------------------------------------------------------------------- + +{- +TODO: + +The code used to determine whether a blank node can be written +using the "[]" short form could probably take advantage of the +GraphPartition module. + +-} + +module Swish.RDF.Formatter.N3 + ( NodeGenLookupMap + , formatGraphAsText + , formatGraphAsLazyText + , formatGraphAsBuilder + , formatGraphIndent + , formatGraphDiag + ) +where + +import Swish.GraphClass (Arc(..)) +import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI) +import Swish.QName (getLName) + +import Swish.RDF.Graph ( + RDFGraph, RDFLabel(..), + NamespaceMap, RevNamespaceMap, + emptyNamespaceMap, + FormulaMap, emptyFormulaMap, + getArcs, labels, + setNamespaces, getNamespaces, + getFormulae, + emptyRDFGraph + , quote + , quoteT + , resRdfFirst, resRdfRest, resRdfNil + ) + +import Swish.RDF.Vocabulary ( + fromLangTag, + rdfType, + rdfNil, + owlSameAs, logImplies + , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble + ) + +import Control.Monad (liftM, when, void) +import Control.Monad.State (State, modify, get, put, runState) + +import Data.Char (isDigit) +import Data.List (foldl', delete, groupBy, partition, sort, intersperse) +import Data.LookupMap (LookupEntryClass(..), LookupMap) +import Data.LookupMap (emptyLookupMap, reverseLookupMap, listLookupMap + , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge) +import Data.Monoid (Monoid(..)) +import Data.Word (Word32) + +-- it strikes me that using Lazy Text here is likely to be +-- wrong; however I have done no profiling to back this +-- assumption up! + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B + +-- temporary conversion +quoteB :: Bool -> String -> B.Builder +quoteB f v = B.fromString $ quote f v + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- The graph to be formatted is carried as part of the formatting +-- state, so that decisions about what needs to be formatted can +-- themselves be based upon and reflected in the state (e.g. if a +-- decision is made to include a blank node inline, it can be removed +-- from the graph state that remains to be formatted). + +type SubjTree lb = [(lb,PredTree lb)] +type PredTree lb = [(lb,[lb])] + +data N3FormatterState = N3FS + { indent :: B.Builder + , lineBreak :: Bool + , graph :: RDFGraph + , subjs :: SubjTree RDFLabel + , props :: PredTree RDFLabel -- for last subject selected + , objs :: [RDFLabel] -- for last property selected + , formAvail :: FormulaMap RDFLabel + , formQueue :: [(RDFLabel,RDFGraph)] + , nodeGenSt :: NodeGenState + , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format + , traceBuf :: [String] + } + +type Formatter a = State N3FormatterState a + +emptyN3FS :: NodeGenState -> N3FormatterState +emptyN3FS ngs = N3FS + { indent = "\n" + , lineBreak = False + , graph = emptyRDFGraph + , subjs = [] + , props = [] + , objs = [] + , formAvail = emptyFormulaMap + , formQueue = [] + , nodeGenSt = ngs + , bNodesCheck = [] + , traceBuf = [] + } + +-- | Node name generation state information that carries through +-- and is updated by nested formulae. +type NodeGenLookupMap = LookupMap (RDFLabel, Word32) + +data NodeGenState = Ngs + { prefixes :: NamespaceMap + , nodeMap :: NodeGenLookupMap + , nodeGen :: Word32 + } + +emptyNgs :: NodeGenState +emptyNgs = Ngs + { prefixes = emptyLookupMap + , nodeMap = emptyLookupMap + , nodeGen = 0 + } + +-- simple context for label creation +-- (may be a temporary solution to the problem +-- of label creation) +-- +data LabelContext = SubjContext | PredContext | ObjContext + deriving (Eq, Show) + +getIndent :: Formatter B.Builder +getIndent = indent `liftM` get + +setIndent :: B.Builder -> Formatter () +setIndent ind = modify $ \st -> st { indent = ind } + +getLineBreak :: Formatter Bool +getLineBreak = lineBreak `liftM` get + +setLineBreak :: Bool -> Formatter () +setLineBreak brk = modify $ \st -> st { lineBreak = brk } + +getNgs :: Formatter NodeGenState +getNgs = nodeGenSt `liftM` get + +setNgs :: NodeGenState -> Formatter () +setNgs ngs = modify $ \st -> st { nodeGenSt = ngs } + +getPrefixes :: Formatter NamespaceMap +getPrefixes = prefixes `liftM` getNgs + +getSubjs :: Formatter (SubjTree RDFLabel) +getSubjs = subjs `liftM` get + +setSubjs :: SubjTree RDFLabel -> Formatter () +setSubjs sl = modify $ \st -> st { subjs = sl } + +getProps :: Formatter (PredTree RDFLabel) +getProps = props `liftM` get + +setProps :: PredTree RDFLabel -> Formatter () +setProps ps = modify $ \st -> st { props = ps } + +{- +getObjs :: Formatter ([RDFLabel]) +getObjs = objs `liftM` get + +setObjs :: [RDFLabel] -> Formatter () +setObjs os = do + st <- get + put $ st { objs = os } +-} + +getBnodesCheck :: Formatter [RDFLabel] +getBnodesCheck = bNodesCheck `liftM` get + +{- +addTrace :: String -> Formatter () +addTrace tr = do + st <- get + put $ st { traceBuf = tr : traceBuf st } +-} + +queueFormula :: RDFLabel -> Formatter () +queueFormula fn = do + st <- get + let fa = formAvail st + newState fv = st { + formAvail = mapDelete fa fn, + formQueue = (fn,fv) : formQueue st + } + case mapFindMaybe fn fa of + Nothing -> return () + Just v -> void $ put $ newState v + +{- +Return the graph associated with the label and delete it +from the store, if there is an association, otherwise +return Nothing. +-} +extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) +extractFormula fn = do + st <- get + let fa = formAvail st + newState = st { formAvail=mapDelete fa fn } + case mapFindMaybe fn fa of + Nothing -> return Nothing + Just fv -> put newState >> return (Just fv) + +{- +moreFormulae :: Formatter Bool +moreFormulae = do + st <- get + return $ not $ null (formQueue st) + +nextFormula :: Formatter (RDFLabel,RDFGraph) +nextFormula = do + st <- get + let (nf : fq) = formQueue st + put $ st { formQueue = fq } + return nf + +-} + +-- list has a length of 1 +len1 :: [a] -> Bool +len1 (_:[]) = True +len1 _ = False + +{-| +Given a set of statements and a label, return the details of the +RDF collection referred to by label, or Nothing. + +For label to be considered as representing a collection we require the +following conditions to hold (this is only to support the +serialisation using the '(..)' syntax and does not make any statement +about semantics of the statements with regard to RDF Collections): + + - there must be one rdf_first and one rdfRest statement + - there must be no other predicates for the label + +-} +getCollection :: + SubjTree RDFLabel -- ^ statements organized by subject + -> RDFLabel -- ^ does this label represent a list? + -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) + -- ^ the statements with the elements removed; the + -- content elements of the collection (the objects of the rdf:first + -- predicate) and the nodes that represent the spine of the + -- collection (in reverse order, unlike the actual contents which are in + -- order). +getCollection subjList lbl = go subjList lbl ([],[]) + where + go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) + | otherwise = do + (pList1, sl') <- removeItem sl l + (pFirst, pList2) <- removeItem pList1 resRdfFirst + (pNext, pList3) <- removeItem pList2 resRdfRest + + -- QUS: could I include these checks implicitly in the pattern matches above? + -- ie instrad of (pFirst, pos1) <- .. + -- have ([content], pos1) <- ... + -- ? + if and [len1 pFirst, len1 pNext, null pList3] + then go sl' (head pNext) (head pFirst : cs, l : ss) + else Nothing + +{- +TODO: + +Should we change the preds/objs entries as well? + +-} +extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) +extractList lctxt ln = do + osubjs <- getSubjs + oprops <- getProps + let mlst = getCollection osubjs' ln + + -- we only want to send in rdf:first/rdf:rest here + fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops + + osubjs' = + case lctxt of + SubjContext -> (ln, fprops) : osubjs + _ -> osubjs + + -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" + -- addTrace tr + case mlst of + -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext + Just (sl,ls,_) -> do + setSubjs sl + when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops + return (Just ls) + + Nothing -> return Nothing + +{-| +Removes the first occurrence of the item from the +association list, returning it's contents and the rest +of the list, if it exists. +-} +removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) +removeItem os x = + let (as, bs) = break (\a -> fst a == x) os + in case bs of + ((_,b):bbs) -> Just (b, as ++ bbs) + [] -> Nothing + +---------------------------------------------------------------------- +-- Define a top-level formatter function: +---------------------------------------------------------------------- + +-- | Convert the graph to text. +formatGraphAsText :: RDFGraph -> T.Text +formatGraphAsText = L.toStrict . formatGraphAsLazyText + +-- | Convert the graph to text. +formatGraphAsLazyText :: RDFGraph -> L.Text +formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder + +-- | Convert the graph to a Builder. +formatGraphAsBuilder :: RDFGraph -> B.Builder +formatGraphAsBuilder = formatGraphIndent "\n" True + +-- | Convert the graph to a builder using the given indentation text. +formatGraphIndent :: + B.Builder -- ^ indentation text + -> Bool -- ^ are prefixes to be generated? + -> RDFGraph -- ^ graph + -> B.Builder +formatGraphIndent indnt flag gr = + let (res, _, _, _) = formatGraphDiag indnt flag gr + in res + +-- | Format graph and return additional information +formatGraphDiag :: + B.Builder -- ^ indentation + -> Bool -- ^ are prefixes to be generated? + -> RDFGraph + -> (B.Builder, NodeGenLookupMap, Word32, [String]) +formatGraphDiag indnt flag gr = + let fg = formatGraph indnt " .\n" False flag gr + ngs = emptyNgs { + prefixes = emptyLookupMap, + nodeGen = findMaxBnode gr + } + + (out, fgs) = runState fg (emptyN3FS ngs) + ogs = nodeGenSt fgs + + in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs) + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +formatGraph :: + B.Builder -- indentation string + -> B.Builder -- text to be placed after final statement + -> Bool -- True if a line break is to be inserted at the start + -> Bool -- True if prefix strings are to be generated + -> RDFGraph -- graph to convert + -> Formatter B.Builder +formatGraph ind end dobreak dopref gr = do + setIndent ind + setLineBreak dobreak + setGraph gr + + fp <- if dopref + then formatPrefixes (getNamespaces gr) + else return mempty + more <- moreSubjects + if more + then do + fr <- formatSubjects + return $ mconcat [fp, fr, end] + else return fp + +formatPrefixes :: NamespaceMap -> Formatter B.Builder +formatPrefixes pmap = do + let mls = map (pref . keyVal) (listLookupMap pmap) + ls <- sequence mls + return $ mconcat ls + where + pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."] + pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."] + +{- +NOTE: +I expect there to be confusion below where I need to +convert from Text to Builder +-} + +formatSubjects :: Formatter B.Builder +formatSubjects = do + sb <- nextSubject + sbstr <- formatLabel SubjContext sb + + flagP <- moreProperties + if flagP + then do + prstr <- formatProperties sb sbstr + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [prstr, " .", fr] + else return prstr + + else do + txt <- nextLine sbstr + + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [txt, " .", fr] + else return txt + +{- +TODO: now we are throwing a Builder around it is awkward to +get the length of the text to calculate the indentation + +So + + a) change the indentation scheme + b) pass around text instead of builder + +mkIndent :: L.Text -> L.Text +mkIndent inVal = L.replicate (L.length inVal) " " +-} + +hackIndent :: B.Builder +hackIndent = " " + +formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder +formatProperties sb sbstr = do + pr <- nextProperty sb + prstr <- formatLabel PredContext pr + obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] + more <- moreProperties + let sbindent = hackIndent -- mkIndent sbstr + if more + then do + fr <- formatProperties sb sbindent + nl <- nextLine $ obstr `mappend` " ;" + return $ nl `mappend` fr + else nextLine obstr + +formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder +formatObjects sb pr prstr = do + ob <- nextObject sb pr + obstr <- formatLabel ObjContext ob + more <- moreObjects + if more + then do + let prindent = hackIndent -- mkIndent prstr + fr <- formatObjects sb pr prindent + nl <- nextLine $ mconcat [prstr, " ", obstr, ","] + return $ nl `mappend` fr + else return $ mconcat [prstr, " ", obstr] + +insertFormula :: RDFGraph -> Formatter B.Builder +insertFormula gr = do + ngs0 <- getNgs + ind <- getIndent + let grm = formatGraph (ind `mappend` " ") "" True False + (setNamespaces emptyNamespaceMap gr) + + (f3str, fgs') = runState grm (emptyN3FS ngs0) + + setNgs (nodeGenSt fgs') + f4str <- nextLine " } " + return $ mconcat [" { ",f3str, f4str] + +{- +Add a list inline. We are given the labels that constitute +the list, in order, so just need to display them surrounded +by (). +-} +insertList :: [RDFLabel] -> Formatter B.Builder +insertList [] = return "()" -- not convinced this can happen +insertList xs = do + ls <- mapM (formatLabel ObjContext) xs + return $ mconcat ("( " : intersperse " " ls) `mappend` " )" + +{- +Add a blank node inline. +-} + +insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder +insertBnode SubjContext lbl = do + flag <- moreProperties + txt <- if flag + then (`mappend` "\n") `liftM` formatProperties lbl "" + else return "" + + -- TODO: handle indentation? + return $ mconcat ["[", txt, "]"] + +insertBnode _ lbl = do + ost <- get + let osubjs = subjs ost + oprops = props ost + oobjs = objs ost + + (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs + + rprops = case bsubj of + [(_,rs)] -> rs + _ -> [] + + -- we essentially want to create a new subgraph + -- for this node but it's not as simple as that since + -- we could have something like + -- :a :b [ :foo [ :bar "xx" ] ] + -- so we still need to carry around the whole graph + -- + nst = ost { subjs = rsubjs, + props = rprops, + objs = [] + } + + put nst + flag <- moreProperties + txt <- if flag + then (`mappend` "\n") `liftM` formatProperties lbl "" + else return "" + + -- TODO: how do we restore the original set up? + -- I can't believe the following is sufficient + -- + nst' <- get + let slist = map fst $ subjs nst' + nsubjs = filter (\(l,_) -> l `elem` slist) osubjs + + put $ nst' { subjs = nsubjs, + props = oprops, + objs = oobjs + } + + -- TODO: handle indentation? + return $ mconcat ["[", txt, "]"] + +---------------------------------------------------------------------- +-- Formatting helpers +---------------------------------------------------------------------- + +setGraph :: RDFGraph -> Formatter () +setGraph gr = do + st <- get + + let ngs0 = nodeGenSt st + pre' = mapMerge (prefixes ngs0) (getNamespaces gr) + ngs' = ngs0 { prefixes = pre' } + arcs = sortArcs $ getArcs gr + nst = st { graph = gr + , subjs = arcTree arcs + , props = [] + , objs = [] + , formAvail = getFormulae gr + , nodeGenSt = ngs' + , bNodesCheck = countBnodes arcs + } + + put nst + +hasMore :: (N3FormatterState -> [b]) -> Formatter Bool +hasMore lens = (not . null . lens) `liftM` get + +moreSubjects :: Formatter Bool +moreSubjects = hasMore subjs +-- moreSubjects = (not . null . subjs) `liftM` get + +moreProperties :: Formatter Bool +moreProperties = hasMore props +-- moreProperties = (not . null . props) `liftM` get + +moreObjects :: Formatter Bool +moreObjects = hasMore objs +-- moreObjects = (not . null . objs) `liftM` get + +nextSubject :: Formatter RDFLabel +nextSubject = do + st <- get + + let sb:sbs = subjs st + nst = st { subjs = sbs + , props = snd sb + , objs = [] + } + + put nst + return $ fst sb + +nextProperty :: RDFLabel -> Formatter RDFLabel +nextProperty _ = do + st <- get + + let pr:prs = props st + nst = st { props = prs + , objs = snd pr + } + + put nst + return $ fst pr + +nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel +nextObject _ _ = do + st <- get + + let ob:obs = objs st + nst = st { objs = obs } + + put nst + return ob + +nextLine :: B.Builder -> Formatter B.Builder +nextLine str = do + ind <- getIndent + brk <- getLineBreak + if brk + then return $ ind `mappend` str + else do + -- After first line, always insert line break + setLineBreak True + return str + +-- Format a label +-- Most labels are simply displayed as provided, but there are a +-- number of wrinkles to take care of here: +-- (a) blank nodes automatically allocated on input, with node +-- identifiers of the form of a digit string nnn. These are +-- not syntactically valid, and are reassigned node identifiers +-- of the form _nnn, where nnn is chosen so that is does not +-- clash with any other identifier in the graph. +-- (b) URI nodes: if possible, replace URI with qname, +-- else display as +-- (c) formula nodes (containing graphs). +-- (d) use the "special-case" formats for integer/float/double +-- literals. +-- +-- [[[TODO:]]] +-- (d) generate multi-line literals when appropriate +-- +-- This is being updated to produce inline formula, lists and +-- blank nodes. The code is not efficient. +-- + +specialTable :: [(ScopedName, String)] +specialTable = + [ (rdfType, "a") + , (owlSameAs, "=") + , (logImplies, "=>") + , (rdfNil, "()") + ] + +formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder +{- +formatLabel lab@(Blank (_:_)) = do + name <- formatNodeId lab + queueFormula lab + return name +-} + +{- +The "[..]" conversion is done last, after "()" and "{}" checks. +-} +formatLabel lctxt lab@(Blank (_:_)) = do + mlst <- extractList lctxt lab + case mlst of + Just lst -> insertList lst + Nothing -> do + mfml <- extractFormula lab + case mfml of + Just fml -> insertFormula fml + Nothing -> do + nb1 <- getBnodesCheck + if lctxt /= PredContext && lab `notElem` nb1 + then insertBnode lctxt lab + else formatNodeId lab + +formatLabel _ lab@(Res sn) = + case lookup sn specialTable of + Just txt -> return $ quoteB True txt -- TODO: do we need to quote? + Nothing -> do + pr <- getPrefixes + let nsuri = getScopeURI sn + local = getLName $ getScopeLocal sn + premap = reverseLookupMap pr :: RevNamespaceMap + prefix = mapFindMaybe nsuri premap + + name = case prefix of + Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames + _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] + + {- + name = case prefix of + Just p -> quoteB True (p ++ ":" ++ local) -- TODO: what are quoting rules for QNames + _ -> mconcat ["<", quoteB True (nsuri++local), ">"] + -} + + queueFormula lab + return name + +-- The canonical notation for xsd:double in XSD, with an upper-case E, +-- does not match the syntax used in N3, so we need to convert here. +-- Rather than converting back to a Double and then displaying that +-- we just convert E to e for now. +-- +formatLabel _ (TypedLit lit dtype) + | dtype == xsdDouble = return $ B.fromText $ T.toLower lit + | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit + | otherwise = return $ quoteText lit `mappend` "^^" `mappend` showScopedName dtype +formatLabel _ (LangLit lit lcode) = + return $ quoteText lit `mappend` "@" `mappend` B.fromText (fromLangTag lcode) +formatLabel _ (Lit lit) = return $ quoteText lit + +formatLabel _ lab = return $ B.fromString $ show lab + +{- +We have to decide whether to use " or """ to quote +the string. + +There is also no need to restrict the string to the +ASCII character set; this could be an option but we +can also leave Unicode as is (or at least convert to UTF-8). + +If we use """ to surround the string then we protect the +last character if it is a " (assuming it isn't protected). +-} + +quoteText :: T.Text -> B.Builder +quoteText txt = + let st = T.unpack txt -- TODO: fix + qst = quoteB (n==1) st + n = if '\n' `elem` st || '"' `elem` st then 3 else 1 + qch = B.fromString (replicate n '"') + in mconcat [qch, qst, qch] + +formatNodeId :: RDFLabel -> Formatter B.Builder +formatNodeId lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab +formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall + +mapBlankNode :: RDFLabel -> Formatter B.Builder +mapBlankNode lab = do + ngs <- getNgs + let cmap = nodeMap ngs + cval = nodeGen ngs + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + setNgs $ ngs { nodeGen = nval, nodeMap = nmap } + return nval + + n -> return n + + -- TODO: is this what we want? + return $ "_:swish" `mappend` B.fromString (show nv) + +-- TODO: need to be a bit more clever with this than we did in NTriples +-- not sure the following counts as clever enough ... +-- +showScopedName :: ScopedName -> B.Builder +{- +showScopedName (ScopedName n l) = + let uri = nsURI n ++ l + in quote uri +-} +showScopedName = quoteB True . show + +---------------------------------------------------------------------- +-- Graph-related helper functions +---------------------------------------------------------------------- + +newtype SortedArcs lb = SA [Arc lb] + +sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb +sortArcs = SA . sort + +-- Rearrange a list of arcs into a tree of pairs which group together +-- all statements for a single subject, and similarly for multiple +-- objects of a common predicate. +-- +arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb +arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as + where + spopair (Arc s p o) = (s,(p,o)) + +{- +arcTree as = map spopair $ sort as + where + spopair (Arc s p o) = (s,[(p,[o])]) +-} + +-- Rearrange a list of pairs so that multiple occurrences of the first +-- are commoned up, and the supplied function is applied to each sublist +-- with common first elements to obtain the corresponding second value +commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] +commonFstEq f ps = + [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] + where + fstEq (f1,_) (f2,_) = f1 == f2 + +{- +-- Diagnostic code for checking arcTree logic: +testArcTree = (arcTree testArcTree1) == testArcTree2 +testArcTree1 = + [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" + ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" + ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" + ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" + ] +testArcTree2 = + [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) + ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) + ] +-} + + +findMaxBnode :: RDFGraph -> Word32 +findMaxBnode = maximum . map getAutoBnodeIndex . labels + +getAutoBnodeIndex :: RDFLabel -> Word32 +getAutoBnodeIndex (Blank ('_':lns)) = res where + -- cf. prelude definition of read s ... + res = case [x | (x,t) <- reads lns, ("","") <- lex t] of + [x] -> x + _ -> 0 +getAutoBnodeIndex _ = 0 + +{- +Find all blank nodes that occur + - any number of times as a subject + - 0 or 1 times as an object + +Such nodes can be output using the "[..]" syntax. To make it simpler +to check we actually store those nodes that can not be expanded. + +Note that we do not try and expand any bNode that is used in +a predicate position. + +Should probably be using the SubjTree RDFLabel structure but this +is easier for now. + +-} + +countBnodes :: SortedArcs RDFLabel -> [RDFLabel] +countBnodes (SA as) = snd (foldl' ctr ([],[]) as) + where + -- first element of tuple are those blank nodes only seen once, + -- second element those blank nodes seen multiple times + -- + inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (l:b1s, bms) + inc b _ = b + + -- if the bNode appears as a predicate we instantly add it to the + -- list of nodes not to expand, even if only used once + incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (b1s, l:bms) + incP b _ = b + + ctr orig (Arc _ p o) = inc (incP orig p) o + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Formatter/NTriples.hs b/src/Swish/RDF/Formatter/NTriples.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Formatter/NTriples.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : NTriples +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a NTriples formatter for an 'RDFGraph'. +-- +-- REFERENCES: +-- +-- - \"RDF Test Cases\", +-- W3C Recommendation 10 February 2004, +-- +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Formatter.NTriples + ( formatGraphAsText + , formatGraphAsLazyText + , formatGraphAsBuilder + ) +where + +import Swish.GraphClass (Arc(..)) +import Swish.Namespace (ScopedName, getQName) + +import Swish.RDF.Graph (RDFGraph, RDFLabel(..)) +import Swish.RDF.Graph (getArcs) + +import Swish.RDF.Vocabulary (fromLangTag) + +import Control.Monad.State +import Control.Applicative ((<$>)) + +import Data.Char (ord, intToDigit, toUpper) +import Data.LookupMap (LookupMap, emptyLookupMap, mapFind, mapAdd) +import Data.Monoid + +-- it strikes me that using Lazy Text here is likely to be +-- wrong; however I have done no profiling to back this +-- assumption up! + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- This is a lot simpler than other formatters. + +-- | Node name generation state information that carries through +-- and is updated by nested formulae +type NodeGenLookupMap = LookupMap (RDFLabel,Int) + +data NTFormatterState = NTFS { + ntfsNodeMap :: NodeGenLookupMap, + ntfsNodeGen :: Int + } deriving Show + +emptyNTFS :: NTFormatterState +emptyNTFS = NTFS { + ntfsNodeMap = emptyLookupMap, + ntfsNodeGen = 0 + } + +type Formatter a = State NTFormatterState a + +-- | Convert a RDF graph to NTriples format. +formatGraphAsText :: RDFGraph -> T.Text +formatGraphAsText = L.toStrict . formatGraphAsLazyText + +-- | Convert a RDF graph to NTriples format. +formatGraphAsLazyText :: RDFGraph -> L.Text +formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder + +-- | Convert a RDF graph to NTriples format. +formatGraphAsBuilder :: RDFGraph -> B.Builder +formatGraphAsBuilder gr = fst $ runState (formatGraph gr) emptyNTFS + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +formatGraph :: RDFGraph -> Formatter B.Builder +formatGraph gr = mconcat <$> mapM formatArc (getArcs gr) + +-- TODO: this reverses the contents but may be faster? +-- that is if I've got the order right in the mappend call +-- formatGraphBuilder gr = foldl' (\a b -> b `mappend` (formatArcBuilder a)) B.empty (getArcs gr) + +space, nl :: B.Builder +space = B.singleton ' ' +nl = " .\n" + +formatArc :: Arc RDFLabel -> Formatter B.Builder +formatArc (Arc s p o) = do + sl <- formatLabel s + pl <- formatLabel p + ol <- formatLabel o + return $ mconcat [sl, space, pl, space, ol, nl] + -- return $ sl `mappend` $ space `mappend` $ pl `mappend` $ space `mappend` $ ol `mappend` nl + +{- +If we have a blank node then can + + - use the label it contains + - generate a new one on output + +For now we create new labels whatever the input was since this +simplifies things, but it may be changed. + +formatLabel :: RDFLabel -> Formatter String +formatLabel lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ show lab +formatLabel lab = return $ show lab +-} + +squote, at, carets :: B.Builder +squote = "\"" +at = "@" +carets = "^^" + +formatLabel :: RDFLabel -> Formatter B.Builder +formatLabel lab@(Blank _) = mapBlankNode lab +formatLabel (Res sn) = return $ showScopedName sn +formatLabel (Lit lit) = return $ quoteText lit +formatLabel (LangLit lit lang) = return $ mconcat [quoteText lit, at, B.fromText (fromLangTag lang)] +formatLabel (TypedLit lit dt) = return $ mconcat [quoteText lit, carets, showScopedName dt] + +-- do not expect to get the following, but include +-- just in case rather than failing +formatLabel lab = return $ B.fromString $ show lab + +mapBlankNode :: RDFLabel -> Formatter B.Builder +mapBlankNode lab = do + st <- get + let cmap = ntfsNodeMap st + cval = ntfsNodeGen st + + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + + put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval } + return nval + + n -> return n + + return $ "_:swish" `mappend` B.fromString (show nv) + +-- TODO: can we use Network.URI to protect the URI? +showScopedName :: ScopedName -> B.Builder +{- +showScopedName (ScopedName n l) = + let uri = T.pack (show (nsURI n)) `mappend` l + in mconcat ["<", B.fromText (quote uri), ">"] +-} +-- showScopedName s = mconcat ["<", B.fromText (quote (T.pack (show (getQName s)))), ">"] +showScopedName s = B.fromText (quote (T.pack (show (getQName s)))) -- looks like qname already adds the <> around this + +quoteText :: T.Text -> B.Builder +quoteText st = mconcat [squote, B.fromText (quote st), squote] + +{- +QUS: should we be operating on Text like this? +-} + +quote :: T.Text -> T.Text +quote = T.concatMap quoteT + +quoteT :: Char -> T.Text +quoteT '\\' = "\\\\" +quoteT '"' = "\\\"" +quoteT '\n' = "\\n" +quoteT '\t' = "\\t" +quoteT '\r' = "\\r" +quoteT c = + let nc = ord c + + in if nc > 0xffff + then T.pack ('\\':'U': numToHex 8 nc) + else if nc > 0x7e || nc < 0x20 + then T.pack ('\\':'u': numToHex 4 nc) + else T.singleton c + +-- we assume c > 0, n >= 0 and that the input value fits +-- into the requested number of digits +numToHex :: Int -> Int -> String +numToHex c = go [] + where + go s 0 = replicate (c - length s) '0' ++ s + go s n = + let (m,x) = divMod n 16 + in go (iToD x:s) m + + -- Data.Char.intToDigit uses lower-case Hex + iToD x | x < 10 = intToDigit x + | otherwise = toUpper $ intToDigit x + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Formatter/Turtle.hs b/src/Swish/RDF/Formatter/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Formatter/Turtle.hs @@ -0,0 +1,877 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Turtle +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Turtle formatter +-- for an 'RDFGraph' value. +-- +-- REFERENCES: +-- +-- - \"Turtle, Terse RDF Triple Language\", +-- W3C Working Draft 09 August 2011 () +-- +-- +-------------------------------------------------------------------------------- + +{- +TODO: + +The code used to determine whether a blank node can be written +using the "[]" short form could probably take advantage of the +GraphPartition module. + +-} + +module Swish.RDF.Formatter.Turtle + ( NodeGenLookupMap + , formatGraphAsText + , formatGraphAsLazyText + , formatGraphAsBuilder + , formatGraphIndent + , formatGraphDiag + + -- -- * Auxillary routines + -- , quoteText + ) +where + +import Swish.GraphClass (Arc(..)) +import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI) +import Swish.QName (getLName) + +import Swish.RDF.Graph ( + RDFGraph, RDFLabel(..) + , NamespaceMap, RevNamespaceMap + -- emptyNamespaceMap, + -- FormulaMap, emptyFormulaMap, + , getArcs + , labels + -- , setNamespaces + , getNamespaces, + -- getFormulae, + emptyRDFGraph + , quote + , quoteT + , resRdfFirst, resRdfRest, resRdfNil + ) + +import Swish.RDF.Vocabulary ( fromLangTag + , rdfType + , rdfNil + , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble + ) + +import Control.Monad (liftM, when) +import Control.Monad.State (State, modify, get, put, runState) + +import Data.Char (isDigit) +import Data.List (foldl', delete, groupBy, partition, sort, intersperse) +import Data.LookupMap (LookupEntryClass(..), LookupMap) +import Data.LookupMap (emptyLookupMap, reverseLookupMap, listLookupMap, mapFind, mapFindMaybe, mapAdd, mapMerge) +import Data.Monoid (Monoid(..)) +import Data.Word (Word32) + +-- it strikes me that using Lazy Text here is likely to be +-- wrong; however I have done no profiling to back this +-- assumption up! + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B + +-- temporary conversion +quoteB :: Bool -> String -> B.Builder +quoteB f v = B.fromString $ quote f v + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- The graph to be formatted is carried as part of the formatting +-- state, so that decisions about what needs to be formatted can +-- themselves be based upon and reflected in the state (e.g. if a +-- decision is made to include a blank node inline, it can be removed +-- from the graph state that remains to be formatted). + +type SubjTree lb = [(lb,PredTree lb)] +type PredTree lb = [(lb,[lb])] + +data TurtleFormatterState = TFS + { indent :: B.Builder + , lineBreak :: Bool + , graph :: RDFGraph + , subjs :: SubjTree RDFLabel + , props :: PredTree RDFLabel -- for last subject selected + , objs :: [RDFLabel] -- for last property selected + -- , formAvail :: FormulaMap RDFLabel + -- , formQueue :: [(RDFLabel,RDFGraph)] + , nodeGenSt :: NodeGenState + , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format + , traceBuf :: [String] + } + +type Formatter a = State TurtleFormatterState a + +emptyTFS :: NodeGenState -> TurtleFormatterState +emptyTFS ngs = TFS + { indent = "\n" + , lineBreak = False + , graph = emptyRDFGraph + , subjs = [] + , props = [] + , objs = [] + -- , formAvail = emptyFormulaMap + -- , formQueue = [] + , nodeGenSt = ngs + , bNodesCheck = [] + , traceBuf = [] + } + +-- | Node name generation state information. +type NodeGenLookupMap = LookupMap (RDFLabel, Word32) + +data NodeGenState = Ngs + { prefixes :: NamespaceMap + , nodeMap :: NodeGenLookupMap + , nodeGen :: Word32 + } + +emptyNgs :: NodeGenState +emptyNgs = Ngs + { prefixes = emptyLookupMap + , nodeMap = emptyLookupMap + , nodeGen = 0 + } + +-- simple context for label creation +-- (may be a temporary solution to the problem +-- of label creation) +-- +data LabelContext = SubjContext | PredContext | ObjContext + deriving (Eq, Show) + +getIndent :: Formatter B.Builder +getIndent = indent `liftM` get + +setIndent :: B.Builder -> Formatter () +setIndent ind = modify $ \st -> st { indent = ind } + +getLineBreak :: Formatter Bool +getLineBreak = lineBreak `liftM` get + +setLineBreak :: Bool -> Formatter () +setLineBreak brk = modify $ \st -> st { lineBreak = brk } + +getNgs :: Formatter NodeGenState +getNgs = nodeGenSt `liftM` get + +setNgs :: NodeGenState -> Formatter () +setNgs ngs = modify $ \st -> st { nodeGenSt = ngs } + +getPrefixes :: Formatter NamespaceMap +getPrefixes = prefixes `liftM` getNgs + +getSubjs :: Formatter (SubjTree RDFLabel) +getSubjs = subjs `liftM` get + +setSubjs :: SubjTree RDFLabel -> Formatter () +setSubjs sl = modify $ \st -> st { subjs = sl } + +getProps :: Formatter (PredTree RDFLabel) +getProps = props `liftM` get + +setProps :: PredTree RDFLabel -> Formatter () +setProps ps = modify $ \st -> st { props = ps } + +{- +getObjs :: Formatter ([RDFLabel]) +getObjs = objs `liftM` get + +setObjs :: [RDFLabel] -> Formatter () +setObjs os = do + st <- get + put $ st { objs = os } +-} + +getBnodesCheck :: Formatter [RDFLabel] +getBnodesCheck = bNodesCheck `liftM` get + +{- +addTrace :: String -> Formatter () +addTrace tr = do + st <- get + put $ st { traceBuf = tr : traceBuf st } +-} + +{- +queueFormula :: RDFLabel -> Formatter () +queueFormula fn = do + st <- get + let fa = formAvail st + newState fv = st { + formAvail = mapDelete fa fn, + formQueue = (fn,fv) : formQueue st + } + case mapFindMaybe fn fa of + Nothing -> return () + Just v -> put (newState v) >> return () +-} + +{- +Return the graph associated with the label and delete it +from the store, if there is an association, otherwise +return Nothing. + +extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) +extractFormula fn = do + st <- get + let fa = formAvail st + newState = st { formAvail=mapDelete fa fn } + case mapFindMaybe fn fa of + Nothing -> return Nothing + Just fv -> put newState >> return (Just fv) + +-} + +{- +moreFormulae :: Formatter Bool +moreFormulae = do + st <- get + return $ not $ null (formQueue st) + +nextFormula :: Formatter (RDFLabel,RDFGraph) +nextFormula = do + st <- get + let (nf : fq) = formQueue st + put $ st { formQueue = fq } + return nf + +-} + +-- list has a length of 1 +len1 :: [a] -> Bool +len1 (_:[]) = True +len1 _ = False + +{-| +Given a set of statements and a label, return the details of the +RDF collection referred to by label, or Nothing. + +For label to be considered as representing a collection we require the +following conditions to hold (this is only to support the +serialisation using the '(..)' syntax and does not make any statement +about semantics of the statements with regard to RDF Collections): + + - there must be one rdf_first and one rdfRest statement + - there must be no other predicates for the label + +-} +getCollection :: + SubjTree RDFLabel -- ^ statements organized by subject + -> RDFLabel -- ^ does this label represent a list? + -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) + -- ^ the statements with the elements removed; the + -- content elements of the collection (the objects of the rdf:first + -- predicate) and the nodes that represent the spine of the + -- collection (in reverse order, unlike the actual contents which are in + -- order). +getCollection subjList lbl = go subjList lbl ([],[]) + where + go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) + | otherwise = do + (pList1, sl') <- removeItem sl l + (pFirst, pList2) <- removeItem pList1 resRdfFirst + (pNext, pList3) <- removeItem pList2 resRdfRest + + -- QUS: could I include these checks implicitly in the pattern matches above? + -- ie instrad of (pFirst, pos1) <- .. + -- have ([content], pos1) <- ... + -- ? + if and [len1 pFirst, len1 pNext, null pList3] + then go sl' (head pNext) (head pFirst : cs, l : ss) + else Nothing + +{- +TODO: + +Should we change the preds/objs entries as well? + +-} +extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) +extractList lctxt ln = do + osubjs <- getSubjs + oprops <- getProps + let mlst = getCollection osubjs' ln + + -- we only want to send in rdf:first/rdf:rest here + fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops + + osubjs' = + case lctxt of + SubjContext -> (ln, fprops) : osubjs + _ -> osubjs + + -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" + -- addTrace tr + case mlst of + -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext + Just (sl,ls,_) -> do + setSubjs sl + when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops + return (Just ls) + + Nothing -> return Nothing + +{-| +Removes the first occurrence of the item from the +association list, returning it's contents and the rest +of the list, if it exists. +-} +removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) +removeItem os x = + let (as, bs) = break (\a -> fst a == x) os + in case bs of + ((_,b):bbs) -> Just (b, as ++ bbs) + [] -> Nothing + +---------------------------------------------------------------------- +-- Define a top-level formatter function: +---------------------------------------------------------------------- + +-- | Convert the graph to text. +formatGraphAsText :: RDFGraph -> T.Text +formatGraphAsText = L.toStrict . formatGraphAsLazyText + +-- | Convert the graph to text. +formatGraphAsLazyText :: RDFGraph -> L.Text +formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder + +-- | Convert the graph to a Builder. +formatGraphAsBuilder :: RDFGraph -> B.Builder +formatGraphAsBuilder = formatGraphIndent "\n" True + +-- | Convert the graph to a builder using the given indentation text. +formatGraphIndent :: + B.Builder -- ^ indentation text + -> Bool -- ^ are prefixes to be generated? + -> RDFGraph -- ^ graph + -> B.Builder +formatGraphIndent indnt flag gr = + let (res, _, _, _) = formatGraphDiag indnt flag gr + in res + +-- | Format graph and return additional information. +formatGraphDiag :: + B.Builder -- ^ indentation + -> Bool -- ^ are prefixes to be generated? + -> RDFGraph + -> (B.Builder, NodeGenLookupMap, Word32, [String]) +formatGraphDiag indnt flag gr = + let fg = formatGraph indnt " .\n" False flag gr + ngs = emptyNgs { + prefixes = emptyLookupMap, + nodeGen = findMaxBnode gr + } + + (out, fgs) = runState fg (emptyTFS ngs) + ogs = nodeGenSt fgs + + in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs) + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +formatGraph :: + B.Builder -- indentation string + -> B.Builder -- text to be placed after final statement + -> Bool -- True if a line break is to be inserted at the start + -> Bool -- True if prefix strings are to be generated + -> RDFGraph -- graph to convert + -> Formatter B.Builder +formatGraph ind end dobreak dopref gr = do + setIndent ind + setLineBreak dobreak + setGraph gr + + fp <- if dopref + then formatPrefixes (getNamespaces gr) + else return mempty + more <- moreSubjects + if more + then do + fr <- formatSubjects + return $ mconcat [fp, fr, end] + else return fp + +formatPrefixes :: NamespaceMap -> Formatter B.Builder +formatPrefixes pmap = do + let mls = map (pref . keyVal) (listLookupMap pmap) + ls <- sequence mls + return $ mconcat ls + where + pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."] + pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."] + +{- +NOTE: +I expect there to be confusion below where I need to +convert from Text to Builder +-} + +formatSubjects :: Formatter B.Builder +formatSubjects = do + sb <- nextSubject + sbstr <- formatLabel SubjContext sb + + flagP <- moreProperties + if flagP + then do + prstr <- formatProperties sb sbstr + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [prstr, " .", fr] + else return prstr + + else do + txt <- nextLine sbstr + + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [txt, " .", fr] + else return txt + +{- +TODO: now we are throwing a Builder around it is awkward to +get the length of the text to calculate the indentation + +So + + a) change the indentation scheme + b) pass around text instead of builder + +mkIndent :: L.Text -> L.Text +mkIndent inVal = L.replicate (L.length inVal) " " +-} + +hackIndent :: B.Builder +hackIndent = " " + +formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder +formatProperties sb sbstr = do + pr <- nextProperty sb + prstr <- formatLabel PredContext pr + obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] + more <- moreProperties + let sbindent = hackIndent -- mkIndent sbstr + if more + then do + fr <- formatProperties sb sbindent + nl <- nextLine $ obstr `mappend` " ;" + return $ nl `mappend` fr + else nextLine obstr + +formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder +formatObjects sb pr prstr = do + ob <- nextObject sb pr + obstr <- formatLabel ObjContext ob + more <- moreObjects + if more + then do + let prindent = hackIndent -- mkIndent prstr + fr <- formatObjects sb pr prindent + nl <- nextLine $ mconcat [prstr, " ", obstr, ","] + return $ nl `mappend` fr + else return $ mconcat [prstr, " ", obstr] + +{- +Add a list inline. We are given the labels that constitute +the list, in order, so just need to display them surrounded +by (). +-} +insertList :: [RDFLabel] -> Formatter B.Builder +insertList [] = return "()" -- not convinced this can happen +insertList xs = do + ls <- mapM (formatLabel ObjContext) xs + return $ mconcat ("( " : intersperse " " ls) `mappend` " )" + +{- +Add a blank node inline. +-} + +insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder +insertBnode SubjContext lbl = do + -- a safety check + flag <- moreProperties + if flag + then do + txt <- (`mappend` "\n") `liftM` formatProperties lbl "" + return $ mconcat ["[] ", txt] + else error $ "Internal error: expected properties with label: " ++ show lbl + +insertBnode _ lbl = do + ost <- get + let osubjs = subjs ost + oprops = props ost + oobjs = objs ost + + (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs + + rprops = case bsubj of + [(_,rs)] -> rs + _ -> [] + + -- we essentially want to create a new subgraph + -- for this node but it's not as simple as that since + -- we could have something like + -- :a :b [ :foo [ :bar "xx" ] ] + -- so we still need to carry around the whole graph + -- + nst = ost { subjs = rsubjs, + props = rprops, + objs = [] + } + + put nst + flag <- moreProperties + txt <- if flag + then (`mappend` "\n") `liftM` formatProperties lbl "" + else return "" + + -- TODO: how do we restore the original set up? + -- I can't believe the following is sufficient + -- + nst' <- get + let slist = map fst $ subjs nst' + nsubjs = filter (\(l,_) -> l `elem` slist) osubjs + + put $ nst' { subjs = nsubjs, + props = oprops, + objs = oobjs + } + + -- TODO: handle indentation? + return $ mconcat ["[", txt, "]"] + +---------------------------------------------------------------------- +-- Formatting helpers +---------------------------------------------------------------------- + +setGraph :: RDFGraph -> Formatter () +setGraph gr = do + st <- get + + let ngs0 = nodeGenSt st + pre' = mapMerge (prefixes ngs0) (getNamespaces gr) + ngs' = ngs0 { prefixes = pre' } + arcs = sortArcs $ getArcs gr + nst = st { graph = gr + , subjs = arcTree arcs + , props = [] + , objs = [] + -- , formAvail = getFormulae gr + , nodeGenSt = ngs' + , bNodesCheck = countBnodes arcs + } + + put nst + +hasMore :: (TurtleFormatterState -> [b]) -> Formatter Bool +hasMore lens = (not . null . lens) `liftM` get + +moreSubjects :: Formatter Bool +moreSubjects = hasMore subjs +-- moreSubjects = (not . null . subjs) `liftM` get + +moreProperties :: Formatter Bool +moreProperties = hasMore props +-- moreProperties = (not . null . props) `liftM` get + +moreObjects :: Formatter Bool +moreObjects = hasMore objs +-- moreObjects = (not . null . objs) `liftM` get + +nextSubject :: Formatter RDFLabel +nextSubject = do + st <- get + + let sb:sbs = subjs st + nst = st { subjs = sbs + , props = snd sb + , objs = [] + } + + put nst + return $ fst sb + +nextProperty :: RDFLabel -> Formatter RDFLabel +nextProperty _ = do + st <- get + + let pr:prs = props st + nst = st { props = prs + , objs = snd pr + } + + put nst + return $ fst pr + +nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel +nextObject _ _ = do + st <- get + + let ob:obs = objs st + nst = st { objs = obs } + + put nst + return ob + +nextLine :: B.Builder -> Formatter B.Builder +nextLine str = do + ind <- getIndent + brk <- getLineBreak + if brk + then return $ ind `mappend` str + else do + -- After first line, always insert line break + setLineBreak True + return str + +-- Format a label +-- Most labels are simply displayed as provided, but there are a +-- number of wrinkles to take care of here: +-- (a) blank nodes automatically allocated on input, with node +-- identifiers of the form of a digit string nnn. These are +-- not syntactically valid, and are reassigned node identifiers +-- of the form _nnn, where nnn is chosen so that is does not +-- clash with any other identifier in the graph. +-- (b) URI nodes: if possible, replace URI with qname, +-- else display as +-- (c) formula nodes (containing graphs). +-- (d) use the "special-case" formats for integer/float/double +-- literals. +-- +-- [[[TODO:]]] +-- (d) generate multi-line literals when appropriate +-- +-- This is being updated to produce inline formula, lists and +-- blank nodes. The code is not efficient. +-- +-- +-- Note: There is a lot less customisation possible in Turtle than N3. +-- + +formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder + +{- +The "[..]" conversion is done last, after "()" and "{}" checks. +-} +formatLabel lctxt lab@(Blank (_:_)) = do + mlst <- extractList lctxt lab + case mlst of + Just lst -> insertList lst + Nothing -> do + -- NOTE: unlike N3 we do not properly handle "formula"/named graphs + -- also we only expand out bnodes into [...] format when it's a object. + -- although we need to handle [] for the subject. + nb1 <- getBnodesCheck + if lctxt /= PredContext && lab `notElem` nb1 + then insertBnode lctxt lab + else formatNodeId lab + +-- formatLabel _ lab@(Res sn) = +formatLabel ctxt (Res sn) + | ctxt == PredContext && sn == rdfType = return "a" + | ctxt == ObjContext && sn == rdfNil = return "()" + | otherwise = do + pr <- getPrefixes + let nsuri = getScopeURI sn + local = getLName $ getScopeLocal sn + premap = reverseLookupMap pr :: RevNamespaceMap + prefix = mapFindMaybe nsuri premap + + name = case prefix of + Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames + _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] + + return name + +-- The canonical notation for xsd:double in XSD, with an upper-case E, +-- does not match the syntax used in N3, so we need to convert here. +-- Rather than converting back to a Double and then displaying that +-- we just convert E to e for now. +-- +formatLabel _ (Lit lit) = return $ quoteText lit +formatLabel _ (LangLit lit lcode) = return $ quoteText lit `mappend` "@" `mappend` B.fromText (fromLangTag lcode) +formatLabel _ (TypedLit lit dtype) + | dtype == xsdDouble = return $ B.fromText $ T.toLower lit + | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit + | otherwise = return $ quoteText lit `mappend` "^^" `mappend` showScopedName dtype + +formatLabel _ lab = return $ B.fromString $ show lab + +{-| +Convert text into a format for display in Turtle. The idea +is to use one double quote unless three are needed, and to +handle adding necessary @\\@ characters, or conversion +for Unicode characters. +-} +quoteText :: T.Text -> B.Builder +quoteText txt = + let st = T.unpack txt -- TODO: fix + qst = quoteB (n==1) st + n = if '\n' `elem` st || '"' `elem` st then 3 else 1 + qch = B.fromString (replicate n '"') + in mconcat [qch, qst, qch] + +formatNodeId :: RDFLabel -> Formatter B.Builder +formatNodeId lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab +formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall + +mapBlankNode :: RDFLabel -> Formatter B.Builder +mapBlankNode lab = do + ngs <- getNgs + let cmap = nodeMap ngs + cval = nodeGen ngs + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + setNgs $ ngs { nodeGen = nval, nodeMap = nmap } + return nval + + n -> return n + + -- TODO: is this what we want? + return $ "_:swish" `mappend` B.fromString (show nv) + +-- TODO: need to be a bit more clever with this than we did in NTriples +-- not sure the following counts as clever enough ... +-- +showScopedName :: ScopedName -> B.Builder +{- +showScopedName (ScopedName n l) = + let uri = nsURI n ++ l + in quote uri +-} +showScopedName = quoteB True . show + +---------------------------------------------------------------------- +-- Graph-related helper functions +---------------------------------------------------------------------- + +newtype SortedArcs lb = SA [Arc lb] + +sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb +sortArcs = SA . sort + +-- Rearrange a list of arcs into a tree of pairs which group together +-- all statements for a single subject, and similarly for multiple +-- objects of a common predicate. +-- +arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb +arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as + where + spopair (Arc s p o) = (s,(p,o)) + +{- +arcTree as = map spopair $ sort as + where + spopair (Arc s p o) = (s,[(p,[o])]) +-} + +-- Rearrange a list of pairs so that multiple occurrences of the first +-- are commoned up, and the supplied function is applied to each sublist +-- with common first elements to obtain the corresponding second value +commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] +commonFstEq f ps = + [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] + where + fstEq (f1,_) (f2,_) = f1 == f2 + +findMaxBnode :: RDFGraph -> Word32 +findMaxBnode = maximum . map getAutoBnodeIndex . labels + +getAutoBnodeIndex :: RDFLabel -> Word32 +getAutoBnodeIndex (Blank ('_':lns)) = res where + -- cf. prelude definition of read s ... + res = case [x | (x,t) <- reads lns, ("","") <- lex t] of + [x] -> x + _ -> 0 +getAutoBnodeIndex _ = 0 + +{- +Find all blank nodes that occur + - any number of times as a subject + - 0 or 1 times as an object + +Such nodes can be output using the "[..]" syntax. To make it simpler +to check we actually store those nodes that can not be expanded. + +Note that we do not try and expand any bNode that is used in +a predicate position. + +Should probably be using the SubjTree RDFLabel structure but this +is easier for now. + +-} + +countBnodes :: SortedArcs RDFLabel -> [RDFLabel] +countBnodes (SA as) = snd (foldl' ctr ([],[]) as) + where + -- first element of tuple are those blank nodes only seen once, + -- second element those blank nodes seen multiple times + -- + inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (l:b1s, bms) + inc b _ = b + + -- if the bNode appears as a predicate we instantly add it to the + -- list of nodes not to expand, even if only used once + incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (b1s, l:bms) + incP b _ = b + + ctr orig (Arc _ p o) = inc (incP orig p) o + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Graph.hs b/src/Swish/RDF/Graph.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Graph.hs @@ -0,0 +1,1458 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeSynonymInstances #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Graph +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : CPP, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, OverloadedStrings +-- +-- This module defines a memory-based RDF graph instance. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Simple labelled directed graph value +------------------------------------------------------------ + +module Swish.RDF.Graph + ( + -- * Labels + RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..) + , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral + , isDatatyped, isMemberProp, isUri, isBlank, isQueryVar + , getLiteralText, getScopedName, makeBlank + , quote + , quoteT + + -- * RDF Graphs + , RDFTriple + , toRDFTriple, fromRDFTriple + , NSGraph(..) + , RDFGraph + , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} + , NamespaceMap, RevNamespaceMap, RevNamespace + , emptyNamespaceMap + , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap + , addArc, merge + , allLabels, allNodes, remapLabels, remapLabelList + , newNode, newNodes + , setNamespaces, getNamespaces + , setFormulae, getFormulae, setFormula, getFormula + + -- * Re-export from GraphClass + -- + -- | Note that @asubj@, @apred@ and @aobj@ have been + -- removed in version @0.7.0.0@; use 'arcSubj', 'arcPred' + -- or 'arcObj' instead. + -- + , LDGraph(..), Label (..), Arc(..) + , arc, Selector + + -- * Selected RDFLabel values + -- + -- | The 'ToRDFLabel' instance of 'ScopedName' can also be used + -- to easily construct 'RDFLabel' versions of the terms defined + -- in `Swish.RDF.Vocabulary`. + + -- ** RDF terms + -- + -- | These terms are described in ; + -- the version used is \"W3C Recommendation 10 February 2004\", . + -- + -- Some terms are listed within the RDF Schema terms below since their definition + -- is given within the RDF Schema document. + -- + , resRdfRDF + , resRdfDescription + , resRdfID + , resRdfAbout + , resRdfParseType + , resRdfResource + , resRdfLi + , resRdfNodeID + , resRdfDatatype + , resRdf1, resRdf2, resRdfn + -- ** RDF Schema terms + -- + -- | These are defined by ; the version + -- used is \"W3C Recommendation 10 February 2004\", . + + -- *** Classes + -- + -- | See the \"Classes\" section at for more information. + , resRdfsResource + , resRdfsClass + , resRdfsLiteral + , resRdfsDatatype + , resRdfXMLLiteral + , resRdfProperty + -- *** Properties + -- + -- | See the \"Properties\" section at for more information. + , resRdfsRange + , resRdfsDomain + , resRdfType + , resRdfsSubClassOf + , resRdfsSubPropertyOf + , resRdfsLabel + , resRdfsComment + -- *** Containers + -- + -- | See the \"Container Classes and Properties\" section at . + , resRdfsContainer + , resRdfBag + , resRdfSeq + , resRdfAlt + , resRdfsContainerMembershipProperty + , resRdfsMember + -- *** Collections + -- + -- | See the \"Collections\" section at . + , resRdfList + , resRdfFirst + , resRdfRest + , resRdfNil + -- *** Reification Vocabulary + -- + -- | See the \"Reification Vocabulary\" section at . + , resRdfStatement + , resRdfSubject + , resRdfPredicate + , resRdfObject + -- *** Utility Properties + -- + -- | See the \"Utility Properties\" section at . + , resRdfsSeeAlso + , resRdfsIsDefinedBy + , resRdfValue + + -- ** OWL + , resOwlSameAs + + -- ** Miscellaneous + , resRdfdGeneralRestriction + , resRdfdOnProperties, resRdfdConstraint, resRdfdMaxCardinality + , resLogImplies + + -- * Exported for testing + , grMatchMap, grEq + , mapnode, maplist + ) + where + +import Swish.Namespace + ( Namespace, makeNamespace, getNamespaceTuple + , getScopedNameURI + , ScopedName + , getScopeLocal, getScopeNamespace + , getQName + , makeQNameScopedName + , makeURIScopedName + , nullScopedName + ) + +import Swish.RDF.Vocabulary +{- + ( namespaceRDF + , langTag, isLang + , rdfType + , rdfFirst, rdfRest, rdfNil, rdfXMLLiteral + , rdfsMember + , rdfdGeneralRestriction + , rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality + , owlSameAs, logImplies + , xsdBoolean, xsdDecimal, xsdFloat, xsdDouble, xsdInteger + , xsdDateTime, xsdDate + ) +-} + +import Swish.GraphClass (LDGraph(..), Label (..), Arc(..), Selector) +import Swish.GraphClass (arc, arcLabels) +import Swish.GraphMatch (LabelMap, ScopedLabel(..)) +import Swish.GraphMatch (graphMatch) +import Swish.QName (QName, getLName) + +import Control.Applicative (Applicative, liftA, (<$>), (<*>)) + +import Network.URI (URI) + +import Data.Monoid (Monoid(..)) +import Data.Maybe (mapMaybe) +import Data.Char (ord, isDigit) +import Data.Hashable (hashWithSalt) +import Data.List (intersect, union, foldl') +import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) +import Data.LookupMap (listLookupMap, mapFind, mapFindMaybe, mapReplace, mapAddIfNew, mapVals, mapKeys ) +import Data.Ord (comparing) +import Data.Word (Word32) + +import Data.String (IsString(..)) +import Data.Time (UTCTime, Day, ParseTime, parseTime, formatTime) + +import System.Locale (defaultTimeLocale) + +import Text.Printf + +import qualified Data.Foldable as Foldable +import qualified Data.Traversable as Traversable + +import qualified Data.Text as T +import qualified Data.Text.Read as T +-- import qualified Data.Text.Lazy as L +-- import Data.Text.Format (format) +-- import Data.Text.Buildable +-- import Data.Text.Format.Types (Only(..)) + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) +import Data.Tuple (swap) +#else +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) +#endif + +-- | RDF graph node values +-- +-- cf. +-- +-- This is extended from the RDF abstract graph syntax in the +-- following ways: +-- +-- (a) a graph can be part of a resource node or blank node +-- (cf. Notation3 formulae) +-- +-- (b) a \"variable\" node option is distinguished from a +-- blank node. +-- I have found this useful for encoding and handling +-- queries, even though query variables can be expressed +-- as blank nodes. +-- +-- (c) a \"NoNode\" option is defined. +-- This might otherwise be handled by @Maybe (RDFLabel g)@. +-- +-- Prior to version @0.7.0.0@, literals were represented by a +-- single constructor, @Lit@, with an optional argument. Language +-- codes for literals was also stored as a 'ScopedName' rather than +-- as a 'LanguageTag'. +-- +data RDFLabel = + Res ScopedName -- ^ resource + | Lit T.Text -- ^ plain literal () + | LangLit T.Text LanguageTag -- ^ plain literal + | TypedLit T.Text ScopedName -- ^ typed literal () + | Blank String -- ^ blank node + | Var String -- ^ variable (not used in ordinary graphs) + | NoNode -- ^ no node (not used in ordinary graphs) + +-- | Define equality of nodes possibly based on different graph types. +-- +-- The equality of literals is taken from section 6.5.1 ("Literal +-- Equality") of the RDF Concepts and Abstract Document, +-- . +-- +instance Eq RDFLabel where + Res q1 == Res q2 = q1 == q2 + Blank b1 == Blank b2 = b1 == b2 + Var v1 == Var v2 = v1 == v2 + + Lit s1 == Lit s2 = s1 == s2 + LangLit s1 l1 == LangLit s2 l2 = s1 == s2 && l1 == l2 + TypedLit s1 t1 == TypedLit s2 t2 = s1 == s2 && t1 == t2 + + _ == _ = False + +instance Show RDFLabel where + show (Res sn) = show sn + show (Lit st) = quote1Str st + show (LangLit st lang) = quote1Str st ++ "@" ++ T.unpack (fromLangTag lang) + show (TypedLit st dtype) + | dtype `elem` [xsdBoolean, xsdDouble, xsdDecimal, xsdInteger] = T.unpack st + | otherwise = quote1Str st ++ "^^" ++ show dtype + + {- + show (Lit st (Just nam)) + | isLang nam = quote1Str st ++ "@" ++ T.unpack (langTag nam) + | nam `elem` [xsdBoolean, xsdDouble, xsdDecimal, xsdInteger] = T.unpack st + | otherwise = quote1Str st ++ "^^" ++ show nam + -} + + show (Blank ln) = "_:"++ln + show (Var ln) = '?' : ln + show NoNode = "" + +instance Ord RDFLabel where + -- Optimize some common cases.. + compare (Res sn1) (Res sn2) = compare sn1 sn2 + compare (Blank ln1) (Blank ln2) = compare ln1 ln2 + compare (Res _) (Blank _) = LT + compare (Blank _) (Res _) = GT + + compare (Lit s1) (Lit s2) = compare s1 s2 + + -- .. else use show string comparison + compare l1 l2 = comparing show l1 l2 + + {- <= is not used if compare is provided + -- Similarly for <= + (Res qn1) <= (Res qn2) = qn1 <= qn2 + (Blank ln1) <= (Blank ln2) = ln1 <= ln2 + (Res _) <= (Blank _) = True + (Blank _) <= (Res _) = False + l1 <= l2 = show l1 <= show l2 + -} + +instance Label RDFLabel where + labelIsVar (Blank _) = True + labelIsVar (Var _) = True + labelIsVar _ = False + + getLocal (Blank loc) = loc + getLocal (Var loc) = '?':loc + getLocal (Res sn) = "Res_" ++ (T.unpack . getLName . getScopeLocal) sn + getLocal (NoNode) = "None" + getLocal _ = "Lit_" + + makeLabel ('?':loc) = Var loc + makeLabel loc = Blank loc + + labelHash seed lb = hashWithSalt seed (showCanon lb) + +instance IsString RDFLabel where + fromString = Lit . T.pack + +{-| +A type that can be converted to a RDF Label. + +The String instance converts to an untyped literal +(so no language tag is assumed). + +The `UTCTime` and `Day` instances assume values are in UTC. + +The conversion for XSD types attempts to use the +canonical form described in section 2.3.1 of +. + +Note that this is similar to +'Swish.RDF.Datatype.toRDFLabel'; +the code should probably be combined at some point. +-} + +class ToRDFLabel a where + toRDFLabel :: a -> RDFLabel + +{-| +A type that can be converted from a RDF Label, +with the possibility of failure. + +The String instance converts from an untyped literal +(so it can not be used with a string with a language tag). + +The following conversions are supported for common XSD +types (out-of-band values result in @Nothing@): + + - @xsd:boolean@ to @Bool@ + + - @xsd:integer@ to @Int@ and @Integer@ + + - @xsd:float@ to @Float@ + + - @xsd:double@ to @Double@ + + - @xsd:dateTime@ to @UTCTime@ + + - @xsd:date@ to @Day@ + +Note that this is similar to +'Swish.RDF.Datatype.fromRDFLabel'; +the code should probably be combined at some point. +-} + +class FromRDFLabel a where + fromRDFLabel :: RDFLabel -> Maybe a + +-- instances for type conversion to/from RDFLabel + +-- | This is just @id@. +instance ToRDFLabel RDFLabel where + toRDFLabel = id + +-- | This is just @Just . id@. +instance FromRDFLabel RDFLabel where + fromRDFLabel = Just . id + +-- TODO: remove this hack when finished conversion to Text +maybeReadStr :: (Read a) => T.Text -> Maybe a +maybeReadStr txt = case reads (T.unpack txt) of + [(val, "")] -> Just val + _ -> Nothing + +maybeRead :: T.Reader a -> T.Text -> Maybe a +maybeRead rdr inTxt = + case rdr inTxt of + Right (val, "") -> Just val + _ -> Nothing + +fLabel :: (T.Text -> Maybe a) -> ScopedName -> RDFLabel -> Maybe a +fLabel conv dtype (TypedLit xs dt) | dt == dtype = conv xs + | otherwise = Nothing +fLabel _ _ _ = Nothing + +tLabel :: (Show a) => ScopedName -> (String -> T.Text) -> a -> RDFLabel +tLabel dtype conv = flip TypedLit dtype . conv . show + +-- | The character is converted to an untyped literal of length one. +instance ToRDFLabel Char where + toRDFLabel = Lit . T.singleton + +-- | The label must be an untyped literal containing a single character. +instance FromRDFLabel Char where + fromRDFLabel (Lit cs) | T.compareLength cs 1 == EQ = Just (T.head cs) + | otherwise = Nothing + fromRDFLabel _ = Nothing + +-- | Strings are converted to untyped literals. +instance ToRDFLabel String where + toRDFLabel = Lit . T.pack + +-- | Only untyped literals are converted to strings. +instance FromRDFLabel String where + fromRDFLabel (Lit xs) = Just (T.unpack xs) + fromRDFLabel _ = Nothing + +textToBool :: T.Text -> Maybe Bool +textToBool s | s `elem` ["1", "true"] = Just True + | s `elem` ["0", "false"] = Just False + | otherwise = Nothing + +-- | Converts to a literal with a @xsd:boolean@ datatype. +instance ToRDFLabel Bool where + toRDFLabel b = TypedLit (if b then "true" else "false") xsdBoolean + +-- | Converts from a literal with a @xsd:boolean@ datatype. The +-- literal can be any of the supported XSD forms - e.g. \"0\" or +-- \"true\". +instance FromRDFLabel Bool where + fromRDFLabel = fLabel textToBool xsdBoolean + +-- fromRealFloat :: (RealFloat a, Buildable a) => ScopedName -> a -> RDFLabel +fromRealFloat :: (RealFloat a, PrintfArg a) => ScopedName -> a -> RDFLabel +fromRealFloat dtype f | isNaN f = toL "NaN" + | isInfinite f = toL $ if f > 0.0 then "INF" else "-INF" + -- + -- Would like to use Data.Text.Format.format but there are + -- issues with this module; 0.3.0.2 doesn't build under + -- 6.12.3 due to a missing RelaxedPolyRec language extension + -- and it relies on double-conversion which has issues + -- when used in ghci due to a dlopen issue with libstdc++. + -- + -- -- | otherwise = toL $ L.toStrict $ format "{}" (Only f) + -- + | otherwise = toL $ T.pack $ printf "%E" f + + where + toL = flip TypedLit dtype + +-- textToRealFloat :: (RealFloat a) => (a -> Maybe a) -> T.Text -> Maybe a +textToRealFloat :: (RealFloat a, Read a) => (a -> Maybe a) -> T.Text -> Maybe a +textToRealFloat conv = rconv + where + rconv "NaN" = Just (0.0/0.0) -- how best to create a NaN? + rconv "INF" = Just (1.0/0.0) -- ditto for Infinity + rconv "-INF" = Just ((-1.0)/0.0) + rconv ival + -- xsd semantics allows "2." but Haskell syntax does not. + | T.null ival = Nothing + + | otherwise = case maybeReadStr ival of + Just val -> conv val + _ -> if T.last ival == '.' -- could drop the check + then maybeReadStr (T.snoc ival '0') >>= conv + else Nothing + + {- + + Unfortunately T.rational does not handle "3.01e4" the same + as read; see https://bitbucket.org/bos/text/issue/7/ + + | otherwise = case maybeRead T.rational ival of + Just val -> conv val + _ -> if T.last ival == '.' -- could drop the check + then maybeRead T.rational (T.snoc ival '0') >>= conv + else Nothing + -} + + -- not sure the above is any improvement on the following + -- -- | T.last ival == '.' = maybeRead T.rational (T.snoc ival '0') >>= conv + -- -- | otherwise = maybeRead T.rational ival >>= conv + +textToFloat :: T.Text -> Maybe Float +textToFloat = + let -- assume that an invalid value (NaN/Inf) from maybeRead means + -- that the value is out of bounds for Float so we do not + -- convert + conv f | isNaN f || isInfinite f = Nothing + | otherwise = Just f + in textToRealFloat conv + +textToDouble :: T.Text -> Maybe Double +textToDouble = textToRealFloat Just + +-- | Converts to a literal with a @xsd:float@ datatype. +instance ToRDFLabel Float where + toRDFLabel = fromRealFloat xsdFloat + +-- | Converts from a literal with a @xsd:float@ datatype. +-- The conversion will fail if the value is outside the valid range of +-- a Haskell `Float`. +instance FromRDFLabel Float where + fromRDFLabel = fLabel textToFloat xsdFloat + +-- | Converts to a literal with a @xsd:double@ datatype. +instance ToRDFLabel Double where + toRDFLabel = fromRealFloat xsdDouble + +-- | Converts from a literal with a @xsd:double@ datatype. +instance FromRDFLabel Double where + fromRDFLabel = fLabel textToDouble xsdDouble + +-- TODO: are there subtypes of xsd::integer that are +-- useful here? +-- +-- TODO: add in support for Int8/..., Word8/... +-- + +-- | Converts to a literal with a @xsd:integer@ datatype. +instance ToRDFLabel Int where + toRDFLabel = tLabel xsdInteger T.pack + +{- +Since decimal will just over/under-flow when converting to Int +we go via Integer and explicitly check for overflow. +-} + +textToInt :: T.Text -> Maybe Int +textToInt s = + let conv :: Integer -> Maybe Int + conv i = + let lb = fromIntegral (minBound :: Int) + ub = fromIntegral (maxBound :: Int) + in if (i >= lb) && (i <= ub) then Just (fromIntegral i) else Nothing + + in maybeRead (T.signed T.decimal) s >>= conv + +-- | Converts from a literal with a @xsd:integer@ datatype. +-- The conversion will fail if the value is outside the valid range of +-- a Haskell `Int`. +instance FromRDFLabel Int where + fromRDFLabel = fLabel textToInt xsdInteger + +-- | Converts to a literal with a @xsd:integer@ datatype. +instance ToRDFLabel Integer where + toRDFLabel = tLabel xsdInteger T.pack + +-- | Converts from a literal with a @xsd:integer@ datatype. +instance FromRDFLabel Integer where + fromRDFLabel = fLabel (maybeRead (T.signed T.decimal)) xsdInteger + +{- +Support an ISO-8601 style format supporting + + 2005-02-28T00:00:00Z + 2004-12-31T19:01:00-05:00 + 2005-07-14T03:18:56.234+01:00 + +fromUTCFormat is used to convert UTCTime to a string +for storage within a Lit. + +toUTCFormat is used to convert a string into UTCTime; +we have to support + no time zone + Z + +/-HH:MM + +which means a somewhat messy convertor, which is written +for clarity rather than speed. +-} + +fromUTCFormat :: UTCTime -> String +fromUTCFormat = formatTime defaultTimeLocale "%FT%T%QZ" + +fromDayFormat :: Day -> String +fromDayFormat = formatTime defaultTimeLocale "%FZ" + +toTimeFormat :: (ParseTime a) => String -> String -> Maybe a +toTimeFormat fmt inVal = + let fmtHHMM = fmt ++ "%z" + fmtZ = fmt ++ "Z" + pt f = parseTime defaultTimeLocale f inVal + in case pt fmtHHMM of + o@(Just _) -> o + _ -> case pt fmtZ of + o@(Just _) -> o + _ -> pt fmt + +toUTCFormat :: T.Text -> Maybe UTCTime +toUTCFormat = toTimeFormat "%FT%T%Q" . T.unpack + +toDayFormat :: T.Text -> Maybe Day +toDayFormat = toTimeFormat "%F" . T.unpack + +-- | Converts to a literal with a @xsd:datetime@ datatype. +instance ToRDFLabel UTCTime where + toRDFLabel = flip TypedLit xsdDateTime . T.pack . fromUTCFormat + +-- | Converts from a literal with a @xsd:datetime@ datatype. +instance FromRDFLabel UTCTime where + fromRDFLabel = fLabel toUTCFormat xsdDateTime + +-- | Converts to a literal with a @xsd:date@ datatype. +instance ToRDFLabel Day where + toRDFLabel = flip TypedLit xsdDate . T.pack . fromDayFormat + +-- | Converts from a literal with a @xsd:date@ datatype. +instance FromRDFLabel Day where + fromRDFLabel = fLabel toDayFormat xsdDate + +-- | Converts to a Resource. +instance ToRDFLabel ScopedName where + toRDFLabel = Res + +-- | Converts from a Resource. +instance FromRDFLabel ScopedName where + fromRDFLabel (Res sn) = Just sn + fromRDFLabel _ = Nothing + +-- | Converts to a Resource. +instance ToRDFLabel QName where + toRDFLabel = Res . makeQNameScopedName Nothing + +-- | Converts from a Resource. +instance FromRDFLabel QName where + fromRDFLabel (Res sn) = Just $ getQName sn + fromRDFLabel _ = Nothing + +-- | Converts to a Resource. +instance ToRDFLabel URI where + toRDFLabel = Res . makeURIScopedName + +-- | Converts from a Resource. +instance FromRDFLabel URI where + fromRDFLabel (Res sn) = Just $ getScopedNameURI sn + fromRDFLabel _ = Nothing + +-- | Get the canonical string for RDF label. +-- +-- This is used for hashing, so that equivalent labels always return +-- the same hash value. +-- +-- TODO: can remove the use of quote1Str as all we care about is +-- a unique output, not that it is valid in any RDF format. Also +-- rename to showForHash or something like that, since it is only used +-- for this purpose. +-- +showCanon :: RDFLabel -> String +showCanon (Res sn) = "<"++show (getScopedNameURI sn)++">" +showCanon (Lit st) = show st +showCanon (LangLit st lang) = quote1Str st ++ "@" ++ T.unpack (fromLangTag lang) +showCanon (TypedLit st dt) = quote1Str st ++ "^^" ++ show (getScopedNameURI dt) +showCanon s = show s + +-- | See `quote`. +quoteT :: Bool -> T.Text -> T.Text +quoteT f = T.pack . quote f . T.unpack + +{-| N3-style quoting rules for a string. + +TODO: when flag is `False` need to worry about multiple quotes (> 2) +in a row. +-} + +quote :: + Bool -- ^ @True@ if the string is to be displayed using one rather than three quotes. + -> String -- ^ String to quote. + -> String +quote _ [] = "" +quote False s@(c:'"':[]) | c == '\\' = s -- handle triple-quoted strings ending in " + | otherwise = [c, '\\', '"'] + +quote True ('"': st) = '\\':'"': quote True st +quote True ('\n':st) = '\\':'n': quote True st + +quote True ('\t':st) = '\\':'t': quote True st +quote False ('"': st) = '"': quote False st +quote False ('\n':st) = '\n': quote False st +quote False ('\t':st) = '\t': quote False st +quote f ('\r':st) = '\\':'r': quote f st +quote f ('\\':st) = '\\':'\\': quote f st -- not sure about this +quote f (c:st) = + let nc = ord c + rst = quote f st + + -- lazy way to convert to a string + hstr = printf "%08X" nc + ustr = hstr ++ rst + + in if nc > 0xffff + then '\\':'U': ustr + else if nc > 0x7e || nc < 0x20 + then '\\':'u': drop 4 ustr + else c : rst + +-- surround a string with quotes ("...") + +quote1Str :: T.Text -> String +quote1Str t = '"' : quote False (T.unpack t) ++ "\"" + +--------------------------------------------------------- +-- Selected RDFLabel values +--------------------------------------------------------- + +-- | @rdf:type@ from . +resRdfType :: RDFLabel +resRdfType = Res rdfType + +-- | @rdf:List@ from . +resRdfList :: RDFLabel +resRdfList = Res rdfList + +-- | @rdf:first@ from . +resRdfFirst :: RDFLabel +resRdfFirst = Res rdfFirst + +-- | @rdf:rest@ from . +resRdfRest :: RDFLabel +resRdfRest = Res rdfRest + +-- | @rdf:nil@ from . +resRdfNil :: RDFLabel +resRdfNil = Res rdfNil + +-- | @rdfs:member@ from . +resRdfsMember :: RDFLabel +resRdfsMember = Res rdfsMember + +-- | @rdfd:GeneralRestriction@. +resRdfdGeneralRestriction :: RDFLabel +resRdfdGeneralRestriction = Res rdfdGeneralRestriction + +-- | @rdfd:onProperties@. +resRdfdOnProperties :: RDFLabel +resRdfdOnProperties = Res rdfdOnProperties + +-- | @rdfd:constraint@. +resRdfdConstraint :: RDFLabel +resRdfdConstraint = Res rdfdConstraint + +-- | @rdfd:maxCardinality@. +resRdfdMaxCardinality :: RDFLabel +resRdfdMaxCardinality = Res rdfdMaxCardinality + +-- | @rdfs:seeAlso@ from . +resRdfsSeeAlso :: RDFLabel +resRdfsSeeAlso = Res rdfsSeeAlso + +-- | @rdf:value@ from . +resRdfValue :: RDFLabel +resRdfValue = Res rdfValue + +-- | @owl:sameAs@. +resOwlSameAs :: RDFLabel +resOwlSameAs = Res owlSameAs + +-- | @log:implies@. +resLogImplies :: RDFLabel +resLogImplies = Res logImplies + +-- | @rdfs:label@ from . +resRdfsLabel :: RDFLabel +resRdfsLabel = Res rdfsLabel + +-- | @rdfs:comment@ from . +resRdfsComment :: RDFLabel +resRdfsComment = Res rdfsComment + +-- | @rdf:Property@ from . +resRdfProperty :: RDFLabel +resRdfProperty = Res rdfProperty + +-- | @rdfs:subPropertyOf@ from . +resRdfsSubPropertyOf :: RDFLabel +resRdfsSubPropertyOf = Res rdfsSubPropertyOf + +-- | @rdfs:subClassOf@ from . +resRdfsSubClassOf :: RDFLabel +resRdfsSubClassOf = Res rdfsSubClassOf + +-- | @rdfs:Class@ from . +resRdfsClass :: RDFLabel +resRdfsClass = Res rdfsClass + +-- | @rdfs:Literal@ from . +resRdfsLiteral :: RDFLabel +resRdfsLiteral = Res rdfsLiteral + +-- | @rdfs:Datatype@ from . +resRdfsDatatype :: RDFLabel +resRdfsDatatype = Res rdfsDatatype + +-- | @rdf:XMLLiteral@ from . +resRdfXMLLiteral :: RDFLabel +resRdfXMLLiteral = Res rdfXMLLiteral + +-- | @rdfs:range@ from . +resRdfsRange :: RDFLabel +resRdfsRange = Res rdfsRange + +-- | @rdfs:domain@ from . +resRdfsDomain :: RDFLabel +resRdfsDomain = Res rdfsDomain + +-- | @rdfs:Container@ from . +resRdfsContainer :: RDFLabel +resRdfsContainer = Res rdfsContainer + +-- | @rdf:Bag@ from . +resRdfBag :: RDFLabel +resRdfBag = Res rdfBag + +-- | @rdf:Seq@ from . +resRdfSeq :: RDFLabel +resRdfSeq = Res rdfSeq + +-- | @rdf:Alt@ from . +resRdfAlt :: RDFLabel +resRdfAlt = Res rdfAlt + +-- | @rdfs:ContainerMembershipProperty@ from . +resRdfsContainerMembershipProperty :: RDFLabel +resRdfsContainerMembershipProperty = Res rdfsContainerMembershipProperty + +-- | @rdfs:isDefinedBy@ from . +resRdfsIsDefinedBy :: RDFLabel +resRdfsIsDefinedBy = Res rdfsIsDefinedBy + +-- | @rdfs:Resource@ from . +resRdfsResource :: RDFLabel +resRdfsResource = Res rdfsResource + +-- | @rdf:Statement@ from . +resRdfStatement :: RDFLabel +resRdfStatement = Res rdfStatement + +-- | @rdf:subject@ from . +resRdfSubject :: RDFLabel +resRdfSubject = Res rdfSubject + +-- | @rdf:predicate@ from . +resRdfPredicate :: RDFLabel +resRdfPredicate = Res rdfPredicate + +-- | @rdf:object@ from . +resRdfObject :: RDFLabel +resRdfObject = Res rdfObject + +-- | @rdf:RDF@. +resRdfRDF :: RDFLabel +resRdfRDF = Res rdfRDF + +-- | @rdf:Description@. +resRdfDescription :: RDFLabel +resRdfDescription = Res rdfDescription + +-- | @rdf:ID@. +resRdfID :: RDFLabel +resRdfID = Res rdfID + +-- | @rdf:about@. +resRdfAbout :: RDFLabel +resRdfAbout = Res rdfAbout + +-- | @rdf:parseType@. +resRdfParseType :: RDFLabel +resRdfParseType = Res rdfParseType + +-- | @rdf:resource@. +resRdfResource :: RDFLabel +resRdfResource = Res rdfResource + +-- | @rdf:li@. +resRdfLi :: RDFLabel +resRdfLi = Res rdfLi + +-- | @rdf:nodeID@. +resRdfNodeID :: RDFLabel +resRdfNodeID = Res rdfNodeID + +-- | @rdf:datatype@. +resRdfDatatype :: RDFLabel +resRdfDatatype = Res rdfDatatype + +-- | @rdf:_1@. +resRdf1 :: RDFLabel +resRdf1 = Res rdf1 + +-- | @rdf:_2@. +resRdf2 :: RDFLabel +resRdf2 = Res rdf2 + +-- | Create a @rdf:_n@ entity. +-- +-- There is no check that the argument is not @0@. +resRdfn :: Word32 -> RDFLabel +resRdfn = Res . rdfn + +--------------------------------------------------------- +-- Additional functions on RDFLabel values +--------------------------------------------------------- + +-- |Test if supplied labal is a URI resource node +isUri :: RDFLabel -> Bool +isUri (Res _) = True +isUri _ = False + +-- |Test if supplied labal is a literal node +-- ('Lit', 'LangLit', or 'TypedLit'). +isLiteral :: RDFLabel -> Bool +isLiteral (Lit _) = True +isLiteral (LangLit _ _) = True +isLiteral (TypedLit _ _) = True +isLiteral _ = False + +-- |Test if supplied labal is an untyped literal node (either +-- 'Lit' or 'LangLit'). +isUntypedLiteral :: RDFLabel -> Bool +isUntypedLiteral (Lit _) = True +isUntypedLiteral (LangLit _ _) = True +isUntypedLiteral _ = False + +-- |Test if supplied labal is a typed literal node ('TypedLit'). +isTypedLiteral :: RDFLabel -> Bool +isTypedLiteral (TypedLit _ _) = True +isTypedLiteral _ = False + +-- |Test if supplied labal is a XML literal node +isXMLLiteral :: RDFLabel -> Bool +isXMLLiteral = isDatatyped rdfXMLLiteral + +-- |Test if supplied label is a typed literal node of a given datatype +isDatatyped :: ScopedName -> RDFLabel -> Bool +isDatatyped d (TypedLit _ dt) = d == dt +isDatatyped _ _ = False + +-- |Test if supplied label is a container membership property +-- +-- Check for namespace is RDF namespace and +-- first character of local name is '_' and +-- remaining characters of local name are all digits +isMemberProp :: RDFLabel -> Bool +isMemberProp (Res sn) = + getScopeNamespace sn == namespaceRDF && + case T.uncons (getLName (getScopeLocal sn)) of + Just ('_', t) -> T.all isDigit t + _ -> False +isMemberProp _ = False + +-- |Test if supplied labal is a blank node +isBlank :: RDFLabel -> Bool +isBlank (Blank _) = True +isBlank _ = False + +-- |Test if supplied labal is a query variable +isQueryVar :: RDFLabel -> Bool +isQueryVar (Var _) = True +isQueryVar _ = False + +-- |Extract text value from a literal node (including the +-- Language and Typed variants). The empty string is returned +-- for other nodes. +getLiteralText :: RDFLabel -> T.Text +getLiteralText (Lit s) = s +getLiteralText (LangLit s _) = s +getLiteralText (TypedLit s _) = s +getLiteralText _ = "" + +-- |Extract the ScopedName value from a resource node ('nullScopedName' +-- is returned for non-resource nodes). +getScopedName :: RDFLabel -> ScopedName +getScopedName (Res sn) = sn +getScopedName _ = nullScopedName + +-- |Make a blank node from a supplied query variable, +-- or return the supplied label unchanged. +-- (Use this in when substituting an existential for an +-- unsubstituted query variable.) +makeBlank :: RDFLabel -> RDFLabel +makeBlank (Var loc) = Blank loc +makeBlank lb = lb + +-- | RDF Triple (statement) +-- +-- At present there is no check or type-level +-- constraint that stops the subject or +-- predicate of the triple from being a literal. +-- +type RDFTriple = Arc RDFLabel + +-- | Convert 3 RDF labels to a RDF triple. +-- +-- See also @Swish.RDF.GraphClass.arcFromTriple@. +toRDFTriple :: + (ToRDFLabel s, ToRDFLabel p, ToRDFLabel o) + => s -- ^ Subject + -> p -- ^ Predicate + -> o -- ^ Object + -> RDFTriple +toRDFTriple s p o = + Arc (toRDFLabel s) (toRDFLabel p) (toRDFLabel o) + +-- | Extract the contents of a RDF triple. +-- +-- See also @Swish.RDF.GraphClass.arcToTriple@. +fromRDFTriple :: + (FromRDFLabel s, FromRDFLabel p, FromRDFLabel o) + => RDFTriple + -> Maybe (s, p, o) -- ^ The conversion only succeeds if all three + -- components can be converted to the correct + -- Haskell types. +fromRDFTriple (Arc s p o) = + (,,) <$> fromRDFLabel s <*> fromRDFLabel p <*> fromRDFLabel o + +-- | Namespace prefix list entry + +-- | A 'LookupMap' for name spaces. +type NamespaceMap = LookupMap Namespace + +-- | A 'LookupMap' for reversed name spaces. +type RevNamespaceMap = LookupMap RevNamespace + +-- | Support for reversed name spaces in a 'LookupMap'. +data RevNamespace = RevNamespace Namespace + +instance LookupEntryClass RevNamespace URI (Maybe T.Text) where + keyVal (RevNamespace ns) = swap $ getNamespaceTuple ns + newEntry (uri,pre) = RevNamespace (makeNamespace pre uri) + +-- | Create an empty namespace map. +emptyNamespaceMap :: NamespaceMap +emptyNamespaceMap = LookupMap [] + +-- | Graph formula entry + +data LookupFormula lb gr = Formula + { formLabel :: lb -- ^ The label for the formula + , formGraph :: gr -- ^ The contents of the formula + } + +instance (Eq lb, Eq gr) => Eq (LookupFormula lb gr) where + f1 == f2 = formLabel f1 == formLabel f2 && + formGraph f1 == formGraph f2 + +instance (Label lb) + => LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb) + where + keyVal fe = (formLabel fe, formGraph fe) + newEntry (k,v) = Formula { formLabel=k, formGraph=v } + +instance (Label lb) => Show (LookupFormula lb (NSGraph lb)) + where + show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" + +-- | A named formula. +type Formula lb = LookupFormula lb (NSGraph lb) + +-- | A 'LookupMap' for named formulae. +type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb)) + +-- | Create an empty formula map. +emptyFormulaMap :: FormulaMap RDFLabel +emptyFormulaMap = LookupMap [] + +{- given up on trying to do Functor for formulae... +instance Functor (LookupFormula (NSGraph lb)) where + fmap f fm = mapTranslateEntries (mapFormulaEntry f) fm +-} + +formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2 +formulaeMap f = fmap (formulaEntryMap f) + +formulaEntryMap :: + (lb -> l2) + -> Formula lb + -> Formula l2 +formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr) + +formulaeMapA :: Applicative f => (lb -> f l2) -> + FormulaMap lb -> f (FormulaMap l2) +formulaeMapA f = Traversable.traverse (formulaEntryMapA f) + +formulaEntryMapA :: + (Applicative f) => + (lb -> f l2) + -> Formula lb + -> f (Formula l2) +formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> Traversable.traverse f gr + +{- +formulaeMapM :: + (Monad m) => (lb -> m l2) -> FormulaMap lb -> m (FormulaMap l2) +formulaeMapM f = T.mapM (formulaEntryMapM f) + +formulaEntryMapM :: + (Monad m) + => (lb -> m l2) + -> Formula lb + -> m (Formula l2) +formulaEntryMapM f (Formula k gr) = + Formula `liftM` f k `ap` T.mapM f gr + +-} + +{-| + +Memory-based graph with namespaces and subgraphs. + +The primary means for adding arcs to an existing graph +are: + + - `setArcs` from the `LDGraph` instance, which replaces the + existing set of arcs and does not change the namespace + map. + + - `addArc` which checks that the arc is unknown before + adding it but does not change the namespace map or + re-label any blank nodes in the arc. + +-} +data NSGraph lb = NSGraph + { namespaces :: NamespaceMap -- ^ the namespaces to use + , formulae :: FormulaMap lb -- ^ any associated formulae (a.k.a. sub- or named- graps) + , statements :: [Arc lb] -- ^ the statements in the graph + } + +instance (Label lb) => LDGraph NSGraph lb where + emptyGraph = NSGraph emptyNamespaceMap (LookupMap []) [] + getArcs = statements + setArcs g as = g { statements=as } + +-- | The 'mappend' operation uses 'merge' rather than 'addGraphs'. +instance (Label lb) => Monoid (NSGraph lb) where + mempty = emptyGraph + mappend = merge + +instance Functor NSGraph where + fmap f (NSGraph ns fml stmts) = + NSGraph ns (formulaeMap f fml) ((map $ fmap f) stmts) + +instance Foldable.Foldable NSGraph where + foldMap = Traversable.foldMapDefault + +instance Traversable.Traversable NSGraph where + traverse f (NSGraph ns fml stmts) = + NSGraph ns <$> formulaeMapA f fml <*> (Traversable.traverse $ Traversable.traverse f) stmts + +instance (Label lb) => Eq (NSGraph lb) where + (==) = grEq + +instance (Label lb) => Show (NSGraph lb) where + show = grShow "" + showList = grShowList "" + +-- | Retrieve the namespace map in the graph. +getNamespaces :: NSGraph lb -> NamespaceMap +getNamespaces = namespaces + +-- | Replace the namespace information in the graph. +setNamespaces :: NamespaceMap -> NSGraph lb -> NSGraph lb +setNamespaces ns g = g { namespaces=ns } + +-- | Retrieve the formulae in the graph. +getFormulae :: NSGraph lb -> FormulaMap lb +getFormulae = formulae + +-- | Replace the formulae in the graph. +setFormulae :: FormulaMap lb -> NSGraph lb -> NSGraph lb +setFormulae fs g = g { formulae=fs } + +-- | Find a formula in the graph, if it exists. +getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb) +getFormula g l = mapFindMaybe l (formulae g) + +-- | Add (or replace) a formula. +setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb +setFormula f g = g { formulae=mapReplace (formulae g) f } + +{-| +Add an arc to the graph. It does not relabel any blank nodes in the input arc, +nor does it change the namespace map, +but it does ensure that the arc is unknown before adding it. +-} +addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb +addArc ar gr = gr { statements=addSetElem ar (statements gr) } + +-- |Add element to the set. + +addSetElem :: (Eq a) => a -> [a] -> [a] +addSetElem e es = if e `elem` es then es else e:es + +grShowList :: (Label lb) => String -> [NSGraph lb] -> String -> String +grShowList _ [] = showString "[no graphs]" +grShowList p (g:gs) = showChar '[' . showString (grShow pp g) . showl gs + where + showl [] = showChar ']' -- showString $ "\n" ++ p ++ "]" + showl (h:hs) = showString (",\n "++p++grShow pp h) . showl hs + pp = ' ':p + +grShow :: (Label lb) => String -> NSGraph lb -> String +grShow p g = + "Graph, formulae: " ++ showForm ++ "\n" ++ + p ++ "arcs: " ++ showArcs p g + where + showForm = foldr ((++) . (pp ++) . show) "" fml + fml = listLookupMap (getFormulae g) + pp = "\n " ++ p + +showArcs :: (Label lb) => String -> NSGraph lb -> String +showArcs p g = foldr ((++) . (pp ++) . show) "" (getArcs g) + where + pp = "\n " ++ p + +-- | Graph equality. +grEq :: (Label lb) => NSGraph lb -> NSGraph lb -> Bool +grEq g1 = fst . grMatchMap g1 + +-- | Match graphs, returning `True` if they are equivalent, +-- with a map of labels to equivalence class identifiers +-- (see 'graphMatch' for further details). +grMatchMap :: (Label lb) => + NSGraph lb -> NSGraph lb -> (Bool, LabelMap (ScopedLabel lb)) +grMatchMap g1 g2 = + graphMatch matchable (getArcs g1) (getArcs g2) + where + matchable l1 l2 = mapFormula g1 l1 == mapFormula g2 l2 + mapFormula g l = mapFindMaybe l (getFormulae g) + +-- |Merge RDF graphs, renaming blank and query variable nodes as +-- needed to neep variable nodes from the two graphs distinct in +-- the resulting graph. +-- +-- Currently formulae are not guaranteed to be preserved across a +-- merge. +-- +merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb +merge gr1 gr2 = + let bn1 = allLabels labelIsVar gr1 + bn2 = allLabels labelIsVar gr2 + dupbn = intersect bn1 bn2 + allbn = union bn1 bn2 + in addGraphs gr1 (remapLabels dupbn allbn id gr2) + +-- |Return list of all labels (including properties) in the graph +-- satisfying a supplied filter predicate. This routine +-- includes the labels in any formulae. +allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) ) + +{- TODO: is the leading 'filter p' needed in allLabels? +-} + +-- |Return list of all subjects and objects in the graph +-- satisfying a supplied filter predicate. +allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +allNodes p = unionNodes p [] . nodes + +-- | List all nodes in graph formulae satisfying a supplied predicate +formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +formulaNodes p gr = foldl' (unionNodes p) fkeys (map (allLabels p) fvals) + where + -- fm :: (Label lb) => FormulaMap lb + -- LookupMap LookupFormula (NSGraph lb) lb + fm = formulae gr + -- fvals :: (Label lb) => [NSGraph lb] + fvals = mapVals fm + -- fkeys :: (Label lb) => [lb] + fkeys = filter p $ mapKeys fm + +-- | Helper to filter variable nodes and merge with those found so far +unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb] +unionNodes p ls1 ls2 = ls1 `union` filter p ls2 + +-- |Remap selected nodes in graph. +-- +-- This is the node renaming operation that prevents graph-scoped +-- variable nodes from being merged when two graphs are merged. +remapLabels :: + (Label lb) + => [lb] -- ^ variable nodes to be renamed (@dupbn@) + -> [lb] -- ^ variable nodes used that must be avoided (@allbn@) + -> (lb -> lb) -- ^ node conversion function that is applied to nodes + -- from @dupbn@ in the graph that are to be replaced by + -- new blank nodes. If no such conversion is required, + -- supply @id@. The function 'makeBlank' can be used to convert + -- RDF query nodes into RDF blank nodes. + -> NSGraph lb -- ^ graph in which nodes are to be renamed + -> NSGraph lb +remapLabels dupbn allbn cnvbn = fmap (mapnode dupbn allbn cnvbn) + +-- |Externally callable function to construct a list of (old,new) +-- values to be used for graph label remapping. +-- +remapLabelList :: + (Label lb) + => [lb] -- ^ labels to be remaped + -> [lb] -- ^ labels to be avoided by the remapping + -> [(lb,lb)] +remapLabelList remap avoid = maplist remap avoid id [] + +-- | Remap a single graph node. +-- +-- If the node is not one of those to be remapped, +-- the supplied value is returned unchanged. +mapnode :: + (Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb +mapnode dupbn allbn cnvbn nv = + mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn [])) + +-- | Construct a list of (oldnode,newnode) values to be used for +-- graph label remapping. The function operates recursively, adding +-- new nodes generated to the accumulator and also to the +-- list of nodes to be avoided. +maplist :: + (Label lb) + => [lb] -- ^ oldnode values + -> [lb] -- ^ nodes to be avoided + -> (lb -> lb) + -> [(lb,lb)] -- ^ accumulator + -> [(lb,lb)] +maplist [] _ _ mapbn = mapbn +maplist (dn:dupbn) allbn cnvbn mapbn = maplist dupbn allbn' cnvbn mapbn' + where + dnmap = newNode (cnvbn dn) allbn + mapbn' = (dn,dnmap):mapbn + allbn' = dnmap:allbn + +-- |Given a node and a list of existing nodes, find a new node for +-- the supplied node that does not clash with any existing node. +-- (Generates an non-terminating list of possible replacements, and +-- picks the first one that isn't already in use.) +-- +-- TODO: optimize this for common case @nnn@ and @_nnn@: +-- always generate @_nnn@ and keep track of last allocated +-- +newNode :: (Label lb) => lb -> [lb] -> lb +newNode dn existnodes = + head $ newNodes dn existnodes + +-- |Given a node and a list of existing nodes, generate a list of new +-- nodes for the supplied node that do not clash with any existing node. +newNodes :: (Label lb) => lb -> [lb] -> [lb] +newNodes dn existnodes = + filter (not . (`elem` existnodes)) $ trynodes (noderootindex dn) + +{- + +For now go with a 32-bit integer (since Int on my machine uses 32-bit +values). We could instead use a Whole class constraint from +Numeric.Natural (in semigroups), but it is probably better to +specialize here. The idea for using Word rather than Int is to +make it obvious that we are only interested in values >= 0. + +-} + +noderootindex :: (Label lb) => lb -> (String, Word32) +noderootindex dn = (nh,nx) where + (nh,nt) = splitnodeid $ getLocal dn + nx = if null nt then 0 else read nt + +splitnodeid :: String -> (String,String) +splitnodeid = break isDigit + +trynodes :: (Label lb) => (String, Word32) -> [lb] +trynodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] + +{- +trybnodes :: (Label lb) => (String,Int) -> [lb] +trybnodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] +-} + +-- | Memory-based RDF graph type + +type RDFGraph = NSGraph RDFLabel + +-- |Create a new RDF graph from a supplied list of arcs. +-- +-- This version will attempt to fill up the namespace map +-- of the graph based on the input labels (including datatypes +-- on literals). For faster +-- creation of a graph you can use: +-- +-- > emptyRDFGraph { statements = arcs } +-- +-- which is how this routine was defined in version @0.3.1.1@ +-- and earlier. +-- +toRDFGraph :: + [RDFTriple] -- ^ There is no check to remove repeated statements in this list, + -- so it is suggested that you use 'Data.List.nub', or convert via 'Data.Set.Set', + -- if your input may contain such elements. + -> RDFGraph +toRDFGraph arcs = + let lbls = concatMap arcLabels arcs + + getNS (Res s) = Just s + getNS (TypedLit _ dt) = Just dt + getNS _ = Nothing + + ns = mapMaybe (fmap getScopeNamespace . getNS) lbls + nsmap = foldl' mapAddIfNew emptyNamespaceMap ns + + in mempty { namespaces = nsmap, statements = arcs } + +-- |Create a new, empty RDF graph (it is just 'mempty'). +-- +emptyRDFGraph :: RDFGraph +emptyRDFGraph = mempty + +{- +-- |Update an RDF graph using a supplied list of arcs, keeping +-- prefix definitions and formula definitions from the original. +-- +-- [[[TODO: I think this may be redundant - the default graph +-- class has an update method which accepts a function to update +-- the arcs, not touching other parts of the graph value.]]] +updateRDFGraph :: RDFGraph -> [RDFTriple] -> RDFGraph +updateRDFGraph gr as = gr { statements=as } +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/GraphClass.hs b/src/Swish/RDF/GraphClass.hs deleted file mode 100644 --- a/src/Swish/RDF/GraphClass.hs +++ /dev/null @@ -1,248 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphClass --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : DeriveFunctor, DeriveFoldable, DeriveTraversable, MultiParamTypeClasses --- --- This module defines a Labelled Directed Graph and Label classes, --- and the Arc datatype. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Define LDGraph, arc and related classes and types ------------------------------------------------------------- - -module Swish.RDF.GraphClass - ( LDGraph(..), replaceArcs - , Label(..) - , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple - , Selector - , hasLabel, arcLabels -- , arcNodes - ) -where - -import qualified Data.Foldable as F -import qualified Data.Traversable as T - -import Data.Hashable (Hashable(..)) - -import Data.List (foldl', union, (\\)) - --- NOTE: I wanted to declare this as a subclass of Functor, but --- the constraint on the label type seems to prevent that. --- So I've just declared specific instances to be Functors. --- - -{-| -Labelled Directed Graph class - -Minimum required implementation: `setArcs`, `getArcs` and `containedIn` -(although @containedIn@ may be removed as it is currently unused). --} -class (Eq (lg lb), Eq lb ) => LDGraph lg lb - where - -- empty graph - -- emptyGr :: lg lb [[[TODO?]]] - -- component-level operations - - -- | Replace the existing arcs in the graph. - setArcs :: [Arc lb] -> lg lb -> lg lb - - -- | Extract all the arcs from a graph - getArcs :: lg lb -> [Arc lb] - - -- | Extract those arcs that match the given `Selector`. - extract :: Selector lb -> lg lb -> lg lb - extract sel = update (filter sel) - - -- | Add the two graphs - add :: lg lb -> lg lb -> lg lb - add addg = update (union (getArcs addg)) - - -- | Remove those arcs in the first graph from the second - -- graph - delete :: lg lb -- ^ g1 - -> lg lb -- ^ g2 - -> lg lb -- ^ g2 - g1 -> g3 - delete delg = update (\\ getArcs delg) - - -- | Enumerate the distinct labels contained in a graph; - -- that is, any label that appears in the subject, - -- predicate or object position of an `Arc`. - labels :: lg lb -> [lb] - labels g = foldl' union [] (map arcLabels (getArcs g)) - - -- | Enumerate the distinct nodes contained in a graph; - -- that is, any label that appears in the subject - -- or object position of an `Arc`. - nodes :: lg lb -> [lb] - nodes g = foldl' union [] (map arcNodes (getArcs g)) - - -- | Test for graph containment in another. - -- - -- At present this is unused and may be removed in a future release. - containedIn :: lg lb -> lg lb -> Bool - - -- | Update the arcs in a graph using a supplied function. - update :: ( [Arc lb] -> [Arc lb] ) -> lg lb -> lg lb - update f g = setArcs ( f (getArcs g) ) g - -{- -TODO: - add a Monoid instance for LDGraph, so that we can remove the - NSGraph instance in RDFGraph - - This means adding the emptyGr function to the interface --} - --- |Function to replace arcs in a graph with a given list of arcs. --- --- This is identical to @flip setArcs@ and so may be removed. --- -replaceArcs :: (LDGraph lg lb) => lg lb -> [Arc lb] -> lg lb -replaceArcs = flip setArcs --- replaceArcs gr as = update (const as) gr - --- | Label class --- --- A label may have a fixed binding, which means that the label identifies (is) a --- particular graph node, and different such labels are always distinct nodes. --- Alternatively, a label may be unbound (variable), which means that it is a --- placeholder for an unknown node label. Unbound node labels are used as --- graph-local identifiers for indicating when the same node appears in --- several arcs. --- --- For the purposes of graph-isomorphism testing, fixed labels are matched when they --- are the same. Variable labels may be matched with any other variable label. --- Our definition of isomorphism (for RDF graphs) does not match variable labels --- with fixed labels. - -class (Eq lb, Show lb, Ord lb) => Label lb where - - -- | Does this node have a variable binding? - labelIsVar :: lb -> Bool - - -- | Calculate the hash of the label using the supplied seed. - labelHash :: Int -> lb -> Int - - -- could provide a default of - -- labelHash = hashWithSalt - -- but this would then force a Hashable constraint - - -- | Extract the local id from a variable node. - getLocal :: lb -> String - - -- | Make a label value from a local id. - makeLabel :: String -> lb - - -- compare :: lb -> lb -> Ordering - -- compare l1 l2 = compare (show l1) (show l2) - --- | Arc type - -data Arc lb = Arc - { asubj :: lb -- ^ The subject of the arc. - , apred :: lb -- ^ The predicate (property) of the arc. - , aobj :: lb -- ^ The object of the arc. - } - deriving (Eq, Functor, F.Foldable, T.Traversable) - -instance (Hashable lb) => Hashable (Arc lb) where - hash (Arc s p o) = hash s `hashWithSalt` p `hashWithSalt` o - hashWithSalt salt (Arc s p o) = salt `hashWithSalt` s `hashWithSalt` p `hashWithSalt` o - --- | Return the subject of the arc. -arcSubj :: Arc lb -> lb -arcSubj = asubj - --- | Return the predicate (property) of the arc. -arcPred :: Arc lb -> lb -arcPred = apred - --- | Return the object of the arc. -arcObj :: Arc lb -> lb -arcObj = aobj - --- | Create an arc. -arc :: lb -- ^ The subject of the arc. - -> lb -- ^ The predicate of the arc. - -> lb -- ^ The object of the arc. - -> Arc lb -arc = Arc - --- | Convert an Arc into a tuple. -arcToTriple :: Arc lb -> (lb,lb,lb) -arcToTriple (Arc s p o) = (s, p, o) - --- | Create an Arc from a tuple. -arcFromTriple :: (lb,lb,lb) -> Arc lb -arcFromTriple (s,p,o) = Arc s p o - -instance Ord lb => Ord (Arc lb) where - compare (Arc s1 p1 o1) (Arc s2 p2 o2) - | cs /= EQ = cs - | cp /= EQ = cp - | otherwise = co - where - cs = compare s1 s2 - cp = compare p1 p2 - co = compare o1 o2 - - {- not needed - (Arc s1 p1 o1) <= (Arc s2 p2 o2) - | s1 /= s2 = s1 <= s2 - | p1 /= p2 = p1 <= p2 - | otherwise = o1 <= o2 - -} - -instance (Show lb) => Show (Arc lb) where - show (Arc lb1 lb2 lb3) = - "("++ show lb1 ++","++ show lb2 ++","++ show lb3 ++")" - --- | Identify arcs. -type Selector lb = Arc lb -> Bool - -hasLabel :: (Eq lb) => lb -> Arc lb -> Bool -hasLabel lbv lb = lbv `elem` arcLabels lb - --- | Return all the labels in an arc. -arcLabels :: Arc lb -> [lb] -arcLabels (Arc lb1 lb2 lb3) = [lb1,lb2,lb3] - --- | Return just the subject and object labels in the arc. -arcNodes :: Arc lb -> [lb] -arcNodes (Arc lb1 _ lb3) = [lb1,lb3] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/GraphMatch.hs b/src/Swish/RDF/GraphMatch.hs deleted file mode 100644 --- a/src/Swish/RDF/GraphMatch.hs +++ /dev/null @@ -1,622 +0,0 @@ -{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphMatch --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses --- --- This module contains graph-matching logic. --- --- The algorithm used is derived from a paper on RDF graph matching --- by Jeremy Carroll [1]. --- --- [1] --- --------------------------------------------------------------------------------- - -module Swish.RDF.GraphMatch - ( graphMatch, - -- * Exported for testing - LabelMap, GenLabelMap(..), LabelEntry, GenLabelEntry(..), - ScopedLabel(..), makeScopedLabel, makeScopedArc, - LabelIndex, EquivalenceClass, nullLabelVal, emptyMap, - labelIsVar, labelHash, - mapLabelIndex, setLabelHash, newLabelMap, - graphLabels, assignLabelMap, newGenerationMap, - graphMatch1, graphMatch2, equivalenceClasses, reclassify - ) where - -import Control.Exception.Base (assert) -import Control.Arrow (second) - -import Data.Ord (comparing) -import Data.List (foldl', nub, sortBy, partition) -import Data.Hashable (combine) -import qualified Data.List as L - -import Swish.RDF.GraphClass (Arc(..), Label(..), - arcLabels, - hasLabel, arcToTriple) -import Swish.Utils.LookupMap (LookupEntryClass(..), LookupMap(..), - makeLookupMap, listLookupMap, mapFind, mapReplaceAll, - mapAddIfNew, mapReplaceMap, mapMerge) -import Swish.Utils.ListHelpers (select, equiv, pairSort, pairGroup, pairUngroup) - --------------------------- --- Label index value type --------------------------- --- - --- | LabelIndex is a unique value assigned to each label, such that --- labels with different values are definitely different values --- in the graph; e.g. do not map to each other in the graph --- bijection. The first member is a generation counter that --- ensures new values are distinct from earlier passes. - -type LabelIndex = (Int,Int) - -nullLabelVal :: LabelIndex -nullLabelVal = (0,0) - ------------------------ --- Label mapping types ------------------------ - -data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv - -type LabelEntry lb = GenLabelEntry lb LabelIndex - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => LookupEntryClass (GenLabelEntry lb lv) lb lv where - keyVal (LabelEntry k v) = (k,v) - newEntry (k,v) = LabelEntry k v - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Show (GenLabelEntry lb lv) where - show = entryShow - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Eq (GenLabelEntry lb lv) where - (==) = entryEq - --- | Type for label->index lookup table -data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = - LabelMap Int (LookupMap (GenLabelEntry lb lv)) - -type LabelMap lb = GenLabelMap lb LabelIndex - -instance (Label lb) => Show (LabelMap lb) where - show = showLabelMap - -instance (Label lb) => Eq (LabelMap lb) where - LabelMap gen1 lmap1 == LabelMap gen2 lmap2 = - gen1 == gen2 && es1 `equiv` es2 - where - es1 = listLookupMap lmap1 - es2 = listLookupMap lmap2 - -emptyMap :: (Label lb) => LabelMap lb -emptyMap = LabelMap 1 $ makeLookupMap [] - --------------------------- --- Equivalence class type --------------------------- --- - --- | Type for equivalence class description --- (An equivalence class is a collection of labels with --- the same LabelIndex value.) - -type EquivalenceClass lb = (LabelIndex,[lb]) - -{- -ecIndex :: EquivalenceClass lb -> LabelIndex -ecIndex = fst --} - -ecLabels :: EquivalenceClass lb -> [lb] -ecLabels = snd - -{- -ecSize :: EquivalenceClass lb -> Int -ecSize = length . ecLabels --} - -ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb -ecRemoveLabel xs l = second (L.delete l) xs - ------------------------------------------------------------- --- Augmented graph label value - for graph matching ------------------------------------------------------------- --- --- | This instance of class label adds a graph identifier to --- each variable label, so that variable labels from --- different graphs are always seen as distinct values. --- --- The essential logic added by this class instance is embodied --- in the eq and hash functions. Note that variable label hashes --- depend only on the graph in which they appear, and non-variable --- label hashes depend only on the variable. Label hash values are --- used when initializing a label equivalence-class map (and, for --- non-variable labels, also for resolving hash collisions). - -data (Label lb) => ScopedLabel lb = ScopedLabel Int lb - -makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb -makeScopedLabel = ScopedLabel - -makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb) -makeScopedArc scope = fmap (ScopedLabel scope) - -instance (Label lb) => Label (ScopedLabel lb) where - getLocal lab = error $ "getLocal for ScopedLabel: "++show lab - makeLabel locnam = error $ "makeLabel for ScopedLabel: "++locnam - labelIsVar (ScopedLabel _ lab) = labelIsVar lab - labelHash seed (ScopedLabel scope lab) - | labelIsVar lab = seed `combine` scope -- MH.hash seed $ show scope ++ "???" - | otherwise = labelHash seed lab - -instance (Label lb) => Eq (ScopedLabel lb) where - (ScopedLabel s1 l1) == (ScopedLabel s2 l2) - = l1 == l2 && s1 == s2 - -instance (Label lb) => Show (ScopedLabel lb) where - show (ScopedLabel s1 l1) = show s1 ++ ":" ++ show l1 - -instance (Label lb) => Ord (ScopedLabel lb) where - compare (ScopedLabel s1 l1) (ScopedLabel s2 l2) = - case compare s1 s2 of - LT -> LT - EQ -> compare l1 l2 - GT -> GT - --- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ? - --- | Graph matching function accepting two lists of arcs and --- returning a node map if successful --- -graphMatch :: (Label lb) => - (lb -> lb -> Bool) - -- ^ a function that tests for additional constraints - -- that may prevent the matching of a supplied pair - -- of nodes. Returns `True` if the supplied nodes may be - -- matched. (Used in RDF graph matching for checking - -- that formula assignments are compatible.) - -> [Arc lb] -- ^ the first graph to be compared, as a list of arcs - -> [Arc lb] -- ^ the second graph to be compared, as a list of arcs - -> (Bool,LabelMap (ScopedLabel lb)) - -- ^ If the first element is `True` then the second element maps each label - -- to an equivalence class identifier, otherwise it is just - -- `emptyMap`. - -- -graphMatch matchable gs1 gs2 = - let - sgs1 = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1 - sgs2 = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2 - ls1 = {- traceShow "ls1 " $ -} graphLabels sgs1 - ls2 = {- traceShow "ls2 " $ -} graphLabels sgs2 - lmap = {- traceShow "lmap " $ -} - newGenerationMap $ - assignLabelMap ls1 $ - assignLabelMap ls2 emptyMap - ec1 = {- traceShow "ec1 " $ -} equivalenceClasses lmap ls1 - ec2 = {- traceShow "ec2 " $ -} equivalenceClasses lmap ls2 - ecpairs = zip (pairSort ec1) (pairSort ec2) - matchableScoped (ScopedLabel _ l1) (ScopedLabel _ l2) = matchable l1 l2 - match = graphMatch1 False matchableScoped sgs1 sgs2 lmap ecpairs - in - if length ec1 /= length ec2 then (False,emptyMap) else match - --- | Recursive graph matching function --- --- This function assumes that no variable label appears in both graphs. --- (Function `graphMatch`, which calls this, ensures that all variable --- labels are distinct.) --- --- TODO: --- --- * replace Equivalence class pair by @(index,[lb],[lb])@ ? --- --- * possible optimization: the `graphMapEq` test should be --- needed only if `graphMatch2` has been used to guess a --- mapping; either: --- a) supply flag saying guess has been used, or --- b) move test to `graphMatch2` and use different --- test to prevent rechecking for each guess used. --- - -graphMatch1 :: - (Label lb) - => Bool - -- ^ `True` if a guess has been used before trying this comparison, - -- `False` if nodes are being matched without any guesswork - -> (lb -> lb -> Bool) - -- ^ Test for additional constraints that may prevent the matching - -- of a supplied pair of nodes. Returns `True` if the supplied - -- nodes may be matched. - -> [Arc lb] - -- ^ (@gs1@ argument) - -- first of two lists of arcs (triples) to be compared - -> [Arc lb] - -- ^ (@gs2@ argument) - -- secind of two lists of arcs (triples) to be compared - -> LabelMap lb - -- ^ the map so far used to map label values to equivalence class - -- values - -> [(EquivalenceClass lb,EquivalenceClass lb)] - -- ^ (the @ecpairs@ argument) list of pairs of corresponding - -- equivalence classes of nodes from @gs1@ and @gs2@ that have not - -- been confirmed in 1:1 correspondence with each other. Each - -- pair of equivalence classes contains nodes that must be placed - -- in 1:1 correspondence with each other. - -- - -> (Bool,LabelMap lb) - -- ^ the pair @(match, map)@ where @match@ is @True@ if the supplied - -- sets of arcs can be matched, in which case @map@ is a - -- corresponding map from labels to equivalence class identifiers. - -- When @match@ is @False@, @map@ is the most detailed equivalence - -- class map obtained before a mismatch was detected or a guess - -- was required -- this is intended to help identify where the - -- graph mismatch may be. -graphMatch1 guessed matchable gs1 gs2 lmap ecpairs = - let - (secs,mecs) = partition uniqueEc ecpairs - uniqueEc ( (_,[_]) , (_,[_]) ) = True - uniqueEc ( _ , _ ) = False - - doMatch ( (_,[l1]) , (_,[l2]) ) = labelMatch matchable lmap l1 l2 - doMatch x = error $ "doMatch failue: " ++ show x -- keep -Wall happy - - ecEqSize ( (_,ls1) , (_,ls2) ) = length ls1 == length ls2 - eSize ( (_,ls1) , _ ) = length ls1 - ecCompareSize = comparing eSize - (lmap',mecs',newEc,matchEc) = reclassify gs1 gs2 lmap mecs - match2 = graphMatch2 matchable gs1 gs2 lmap $ sortBy ecCompareSize mecs - in - -- trace ("graphMatch1\nsingle ECs:\n"++show secs++ - -- "\nmultiple ECs:\n"++show mecs++ - -- "\n\n") $ - -- if mismatch in singleton equivalence classes, fail - if not $ all doMatch secs then (False,lmap) - else - -- if no multi-member equivalence classes, - -- check and return label map supplied - -- trace ("graphMatch1\ngraphMapEq: "++show (graphMapEq lmap gs1 gs2)) $ - if null mecs then (graphMapEq lmap gs1 gs2,lmap) - else - -- if size mismatch in equivalence classes, fail - -- trace ("graphMatch1\nall ecEqSize mecs: "++show (all ecEqSize mecs)) $ - - -- invoke reclassification, and deal with result - if not (all ecEqSize mecs) || not matchEc - then (False, lmap) - else if newEc - then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' - -- if guess does not result in a match, return supplied label map - else if fst match2 then match2 else (False, lmap) - -{- - if not $ all ecEqSize mecs then (False,lmap) - else - if not matchEc then (False,lmap) - else - if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' - else - if fst match2 then match2 else (False,lmap) --} - --- | Auxiliary graph matching function --- --- This function is called when deterministic decomposition of node --- mapping equivalence classes has run its course. --- --- It picks a pair of equivalence classes in ecpairs, and arbitrarily matches --- pairs of nodes in those equivalence classes, recursively calling the --- graph matching function until a suitable node mapping is discovered --- (success), or until all such pairs have been tried (failure). --- --- This function represents a point to which arbitrary choices are backtracked. --- The list comprehension 'glp' represents the alternative choices at the --- point of backtracking --- --- The selected pair of nodes are placed in a new equivalence class based on their --- original equivalence class value, but with a new NodeVal generation number. - -graphMatch2 :: (Label lb) => (lb -> lb -> Bool) - -> [Arc lb] -> [Arc lb] - -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] - -> (Bool,LabelMap lb) -graphMatch2 _ _ _ _ [] = error "graphMatch2 sent an empty list" -- To keep -Wall happy -graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) = - let - v1 = snd ev1 - -- Return any equivalence-mapping obtained by matching a pair - -- of labels in the supplied list, or Nothing. - try [] = (False,lmap) - try ((l1,l2):lps) = if isEquiv try1 l1 l2 then try1 else try lps - where - try1 = graphMatch1 True matchable gs1 gs2 lmap' ecpairs' - lmap' = newLabelMap lmap [(l1,v1),(l2,v1)] - ecpairs' = ((ev',[l1]),(ev',[l2])):ec':ecpairs - ev' = mapLabelIndex lmap' l1 - ec' = (ecRemoveLabel ec1 l1, ecRemoveLabel ec2 l2) - -- [[[TODO: replace this: if isJust try ?]]] - isEquiv (False,_) _ _ = False - isEquiv (True,lm) x1 x2 = - mapLabelIndex m1 x1 == mapLabelIndex m2 x2 - where - m1 = remapLabels gs1 lm [x1] - m2 = remapLabels gs2 lm [x2] - -- glp is a list of label-pair candidates for matching, - -- selected from the first label-equivalence class. - -- NOTE: final test is call of external matchable function - glp = [ (l1,l2) | l1 <- ls1 , l2 <- ls2 , matchable l1 l2 ] - in - assert (ev1==ev2) -- "GraphMatch2: Equivalence class value mismatch" $ - $ try glp - --- this was in Swish.Utils.MiscHelpers along with a simple hash-based function --- based on Sedgewick, Algorithms in C, p233. As we have now moved to using --- Data.Hashable it is not clear whether this is still necessary or sensible. --- -hashModulus :: Int -hashModulus = 16000001 - --- | Returns a string representation of a LabelMap value --- -showLabelMap :: (Label lb) => LabelMap lb -> String -showLabelMap (LabelMap gn lmap) = - "LabelMap gen="++ Prelude.show gn ++", map="++ - foldl' (++) "" (map (("\n "++) . Prelude.show) es) - where - es = listLookupMap lmap - --- | Map a label to its corresponding label index value in the supplied LabelMap --- -mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex -mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms - --- | Confirm that a given pair of labels are matchable, and are --- mapped to the same value by the supplied label map --- -labelMatch :: (Label lb) - => (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool -labelMatch matchable lmap l1 l2 = - matchable l1 l2 && (mapLabelIndex lmap l1 == mapLabelIndex lmap l1) - --- | Replace selected values in a label map with new values from the supplied --- list of labels and new label index values. The generation number is --- supplied from the current label map. The generation number in the --- resulting label map is incremented. --- -newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb -newLabelMap lmap [] = newGenerationMap lmap -newLabelMap lmap (lv:lvs) = setLabelHash (newLabelMap lmap lvs) lv - --- | Replace a label and its associated value in a label map --- with a new value using the supplied hash value and the current --- `LabelMap` generation number. If the key is not found, then no change --- is made to the label map. - -setLabelHash :: (Label lb) - => LabelMap lb -> (lb,Int) -> LabelMap lb -setLabelHash (LabelMap g lmap) (lb,lh) = - LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) ) - --- | Increment the generation of the label map. --- --- Returns a new label map identical to the supplied value --- but with an incremented generation number. --- -newGenerationMap :: (Label lb) => LabelMap lb -> LabelMap lb -newGenerationMap (LabelMap g lvs) = LabelMap (g+1) lvs - --- | Scan label list, assigning initial label map values, --- adding new values to the label map supplied. --- --- Label map values are assigned on the basis of the --- label alone, without regard for it's connectivity in --- the graph. (cf. `reclassify`). --- --- All variable node labels are assigned the same initial --- value, as they may be matched with each other. --- -assignLabelMap :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb -assignLabelMap ns lmap = foldl' (flip assignLabelMap1) lmap ns - -assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb -assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs' - where - lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab)) - --- Calculate initial value for a node - -initVal :: (Label lb) => lb -> Int -initVal = hashVal 0 - -hashVal :: (Label lb) => Int -> lb -> Int -hashVal seed lab = - if labelIsVar lab then seed `combine` 23 else labelHash seed lab - -- if labelIsVar lab then hash seed "???" else labelHash seed lab - -equivalenceClasses :: - (Label lb) - => LabelMap lb -- ^ label map - -> [lb] -- ^ list of nodes to be reclassified - -> [EquivalenceClass lb] - -- ^ the equivalence classes of the supplied labels under the - -- supplied label map -equivalenceClasses lmap ls = - pairGroup $ map labelPair ls - where - labelPair l = (mapLabelIndex lmap l,l) - --- | Reclassify labels --- --- Examines the supplied label equivalence classes (based on the supplied --- label map), and evaluates new equivalence subclasses based on node --- values and adjacency (for variable nodes) and rehashing --- (for non-variable nodes). --- --- Note, assumes that all all equivalence classes supplied are --- non-singletons; i.e. contain more than one label. --- -reclassify :: - (Label lb) - => [Arc lb] - -- ^ (the @gs1@ argument) the first of two lists of arcs (triples) to perform a - -- basis for reclassifying the labels in the first equivalence - -- class in each pair of @ecpairs@. - -> [Arc lb] - -- ^ (the @gs2@ argument) the second of two lists of arcs (triples) to perform a - -- basis for reclassifying the labels in the second equivalence - -- class in each pair of the @ecpairs@ argument - -> LabelMap lb - -- ^ the label map used for classification of the labels in - -- the supplied equivalence classes - -> [(EquivalenceClass lb,EquivalenceClass lb)] - -- ^ (the @ecpairs@ argument) a list of pairs of corresponding equivalence classes of - -- nodes from @gs1@ and @gs2@ that have not been confirmed - -- in 1:1 correspondence with each other. - -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool) - -- ^ The output tuple consists of: - -- - -- 1) a revised label map reflecting the reclassification - -- - -- 2) a new list of equivalence class pairs based on the - -- new node map - -- - -- 3) if the reclassification partitions any of the - -- supplied equivalence classes then `True`, else `False` - -- - -- 4) if reclassification results in each equivalence class - -- being split same-sized equivalence classes in the two graphs, - -- then `True`, otherwise `False`. - -reclassify gs1 gs2 lmap@(LabelMap _ lm) ecpairs = - assert (gen1==gen2) -- "Label map generation mismatch" - (LabelMap gen1 lm',ecpairs',newPart,matchPart) - where - LabelMap gen1 lm1 = - remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs - LabelMap gen2 lm2 = - remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs - lm' = mapReplaceMap lm $ mapMerge lm1 lm2 - - tmap f (a,b) = (f a, f b) - - -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])] - ecGroups = map (tmap remapEc) ecpairs - ecpairs' = concatMap (uncurry zip) ecGroups - newPart = any pairG1 lenGroups - matchPart = all pairEq lenGroups - lenGroups = map (tmap length) ecGroups - pairEq = uncurry (==) - pairG1 (p1,p2) = p1 > 1 || p2 > 1 - remapEc = pairGroup . map (newIndex lm') . pairUngroup - newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab) - --- | Calculate a new index value for a supplied list of labels based on the --- supplied label map and adjacency calculations in the supplied graph --- -remapLabels :: - (Label lb) - => [Arc lb] -- ^ arcs used for adjacency calculations when remapping - -> LabelMap lb -- ^ the current label index values - -> [lb] -- ^ the graph labels for which new mappings are to be created - -> LabelMap lb - -- ^ the updated label map containing recalculated label index values - -- for the given graph labels. The label map generation number is - -- incremented by 1. -remapLabels gs lmap@(LabelMap gen _) ls = - LabelMap gen' (LookupMap newEntries) - where - gen' = gen+1 - newEntries = [ newEntry (l, (gen',newIndex l)) | l <- ls ] - newIndex l - | labelIsVar l = mapAdjacent l -- adjacency classifies variable labels - | otherwise = hashVal gen l -- otherwise rehash (to disentangle collisions) - -- mapAdjacent l = sum (sigsOver l) `rem` hashModulus - mapAdjacent l = sum (sigsOver l) `combine` hashModulus -- is this a sensible replacement for `rem` MH.hashModulus - sigsOver l = select (hasLabel l) gs (arcSignatures lmap gs) - --- | Return list of distinct labels used in a graph - -graphLabels :: (Label lb) => [Arc lb] -> [lb] -graphLabels = nub . concatMap arcLabels - --- | Calculate a signature value for each arc that can be used in constructing an --- adjacency based value for a node. The adjacancy value for a label is obtained --- by summing the signatures of all statements containing that label. --- -arcSignatures :: - (Label lb) - => LabelMap lb -- ^ the current label index values - -> [Arc lb] -- ^ calculate signatures for these arcs - -> [Int] -- ^ the signatures of the arcs -arcSignatures lmap = - map (sigCalc . arcToTriple) - where - sigCalc (s,p,o) = - ( labelVal2 s + - labelVal2 p * 3 + - labelVal2 o * 5 ) - `combine` hashModulus - -- `rem` hashModulus - - labelVal = mapLabelIndex lmap - labelVal2 = uncurry (*) . labelVal - --- | Return a new graph that is supplied graph with every node/arc --- mapped to a new value according to the supplied function. --- --- Used for testing for graph equivalence under a supplied --- label mapping; e.g. --- --- > if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same) --- -graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex] -graphMap = map . fmap . mapLabelIndex -- graphMapStmt - --- | Compare a pair of graphs for equivalence under a given mapping --- function. --- --- This is used to perform the ultimate test that two graphs are --- indeed equivalent: guesswork in `graphMatch2` means that it is --- occasionally possible to construct a node mapping that generates --- the required singleton equivalence classes, but does not fully --- reflect the topology of the graphs. - -graphMapEq :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc lb] -> Bool -graphMapEq lmap gs1 gs2 = graphMap lmap gs1 `equiv` graphMap lmap gs2 - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/GraphMem.hs b/src/Swish/RDF/GraphMem.hs deleted file mode 100644 --- a/src/Swish/RDF/GraphMem.hs +++ /dev/null @@ -1,166 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphMem --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses --- --- This module defines a simple memory-based graph instance. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Simple labelled directed graph value ------------------------------------------------------------- - -module Swish.RDF.GraphMem - ( GraphMem(..) - , setArcs, getArcs, add, delete, extract, labels - , LabelMem(..) - , labelIsVar, labelHash - -- For debug/test: - , matchGraphMem - ) where - -import Swish.RDF.GraphClass -import Swish.RDF.GraphMatch --- import Swish.Utils.MiscHelpers (hash) - -import Data.Hashable (Hashable(..), combine) -import Data.Ord (comparing) - -import qualified Data.Foldable as F -import qualified Data.Traversable as T - --- | Memory-based graph type - -data GraphMem lb = GraphMem { arcs :: [Arc lb] } - deriving (Functor, F.Foldable, T.Traversable) - -instance (Label lb) => LDGraph GraphMem lb where - getArcs = arcs - setArcs as g = g { arcs=as } - -- gmap f g = g { arcs = (map $ fmap f) (arcs g) } - containedIn = error "containedIn for LDGraph GraphMem lb is undefined!" -- TODO: should there be one defined? - -instance (Label lb) => Eq (GraphMem lb) where - (==) = graphEq - -instance (Label lb) => Show (GraphMem lb) where - show = graphShow - -graphShow :: (Label lb) => GraphMem lb -> String -graphShow g = "Graph:" ++ foldr ((++) . ("\n " ++) . show) "" (arcs g) - -{- -toGraph :: (Label lb) => [Arc lb] -> GraphMem lb -toGraph as = GraphMem { arcs=nub as } --} - --- | Return Boolean graph equality - -graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool -graphEq g1 g2 = fst ( matchGraphMem g1 g2 ) - --- | GraphMem matching function accepting GraphMem value and returning --- node map if successful --- -matchGraphMem :: - (Label lb) - => GraphMem lb - -> GraphMem lb - -> (Bool,LabelMap (ScopedLabel lb)) - -- ^ if the first element is @True@ then the second value is a label - -- map that maps each label to an equivalence-class identifier, - -- otherwise `emptyMap`. - -- -matchGraphMem g1 g2 = - let - gs1 = arcs g1 - gs2 = arcs g2 - matchable l1 l2 - | labelIsVar l1 && labelIsVar l2 = True - | labelIsVar l1 || labelIsVar l2 = False - | otherwise = l1 == l2 - in - graphMatch matchable gs1 gs2 - -{- --- | Return bijection between two graphs, or empty list -graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)] -graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2) - where - lmap = graphMatch g1 g2 - sortedls g = map snd $ - (sortBy indexComp) $ - equivalenceClasses (graphLabels $ arcs g) lmap - classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2) - indexComp (g1,v1) (g2,v2) - | g1 == g2 = compare v1 v2 - | otherwise = compare g1 g2 --} - --- | Minimal graph label value - for testing - -data LabelMem - = LF String - | LV String - -instance Hashable LabelMem where - hash (LF l) = 1 `hashWithSalt` l - hash (LV l) = 2 `hashWithSalt` l - hashWithSalt salt (LF l) = salt `combine` 1 `hashWithSalt` l - hashWithSalt salt (LV l) = salt `combine` 2 `hashWithSalt` l - -instance Label LabelMem where - labelIsVar (LV _) = True - labelIsVar _ = False - getLocal (LV loc) = loc - getLocal lab = error "getLocal of non-variable label: " ++ show lab - makeLabel = LV - -- labelHash seed lb = hash seed (show lb) - labelHash = hashWithSalt - -instance Eq LabelMem where - (LF l1) == (LF l2) = l1 == l2 - (LV l1) == (LV l2) = l1 == l2 - _ == _ = False - -instance Show LabelMem where - show (LF l1) = '!' : l1 - show (LV l2) = '?' : l2 - -instance Ord LabelMem where - compare = comparing show - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/GraphPartition.hs b/src/Swish/RDF/GraphPartition.hs deleted file mode 100644 --- a/src/Swish/RDF/GraphPartition.hs +++ /dev/null @@ -1,570 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphPartition --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module contains functions for partitioning a graph into subgraphs --- that rooted from different subject nodes. --- --------------------------------------------------------------------------------- - -module Swish.RDF.GraphPartition - ( PartitionedGraph(..), getArcs, getPartitions - , GraphPartition(..), node, toArcs - , partitionGraph, comparePartitions - , partitionShowP - ) -where - -import Swish.RDF.GraphClass - ( Label(..) - , Arc(..), arcSubj, arcObj, - -- , hasLabel, arcLabels - ) - -import Data.List (foldl', partition) - -import Control.Monad.State - ( MonadState(..), State, evalState ) - -import Data.Maybe (isJust, fromJust, mapMaybe) - - ------------------------------------------------------------- --- Data type for a partitioned graph ------------------------------------------------------------- - --- |Representation of a graph as a collection of (possibly nested) --- partitions. Each node in the graph appears at least once as the --- root value of a 'GraphPartition' value: --- --- * Nodes that are the subject of at least one statement appear as --- the first value of exactly one 'PartSub' constructor, and may --- also appear in any number of 'PartObj' constructors. --- --- * Nodes appearing only as objects of statements appear only in --- 'PartObj' constructors. - -data PartitionedGraph lb = PartitionedGraph [GraphPartition lb] - deriving (Eq,Show) - -getArcs :: PartitionedGraph lb -> [Arc lb] -getArcs (PartitionedGraph ps) = concatMap toArcs ps - -getPartitions :: PartitionedGraph lb -> [GraphPartition lb] -getPartitions (PartitionedGraph ps) = ps - --- QUS: is the list always guaranteed to be non-empty in PartSub? -data GraphPartition lb - = PartObj lb - | PartSub lb [(lb,GraphPartition lb)] - -node :: GraphPartition lb -> lb -node (PartObj ob) = ob -node (PartSub sb _) = sb - -toArcs :: GraphPartition lb -> [Arc lb] -toArcs (PartObj _) = [] -toArcs (PartSub sb prs) = concatMap toArcs1 prs - where - toArcs1 (pr,ob) = Arc sb pr (node ob) : toArcs ob - -instance (Label lb) => Eq (GraphPartition lb) where - (==) = partitionEq - -instance (Label lb) => Show (GraphPartition lb) where - show = partitionShow - --- Equality is based on total structural equivalence. --- This is not the same as graph equality. -partitionEq :: (Label lb) => GraphPartition lb -> GraphPartition lb -> Bool -partitionEq (PartObj o1) (PartObj o2) = o1 == o2 -partitionEq (PartSub s1 p1) (PartSub s2 p2) = s1 == s2 && p1 == p2 -partitionEq _ _ = False - -partitionShow :: (Label lb) => GraphPartition lb -> String -partitionShow (PartObj ob) = show ob -partitionShow (PartSub sb []) = "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible? -partitionShow (PartSub sb (pr:prs)) = - "("++ show sb ++ " " ++ showpr pr ++ concatMap ((" ; "++).showpr) prs ++ ")" - where - showpr (a,b) = show a ++ " " ++ show b - -partitionShowP :: (Label lb) => String -> GraphPartition lb -> String -partitionShowP _ (PartObj ob) = show ob -partitionShowP pref (PartSub sb []) = pref ++ "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible? -partitionShowP pref (PartSub sb (pr:prs)) = - pref++"("++ show sb ++ " " ++ showpr pr ++ concatMap (((pref++" ; ")++).showpr) prs ++ ")" - where - showpr (a,b) = show a ++ " " ++ partitionShowP (pref++" ") b - ------------------------------------------------------------- --- Creating partitioned graphs ------------------------------------------------------------- --- --- |Turning a partitioned graph into a flat graph is easy. --- The interesting challenge is to turn a flat graph into a --- partitioned graph that is more useful for certain purposes. --- Currently, I'm interested in: --- --- (1) isolating differences between graphs --- --- (2) pretty-printing graphs --- --- For (1), the goal is to separate subgraphs that are known --- to be equivalent from subgraphs that are known to be different, --- such that: --- --- * different sub-graphs are minimized, --- --- * different --- sub-graphs are placed into 1:1 correspondence (possibly with null --- subgraphs), and --- --- * only deterministic matching decisions are made. --- --- For (2), the goal is to decide when a subgraph is to be treated --- as nested in another partition, or treated as a new top-level partition. --- If a subgraph is referenced by exactly one graph partition, it should --- be nested in that partition, otherwise it should be a new top-level --- partition. --- --- Strategy. Examining just subject and object nodes: --- --- * all non-blank subject nodes are the root of a top-level partition --- --- * blank subject nodes that are not the object of exactly one statement --- are the root of a top-level partition. --- --- * blank nodes referenced as the object of exactly 1 statement --- of an existing partition are the root of a sub-partition of the --- refering partition. --- --- * what remain are circular chains of blank nodes not referenced --- elsewhere: for each such chain, pick a root node arbitrarily. --- -partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb -partitionGraph arcs = - makePartitions fixs topv1 intv1 - where - (fixs,vars) = partition isNonVar $ collect arcSubj arcs - vars1 = collectMore arcObj arcs vars - (intv,topv) = partition objOnce vars1 - intv1 = map stripObj intv - topv1 = map stripObj topv - isNonVar = not . labelIsVar . fst - objOnce = isSingle . snd . snd - isSingle [_] = True - isSingle _ = False - stripObj (k,(s,_)) = (k,s) - --- Local state type for partitioning function -type MakePartitionState lb = ([(lb,[Arc lb])],[(lb,[Arc lb])],[(lb,[Arc lb])]) - -makePartitions :: (Eq lb) => - [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> PartitionedGraph lb -makePartitions fixs topv intv = - PartitionedGraph $ evalState (makePartitions1 []) (fixs,topv,intv) - --- Use a state monad to keep track of arcs that have been incorporated into --- the resulting list of graph partitions. The collections of arcs used to --- generate the list of partitions are supplied as theinitial state of the --- monad (see call of evalState above). --- -makePartitions1 :: (Eq lb) => - [(lb,[Arc lb])] -> State (MakePartitionState lb) [GraphPartition lb] -makePartitions1 [] = - do { s <- pickNextSubject - ; if null s then return [] else makePartitions1 s - } -makePartitions1 (sub:subs) = - do { ph <- makePartitions2 sub - ; pt <- makePartitions1 subs - ; return $ ph++pt - } - -makePartitions2 :: (Eq lb) => - (lb,[Arc lb]) -> State (MakePartitionState lb) [GraphPartition lb] -makePartitions2 subs = - do { (part,moresubs) <- makeStatements subs - ; moreparts <- if not (null moresubs) then - makePartitions1 moresubs - else - return [] - ; return $ part:moreparts - } - -makeStatements :: (Eq lb) => - (lb,[Arc lb]) - -> State (MakePartitionState lb) (GraphPartition lb,[(lb,[Arc lb])]) -makeStatements (sub,stmts) = - do { propmore <- mapM makeStatement stmts - ; let (props,moresubs) = unzip propmore - ; return (PartSub sub props,concat moresubs) - } - -makeStatement :: (Eq lb) => - Arc lb - -> State (MakePartitionState lb) ((lb,GraphPartition lb),[(lb,[Arc lb])]) -makeStatement (Arc _ prop obj) = - do { intobj <- pickIntSubject obj - ; (gpobj,moresubs) <- if null intobj - then - do { ms <- pickVarSubject obj - ; return (PartObj obj,ms) - } - else - makeStatements (head intobj) - ; return ((prop,gpobj),moresubs) - } - -pickNextSubject :: State (MakePartitionState lb) [(lb,[Arc lb])] -pickNextSubject = - do { (a1,a2,a3) <- get - ; let (s,st) = case (a1,a2,a3) of - (s1h:s1t,s2,s3) -> ([s1h],(s1t,s2,s3)) - ([],s2h:s2t,s3) -> ([s2h],([],s2t,s3)) - ([],[],s3h:s3t) -> ([s3h],([],[],s3t)) - ([],[],[]) -> ([] ,([],[],[] )) - ; put st - ; return s - } - -pickIntSubject :: (Eq lb) => - lb -> State (MakePartitionState lb) [(lb,[Arc lb])] -pickIntSubject sub = - do { (s1,s2,s3) <- get - ; let varsub = removeBy (\x->(x==).fst) sub s3 - ; if isJust varsub then - do { let (vs,s3new) = fromJust varsub - ; put (s1,s2,s3new) - ; return [vs] - } - else - return [] - } - -pickVarSubject :: (Eq lb) => - lb -> State (MakePartitionState lb) [(lb,[Arc lb])] -pickVarSubject sub = - do { (s1,s2,s3) <- get - ; let varsub = removeBy (\x->(x==).fst) sub s2 - ; if isJust varsub then - do { let (vs,s2new) = fromJust varsub - ; put (s1,s2new,s3) - ; return [vs] - } - else - return [] - } - ------------------------------------------------------------- --- Other useful functions ------------------------------------------------------------- --- --- Create a list of pairs of corresponding Partitions that --- are unequal - -comparePartitions :: (Label lb) => - PartitionedGraph lb -> PartitionedGraph lb - -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions (PartitionedGraph gp1) (PartitionedGraph gp2) = - comparePartitions1 (reverse gp1) (reverse gp2) - -comparePartitions1 :: (Label lb) => - [GraphPartition lb] -> [GraphPartition lb] - -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions1 pg1 pg2 = - ds ++ [ (Just r1p,Nothing) | r1p<-r1 ] - ++ [ (Nothing,Just r2p) | r2p<-r2 ] - where - (ds,r1,r2) = listDifferences comparePartitions2 pg1 pg2 - --- Compare two graph partitions, with three possible outcomes: --- Nothing -> no match --- Just [] -> total match --- Just [...] -> partial match, with mismatched sub-partitions listed. --- --- A partial match occurs when the leading nodes are non-variable and --- equal, but something else in the partition does not match. --- --- A complete match can be achieved with variable nodes that have --- different labels --- -comparePartitions2 :: (Label lb) => - GraphPartition lb -> GraphPartition lb - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions2 (PartObj l1) (PartObj l2) = - if matchNodes l1 l2 then Just [] else Nothing -comparePartitions2 pg1@(PartSub l1 p1s) pg2@(PartSub l2 p2s) = - if match then comp1 else Nothing - where - comp1 = case comparePartitions3 l1 l2 p1s p2s of - Nothing -> if matchVar then Nothing - else Just [(Just pg1,Just pg2)] - Just [] -> Just [] - Just ps -> {- if matchVar then Nothing else -} Just ps - matchVar = labelIsVar l1 && labelIsVar l2 - match = matchVar || l1 == l2 -comparePartitions2 pg1 pg2 = - if not (labelIsVar l1) && l1 == l2 - then Just [(Just pg1,Just pg2)] - else Nothing - where - l1 = node pg1 - l2 = node pg2 - -comparePartitions3 :: (Label lb) => - lb -> lb -> [(lb,GraphPartition lb)] -> [(lb,GraphPartition lb)] - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions3 l1 l2 s1s s2s = Just $ - ds ++ [ (Just (PartSub l1 [r1p]),Nothing) | r1p<-r1 ] - ++ [ (Nothing,Just (PartSub l2 [r2p])) | r2p<-r2 ] - where - (ds,r1,r2) = listDifferences (comparePartitions4 l1 l2) s1s s2s - -comparePartitions4 :: (Label lb) => - lb -> lb -> (lb,GraphPartition lb) -> (lb,GraphPartition lb) - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions4 _ _ (p1,o1) (p2,o2) = - if matchNodes p1 p2 then comp1 else Nothing - where - comp1 = case comparePartitions2 o1 o2 of - Nothing -> Just [(Just o1,Just o2)] - ds -> ds - -matchNodes :: (Label lb) => lb -> lb -> Bool -matchNodes l1 l2 - | labelIsVar l1 = labelIsVar l2 - | otherwise = l1 == l2 - - ------------------------------------------------------------- --- Helpers ------------------------------------------------------------- - --- |Collect a list of items by some comparison of a selected component --- or other derived value. --- --- cmp a comparison function that determines if a pair of values --- should be grouped together --- sel a function that selects a value from any item --- --- Example: collect fst [(1,'a'),(2,'b'),(1,'c')] = --- [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])] --- -collect :: (Eq b) => (a->b) -> [a] -> [(b,[a])] -collect = collectBy (==) - -collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b,[a])] -collectBy cmp sel = map reverseCollection . collectBy1 cmp sel [] - -collectBy1 :: (b->b->Bool) -> (a->b) -> [(b,[a])] -> [a] -> [(b,[a])] -collectBy1 _ _ sofar [] = sofar -collectBy1 cmp sel sofar (a:as) = - collectBy1 cmp sel (collectBy2 cmp sel a sofar) as - -collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b,[a])] -> [(b,[a])] -collectBy2 _ sel a [] = [(sel a,[a])] -collectBy2 cmp sel a (col@(k,as):cols) - | cmp ka k = (k,a:as):cols - | otherwise = col:collectBy2 cmp sel a cols - where - ka = sel a - -reverseCollection :: (b,[a]) -> (b,[a]) -reverseCollection (k,as) = (k,reverse as) - -{- --- Example/test: -testCollect1 :: [(Int, [(Int, Char)])] -testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')] - -testCollect2 :: Bool -testCollect2 = testCollect1 - == [ (1,[(1,'a'),(1,'c'),(1,'d')]) - , (2,[(2,'b'),(2,'d')]) - , (3,[(3,'d')]) - ] --} - --- |Add new values to an existing list of collections. --- The list of collections is not extended, but each collection is --- augmented with a further list of values from the supplied list, --- each of which are related to the existing collection in some way. --- --- NOTE: the basic pattern of 'collect' and 'collectMore' is similar, --- and might be generalized into a common set of core functions. --- -collectMore :: (Eq b) => (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] -collectMore = collectMoreBy (==) - -collectMoreBy :: - (b->b->Bool) -> (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] -collectMoreBy cmp sel as cols = - map reverseMoreCollection $ - collectMoreBy1 cmp sel as (map (\ (b,cs) -> (b,(cs,[])) ) cols) - -collectMoreBy1 :: - (b->b->Bool) -> (a->b) -> [a] -> [(b,(c,[a]))] -> [(b,(c,[a]))] -collectMoreBy1 _ _ [] cols = cols -collectMoreBy1 cmp sel (a:as) cols = - collectMoreBy1 cmp sel as (collectMoreBy2 cmp sel a cols) - -collectMoreBy2 :: - (b->b->Bool) -> (a->b) -> a -> [(b,(c,[a]))] -> [(b,(c,[a]))] -collectMoreBy2 _ _ _ [] = [] -collectMoreBy2 cmp sel a (col@(k,(b,as)):cols) - | cmp (sel a) k = (k,(b,a:as)):cols - | otherwise = col:collectMoreBy2 cmp sel a cols - -reverseMoreCollection :: (b,(c,[a])) -> (b,(c,[a])) -reverseMoreCollection (k,(c,as)) = (k,(c,reverse as)) - -{- --- Example/test: -testCollectMore1 = - collectMore snd [(111,1),(112,1),(211,2),(311,3),(411,4)] testCollect1 - -testCollectMore2 :: Bool -testCollectMore2 = testCollectMore1 - == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)])) - , (2,([(2,'b'),(2,'d')],[(211,2)])) - , (3,([(3,'d')],[(311,3)])) - ] --} - --- |Remove supplied element from a list using the supplied test --- function, and return Just the element remoived and the --- remaining list, or Nothing if no element was matched for removal. --- -{- -remove :: (Eq a) => a -> [a] -> Maybe (a,[a]) -remove = removeBy (==) - -testRemove1 = remove 3 [1,2,3,4,5] -testRemove2 = testRemove1 == Just (3,[1,2,4,5]) -testRemove3 = remove 3 [1,2,4,5] -testRemove4 = testRemove3 == Nothing -testRemove5 = remove 5 [1,2,4,5] -testRemove6 = testRemove5 == Just (5,[1,2,4]) -testRemove7 = remove 1 [1,2,4] -testRemove8 = testRemove7 == Just (1,[2,4]) -testRemove9 = remove 2 [2] -testRemove10 = testRemove9 == Just (2,[]) - --} - -removeBy :: (b->a->Bool) -> b -> [a] -> Maybe (a,[a]) -removeBy cmp a0 as = removeBy1 cmp a0 as [] - -removeBy1 :: (b->a->Bool) -> b -> [a] -> [a] -> Maybe (a,[a]) -removeBy1 _ _ [] _ = Nothing -removeBy1 cmp a0 (a:as) sofar - | cmp a0 a = Just (a,reverseTo sofar as) - | otherwise = removeBy1 cmp a0 as (a:sofar) - --- |Reverse first argument, prepending the result to the second argument --- -reverseTo :: [a] -> [a] -> [a] -reverseTo front back = foldl' (flip (:)) back front - --- |Remove each element from a list, returning a list of pairs, --- each of which is the element removed and the list remaining. --- -removeEach :: [a] -> [(a,[a])] -removeEach [] = [] -removeEach (a:as) = (a,as):[ (a1,a:a1s) | (a1,a1s) <- removeEach as ] - -{- -testRemoveEach1 = removeEach [1,2,3,4,5] -testRemoveEach2 = testRemoveEach1 == - [ (1,[2,3,4,5]) - , (2,[1,3,4,5]) - , (3,[1,2,4,5]) - , (4,[1,2,3,5]) - , (5,[1,2,3,4]) - ] --} - --- |List differences between the members of two lists, where corresponding --- elements may appear at arbitrary locations in the corresponding lists. --- --- Elements are compared using the function 'cmp', which returns: --- * Nothing if the elements are completely unrelated --- * Just [] if the elements are identical --- * Just ds if the elements are related but not identical, in which case --- ds is a list of values describing differences between them. --- --- Returns (ds,u1,u2), where: --- ds is null if the related elements from each list are identical, --- otherwise is a list of differences between the related elements. --- u1 is a list of elements in a1 not related to elements in a2. --- u2 is a list of elements in a2 not related to elements in a1. --- -listDifferences :: (a->a->Maybe [d]) -> [a] -> [a] -> ([d],[a],[a]) -listDifferences _ [] a2s = ([],[],a2s) -listDifferences cmp (a1:a1t) a2s = - case mcomp of - Nothing -> morediffs [] [a1] a1t a2s - Just (ds,a2t) -> morediffs ds [] a1t a2t - where - -- mcomp finds identical match, if there is one, or - -- the first element in a2s related to a1, or Nothing - -- [choose was listToMaybe, - -- but that didn't handle repeated properties well] - mcomp = choose $ mapMaybe maybeResult comps - comps = [ (cmp a1 a2,a2t) | (a2,a2t) <- removeEach a2s ] - maybeResult (Nothing,_) = Nothing - maybeResult (Just ds,a2t) = Just (ds,a2t) - morediffs xds xa1h xa1t xa2t = (xds++xds1,xa1h++xa1r,xa2r) - where - (xds1,xa1r,xa2r) = listDifferences cmp xa1t xa2t - choose [] = Nothing - choose ds@(d:_) = choose1 d ds - choose1 _ (d@([],_):_) = Just d - choose1 d [] = Just d - choose1 d (_:ds) = choose1 d ds - -{- -testcmp (l1,h1) (l2,h2) - | (l1 >= h2) || (l2 >= h1) = Nothing - | (l1 == l2) && (h1 == h2) = Just [] - | otherwise = Just [((l1,h1),(l2,h2))] - -testdiff1 = listDifferences testcmp - [(12,15),(1,2),(3,4),(5,8),(10,11)] - [(10,11),(0,1),(3,4),(6,9),(13,15)] -testdiff2 = testdiff1 == ([((12,15),(13,15)),((5,8),(6,9))],[(1,2)],[(0,1)]) --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/GraphShowLines.hs b/src/Swish/RDF/GraphShowLines.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/GraphShowLines.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphShowLines +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, TypeSynonymInstances +-- +-- This module defines a `ShowLines` class instance for `RDFGraph`, to be +-- used when displaying RDF Graph values as part of a proof sequence, +-- etc. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.GraphShowLines () where + +import Swish.RDF.Graph (RDFGraph) +import Swish.RDF.Formatter.N3 (formatGraphIndent) + +import Data.String.ShowLines (ShowLines(..)) + +-- import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B + +instance ShowLines RDFGraph where + -- showls linebreak = shows . L.unpack . B.toLazyText . formatGraphIndent linebreak False + showls linebreak = shows . formatGraphIndent (B.fromString linebreak) False + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/MapXsdDecimal.hs b/src/Swish/RDF/MapXsdDecimal.hs deleted file mode 100644 --- a/src/Swish/RDF/MapXsdDecimal.hs +++ /dev/null @@ -1,72 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : MapXsdDecimal --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, --- 2011 Douglas Burke, 2011 William Waites --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines the datatytpe mapping and relation values --- used for RDF dataype xsd:decimal --- --------------------------------------------------------------------------------- - -module Swish.RDF.MapXsdDecimal (mapXsdDecimal) where - -import Swish.RDF.Datatype (DatatypeMap(..)) - -import qualified Data.Text as T -import qualified Data.Text.Read as T - ------------------------------------------------------------- --- Implementation of DatatypeMap for xsd:decimal ------------------------------------------------------------- - --- |mapXsdDecimal contains functions that perform lexical-to-value --- and value-to-canonical-lexical mappings for xsd:decimal values --- -mapXsdDecimal :: DatatypeMap Double -mapXsdDecimal = DatatypeMap - { -- mapL2V :: T.Text -> Maybe Double - mapL2V = \txt -> case T.double txt of - Right (val, "") -> Just val - _ -> Nothing - - -- mapV2L :: Double -> Maybe T.Text - -- TODO: for now convert via String as issues with text-format - -- (inability to use with ghci) - , mapV2L = Just . T.pack . show - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, --- 2011 Douglas Burke, 2011 William Waites --- --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/MapXsdInteger.hs b/src/Swish/RDF/MapXsdInteger.hs deleted file mode 100644 --- a/src/Swish/RDF/MapXsdInteger.hs +++ /dev/null @@ -1,69 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : MapXsdInteger --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines the datatytpe mapping and relation values --- used for RDF dataype xsd:integer --- --------------------------------------------------------------------------------- - -module Swish.RDF.MapXsdInteger (mapXsdInteger) where - -import Swish.RDF.Datatype (DatatypeMap(..)) - -import qualified Data.Text as T -import qualified Data.Text.Read as T - ------------------------------------------------------------- --- Implementation of DatatypeMap for xsd:integer ------------------------------------------------------------- - --- |mapXsdInteger contains functions that perform lexical-to-value --- and value-to-canonical-lexical mappings for xsd:integer values --- -mapXsdInteger :: DatatypeMap Integer -mapXsdInteger = DatatypeMap - { -- mapL2V :: T.Text -> Maybe Integer - mapL2V = \txt -> case T.signed T.decimal txt of - Right (val, "") -> Just val - _ -> Nothing - - -- mapV2L :: Integer -> Maybe T.Text - -- TODO: for now convert via String as issues with text-format - -- (inability to use with ghci) - , mapV2L = Just . T.pack . show - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/N3Formatter.hs b/src/Swish/RDF/N3Formatter.hs deleted file mode 100644 --- a/src/Swish/RDF/N3Formatter.hs +++ /dev/null @@ -1,941 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3Formatter --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This Module implements a Notation 3 formatter (see [1], [2] and [3]), --- for an RDFGraph value. --- --- REFERENCES: --- --- (1) --- Notation3 (N3): A readable RDF syntax, --- W3C Team Submission 14 January 2008 --- --- (2) --- Tim Berners-Lee's design issues series notes and description --- --- (2) --- Notation 3 Primer by Sean Palmer --- --- TODO: --- --- * Initial prefix list to include nested formulae; --- then don't need to update prefix list for these. --- --- * correct output of strings containing unsupported escape --- characters (such as @\\q@) --- --- * more flexible terminator generation for formatted formulae --- (for inline blank nodes.) --- --------------------------------------------------------------------------------- - -{- -TODO: - -The code used to determine whether a blank node can be written -using the "[]" short form could probably take advantage of the -GraphPartition module. - --} - -module Swish.RDF.N3Formatter - ( NodeGenLookupMap - , formatGraphAsText - , formatGraphAsLazyText - , formatGraphAsBuilder - , formatGraphIndent - , formatGraphDiag - ) -where - -import Swish.RDF.RDFGraph ( - RDFGraph, RDFLabel(..), - NamespaceMap, RevNamespaceMap, - emptyNamespaceMap, - FormulaMap, emptyFormulaMap, - getArcs, labels, - setNamespaces, getNamespaces, - getFormulae, - emptyRDFGraph - , quote - , quoteT - , resRdfFirst, resRdfRest, resRdfNil - ) - -import Swish.RDF.Vocabulary ( - isLang, langTag, - rdfType, - rdfNil, - owlSameAs, logImplies - , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble - ) - -import Swish.RDF.GraphClass (Arc(..)) - -import Swish.Utils.LookupMap - ( LookupEntryClass(..) - , LookupMap, emptyLookupMap, reverseLookupMap - , listLookupMap - , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge - ) - -import Swish.Utils.Namespace (ScopedName, getScopeLocal, getScopeURI) - -import Data.Char (isDigit) - -import Data.List (foldl', delete, groupBy, partition, sort, intersperse) - -import Data.Monoid (Monoid(..)) -import Control.Monad (liftM, when) -import Control.Monad.State (State, modify, get, put, runState) - --- it strikes me that using Lazy Text here is likely to be --- wrong; however I have done no profiling to back this --- assumption up! - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B - --- temporary conversion -quoteB :: Bool -> String -> B.Builder -quoteB f v = B.fromString $ quote f v - ----------------------------------------------------------------------- --- Graph formatting state monad ----------------------------------------------------------------------- --- --- The graph to be formatted is carried as part of the formatting --- state, so that decisions about what needs to be formatted can --- themselves be based upon and reflected in the state (e.g. if a --- decision is made to include a blank node inline, it can be removed --- from the graph state that remains to be formatted). - -type SubjTree lb = [(lb,PredTree lb)] -type PredTree lb = [(lb,[lb])] - -data N3FormatterState = N3FS - { indent :: B.Builder - , lineBreak :: Bool - , graph :: RDFGraph - , subjs :: SubjTree RDFLabel - , props :: PredTree RDFLabel -- for last subject selected - , objs :: [RDFLabel] -- for last property selected - , formAvail :: FormulaMap RDFLabel - , formQueue :: [(RDFLabel,RDFGraph)] - , nodeGenSt :: NodeGenState - , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format - , traceBuf :: [String] - } - -type Formatter a = State N3FormatterState a - -emptyN3FS :: NodeGenState -> N3FormatterState -emptyN3FS ngs = N3FS - { indent = "\n" - , lineBreak = False - , graph = emptyRDFGraph - , subjs = [] - , props = [] - , objs = [] - , formAvail = emptyFormulaMap - , formQueue = [] - , nodeGenSt = ngs - , bNodesCheck = [] - , traceBuf = [] - } - --- | Node name generation state information that carries through --- and is updated by nested formulae -type NodeGenLookupMap = LookupMap (RDFLabel,Int) - -data NodeGenState = Ngs - { prefixes :: NamespaceMap - , nodeMap :: NodeGenLookupMap - , nodeGen :: Int - } - -emptyNgs :: NodeGenState -emptyNgs = Ngs - { prefixes = emptyLookupMap - , nodeMap = emptyLookupMap - , nodeGen = 0 - } - --- simple context for label creation --- (may be a temporary solution to the problem --- of label creation) --- -data LabelContext = SubjContext | PredContext | ObjContext - deriving (Eq, Show) - -getIndent :: Formatter B.Builder -getIndent = indent `liftM` get - -setIndent :: B.Builder -> Formatter () -setIndent ind = modify $ \st -> st { indent = ind } - -getLineBreak :: Formatter Bool -getLineBreak = lineBreak `liftM` get - -setLineBreak :: Bool -> Formatter () -setLineBreak brk = modify $ \st -> st { lineBreak = brk } - -getNgs :: Formatter NodeGenState -getNgs = nodeGenSt `liftM` get - -setNgs :: NodeGenState -> Formatter () -setNgs ngs = modify $ \st -> st { nodeGenSt = ngs } - -getPrefixes :: Formatter NamespaceMap -getPrefixes = prefixes `liftM` getNgs - -getSubjs :: Formatter (SubjTree RDFLabel) -getSubjs = subjs `liftM` get - -setSubjs :: SubjTree RDFLabel -> Formatter () -setSubjs sl = modify $ \st -> st { subjs = sl } - -getProps :: Formatter (PredTree RDFLabel) -getProps = props `liftM` get - -setProps :: PredTree RDFLabel -> Formatter () -setProps ps = modify $ \st -> st { props = ps } - -{- -getObjs :: Formatter ([RDFLabel]) -getObjs = objs `liftM` get - -setObjs :: [RDFLabel] -> Formatter () -setObjs os = do - st <- get - put $ st { objs = os } --} - -getBnodesCheck :: Formatter [RDFLabel] -getBnodesCheck = bNodesCheck `liftM` get - -{- -addTrace :: String -> Formatter () -addTrace tr = do - st <- get - put $ st { traceBuf = tr : traceBuf st } --} - -queueFormula :: RDFLabel -> Formatter () -queueFormula fn = do - st <- get - let fa = formAvail st - newState fv = st { - formAvail = mapDelete fa fn, - formQueue = (fn,fv) : formQueue st - } - case mapFindMaybe fn fa of - Nothing -> return () - Just v -> put (newState v) >> return () - -{- -Return the graph associated with the label and delete it -from the store, if there is an association, otherwise -return Nothing. --} -extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) -extractFormula fn = do - st <- get - let fa = formAvail st - newState = st { formAvail=mapDelete fa fn } - case mapFindMaybe fn fa of - Nothing -> return Nothing - Just fv -> put newState >> return (Just fv) - -{- -moreFormulae :: Formatter Bool -moreFormulae = do - st <- get - return $ not $ null (formQueue st) - -nextFormula :: Formatter (RDFLabel,RDFGraph) -nextFormula = do - st <- get - let (nf : fq) = formQueue st - put $ st { formQueue = fq } - return nf - --} - --- list has a length of 1 -len1 :: [a] -> Bool -len1 (_:[]) = True -len1 _ = False - -{-| -Given a set of statements and a label, return the details of the -RDF collection referred to by label, or Nothing. - -For label to be considered as representing a collection we require the -following conditions to hold (this is only to support the -serialisation using the '(..)' syntax and does not make any statement -about semantics of the statements with regard to RDF Collections): - - - there must be one rdf_first and one rdfRest statement - - there must be no other predicates for the label - --} -getCollection :: - SubjTree RDFLabel -- ^ statements organized by subject - -> RDFLabel -- ^ does this label represent a list? - -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) - -- ^ the statements with the elements removed; the - -- content elements of the collection (the objects of the rdf:first - -- predicate) and the nodes that represent the spine of the - -- collection (in reverse order, unlike the actual contents which are in - -- order). -getCollection subjList lbl = go subjList lbl ([],[]) - where - go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) - | otherwise = do - (pList1, sl') <- removeItem sl l - (pFirst, pList2) <- removeItem pList1 resRdfFirst - (pNext, pList3) <- removeItem pList2 resRdfRest - - -- QUS: could I include these checks implicitly in the pattern matches above? - -- ie instrad of (pFirst, pos1) <- .. - -- have ([content], pos1) <- ... - -- ? - if and [len1 pFirst, len1 pNext, null pList3] - then go sl' (head pNext) (head pFirst : cs, l : ss) - else Nothing - -{- -TODO: - -Should we change the preds/objs entries as well? - --} -extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) -extractList lctxt ln = do - osubjs <- getSubjs - oprops <- getProps - let mlst = getCollection osubjs' ln - - -- we only want to send in rdf:first/rdf:rest here - fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops - - osubjs' = - case lctxt of - SubjContext -> (ln, fprops) : osubjs - _ -> osubjs - - -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" - -- addTrace tr - case mlst of - -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext - Just (sl,ls,_) -> do - setSubjs sl - when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops - return (Just ls) - - Nothing -> return Nothing - -{-| -Removes the first occurrence of the item from the -association list, returning it's contents and the rest -of the list, if it exists. --} -removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) -removeItem os x = - let (as, bs) = break (\a -> fst a == x) os - in case bs of - ((_,b):bbs) -> Just (b, as ++ bbs) - [] -> Nothing - ----------------------------------------------------------------------- --- Define a top-level formatter function: ----------------------------------------------------------------------- - -formatGraphAsText :: RDFGraph -> T.Text -formatGraphAsText = L.toStrict . formatGraphAsLazyText - -formatGraphAsLazyText :: RDFGraph -> L.Text -formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder - -formatGraphAsBuilder :: RDFGraph -> B.Builder -formatGraphAsBuilder = formatGraphIndent "\n" True - -formatGraphIndent :: B.Builder -> Bool -> RDFGraph -> B.Builder -formatGraphIndent indnt flag gr = - let (res, _, _, _) = formatGraphDiag indnt flag gr - in res - --- | Format graph and return additional information -formatGraphDiag :: - B.Builder -- ^ indentation - -> Bool -- ^ are prefixes to be generated? - -> RDFGraph - -> (B.Builder, NodeGenLookupMap, Int, [String]) -formatGraphDiag indnt flag gr = - let fg = formatGraph indnt " .\n" False flag gr - ngs = emptyNgs { - prefixes = emptyLookupMap, - nodeGen = findMaxBnode gr - } - - (out, fgs) = runState fg (emptyN3FS ngs) - ogs = nodeGenSt fgs - - in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs) - ----------------------------------------------------------------------- --- Formatting as a monad-based computation ----------------------------------------------------------------------- - -formatGraph :: - B.Builder -- indentation string - -> B.Builder -- text to be placed after final statement - -> Bool -- True if a line break is to be inserted at the start - -> Bool -- True if prefix strings are to be generated - -> RDFGraph -- graph to convert - -> Formatter B.Builder -formatGraph ind end dobreak dopref gr = do - setIndent ind - setLineBreak dobreak - setGraph gr - - fp <- if dopref - then formatPrefixes (getNamespaces gr) - else return mempty - more <- moreSubjects - if more - then do - fr <- formatSubjects - return $ mconcat [fp, fr, end] - else return fp - -formatPrefixes :: NamespaceMap -> Formatter B.Builder -formatPrefixes pmap = do - let mls = map (pref . keyVal) (listLookupMap pmap) - ls <- sequence mls - return $ mconcat ls - where - pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."] - pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."] - -{- -NOTE: -I expect there to be confusion below where I need to -convert from Text to Builder --} - -formatSubjects :: Formatter B.Builder -formatSubjects = do - sb <- nextSubject - sbstr <- formatLabel SubjContext sb - - flagP <- moreProperties - if flagP - then do - prstr <- formatProperties sb sbstr - flagS <- moreSubjects - if flagS - then do - fr <- formatSubjects - return $ mconcat [prstr, " .", fr] - else return prstr - - else do - txt <- nextLine sbstr - - flagS <- moreSubjects - if flagS - then do - fr <- formatSubjects - return $ mconcat [txt, " .", fr] - else return txt - -{- -TODO: now we are throwing a Builder around it is awkward to -get the length of the text to calculate the indentation - -So - - a) change the indentation scheme - b) pass around text instead of builder - -mkIndent :: L.Text -> L.Text -mkIndent inVal = L.replicate (L.length inVal) " " --} - -hackIndent :: B.Builder -hackIndent = " " - -formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder -formatProperties sb sbstr = do - pr <- nextProperty sb - prstr <- formatLabel PredContext pr - obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] - more <- moreProperties - let sbindent = hackIndent -- mkIndent sbstr - if more - then do - fr <- formatProperties sb sbindent - nl <- nextLine $ obstr `mappend` " ;" - return $ nl `mappend` fr - else nextLine obstr - -formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder -formatObjects sb pr prstr = do - ob <- nextObject sb pr - obstr <- formatLabel ObjContext ob - more <- moreObjects - if more - then do - let prindent = hackIndent -- mkIndent prstr - fr <- formatObjects sb pr prindent - nl <- nextLine $ mconcat [prstr, " ", obstr, ","] - return $ nl `mappend` fr - else return $ mconcat [prstr, " ", obstr] - -insertFormula :: RDFGraph -> Formatter B.Builder -insertFormula gr = do - ngs0 <- getNgs - ind <- getIndent - let grm = formatGraph (ind `mappend` " ") "" True False - (setNamespaces emptyNamespaceMap gr) - - (f3str, fgs') = runState grm (emptyN3FS ngs0) - - setNgs (nodeGenSt fgs') - f4str <- nextLine " } " - return $ mconcat [" { ",f3str, f4str] - -{- -Add a list inline. We are given the labels that constitute -the list, in order, so just need to display them surrounded -by (). --} -insertList :: [RDFLabel] -> Formatter B.Builder -insertList [] = return "()" -- not convinced this can happen -insertList xs = do - ls <- mapM (formatLabel ObjContext) xs - return $ mconcat ("( " : intersperse " " ls) `mappend` " )" - -{- -Add a blank node inline. --} - -insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder -insertBnode SubjContext lbl = do - flag <- moreProperties - txt <- if flag - then (`mappend` "\n") `liftM` formatProperties lbl "" - else return "" - - -- TODO: handle indentation? - return $ mconcat ["[", txt, "]"] - -insertBnode _ lbl = do - ost <- get - let osubjs = subjs ost - oprops = props ost - oobjs = objs ost - - (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs - - rprops = case bsubj of - [(_,rs)] -> rs - _ -> [] - - -- we essentially want to create a new subgraph - -- for this node but it's not as simple as that since - -- we could have something like - -- :a :b [ :foo [ :bar "xx" ] ] - -- so we still need to carry around the whole graph - -- - nst = ost { subjs = rsubjs, - props = rprops, - objs = [] - } - - put nst - flag <- moreProperties - txt <- if flag - then (`mappend` "\n") `liftM` formatProperties lbl "" - else return "" - - -- TODO: how do we restore the original set up? - -- I can't believe the following is sufficient - -- - nst' <- get - let slist = map fst $ subjs nst' - nsubjs = filter (\(l,_) -> l `elem` slist) osubjs - - put $ nst' { subjs = nsubjs, - props = oprops, - objs = oobjs - } - - -- TODO: handle indentation? - return $ mconcat ["[", txt, "]"] - ----------------------------------------------------------------------- --- Formatting helpers ----------------------------------------------------------------------- - -setGraph :: RDFGraph -> Formatter () -setGraph gr = do - st <- get - - let ngs0 = nodeGenSt st - pre' = mapMerge (prefixes ngs0) (getNamespaces gr) - ngs' = ngs0 { prefixes = pre' } - arcs = sortArcs $ getArcs gr - nst = st { graph = gr - , subjs = arcTree arcs - , props = [] - , objs = [] - , formAvail = getFormulae gr - , nodeGenSt = ngs' - , bNodesCheck = countBnodes arcs - } - - put nst - -hasMore :: (N3FormatterState -> [b]) -> Formatter Bool -hasMore lens = (not . null . lens) `liftM` get - -moreSubjects :: Formatter Bool -moreSubjects = hasMore subjs --- moreSubjects = (not . null . subjs) `liftM` get - -moreProperties :: Formatter Bool -moreProperties = hasMore props --- moreProperties = (not . null . props) `liftM` get - -moreObjects :: Formatter Bool -moreObjects = hasMore objs --- moreObjects = (not . null . objs) `liftM` get - -nextSubject :: Formatter RDFLabel -nextSubject = do - st <- get - - let sb:sbs = subjs st - nst = st { subjs = sbs - , props = snd sb - , objs = [] - } - - put nst - return $ fst sb - -nextProperty :: RDFLabel -> Formatter RDFLabel -nextProperty _ = do - st <- get - - let pr:prs = props st - nst = st { props = prs - , objs = snd pr - } - - put nst - return $ fst pr - -nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel -nextObject _ _ = do - st <- get - - let ob:obs = objs st - nst = st { objs = obs } - - put nst - return ob - -nextLine :: B.Builder -> Formatter B.Builder -nextLine str = do - ind <- getIndent - brk <- getLineBreak - if brk - then return $ ind `mappend` str - else do - -- After first line, always insert line break - setLineBreak True - return str - --- Format a label --- Most labels are simply displayed as provided, but there are a --- number of wrinkles to take care of here: --- (a) blank nodes automatically allocated on input, with node --- identifiers of the form of a digit string nnn. These are --- not syntactically valid, and are reassigned node identifiers --- of the form _nnn, where nnn is chosen so that is does not --- clash with any other identifier in the graph. --- (b) URI nodes: if possible, replace URI with qname, --- else display as --- (c) formula nodes (containing graphs). --- (d) use the "special-case" formats for integer/float/double --- literals. --- --- [[[TODO:]]] --- (d) generate multi-line literals when appropriate --- --- This is being updated to produce inline formula, lists and --- blank nodes. The code is not efficient. --- - -specialTable :: [(ScopedName, String)] -specialTable = - [ (rdfType, "a") - , (owlSameAs, "=") - , (logImplies, "=>") - , (rdfNil, "()") - ] - -formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder -{- -formatLabel lab@(Blank (_:_)) = do - name <- formatNodeId lab - queueFormula lab - return name --} - -{- -The "[..]" conversion is done last, after "()" and "{}" checks. --} -formatLabel lctxt lab@(Blank (_:_)) = do - mlst <- extractList lctxt lab - case mlst of - Just lst -> insertList lst - Nothing -> do - mfml <- extractFormula lab - case mfml of - Just fml -> insertFormula fml - Nothing -> do - nb1 <- getBnodesCheck - if lctxt /= PredContext && lab `notElem` nb1 - then insertBnode lctxt lab - else formatNodeId lab - -formatLabel _ lab@(Res sn) = - case lookup sn specialTable of - Just txt -> return $ quoteB True txt -- TODO: do we need to quote? - Nothing -> do - pr <- getPrefixes - let nsuri = getScopeURI sn - local = getScopeLocal sn - premap = reverseLookupMap pr :: RevNamespaceMap - prefix = mapFindMaybe nsuri premap - - name = case prefix of - Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames - _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] - - {- - name = case prefix of - Just p -> quoteB True (p ++ ":" ++ local) -- TODO: what are quoting rules for QNames - _ -> mconcat ["<", quoteB True (nsuri++local), ">"] - -} - - queueFormula lab - return name - --- The canonical notation for xsd:double in XSD, with an upper-case E, --- does not match the syntax used in N3, so we need to convert here. --- Rather than converting back to a Double and then displaying that --- we just convert E to e for now. --- -formatLabel _ (Lit lit (Just dtype)) - | dtype == xsdDouble = return $ B.fromText $ T.toLower lit - | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit - | otherwise = return $ quoteText lit `mappend` formatAnnotation dtype -formatLabel _ (Lit lit Nothing) = return $ quoteText lit - -formatLabel _ lab = return $ B.fromString $ show lab - --- the annotation for a literal (ie type or language) -formatAnnotation :: ScopedName -> B.Builder -formatAnnotation a | isLang a = "@" `mappend` B.fromText (langTag a) - | otherwise = "^^" `mappend` showScopedName a - -{- -We have to decide whether to use " or """ to quote -the string. - -There is also no need to restrict the string to the -ASCII character set; this could be an option but we -can also leave Unicode as is (or at least convert to UTF-8). - -If we use """ to surround the string then we protect the -last character if it is a " (assuming it isn't protected). --} - -quoteText :: T.Text -> B.Builder -quoteText txt = - let st = T.unpack txt -- TODO: fix - qst = quoteB (n==1) st - n = if '\n' `elem` st || '"' `elem` st then 3 else 1 - qch = B.fromString (replicate n '"') - in mconcat [qch, qst, qch] - -formatNodeId :: RDFLabel -> Formatter B.Builder -formatNodeId lab@(Blank (lnc:_)) = - if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab -formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall - -mapBlankNode :: RDFLabel -> Formatter B.Builder -mapBlankNode lab = do - ngs <- getNgs - let cmap = nodeMap ngs - cval = nodeGen ngs - nv <- case mapFind 0 lab cmap of - 0 -> do - let nval = succ cval - nmap = mapAdd cmap (lab, nval) - setNgs $ ngs { nodeGen = nval, nodeMap = nmap } - return nval - - n -> return n - - -- TODO: is this what we want? - return $ "_:swish" `mappend` B.fromString (show nv) - --- TODO: need to be a bit more clever with this than we did in NTriples --- not sure the following counts as clever enough ... --- -showScopedName :: ScopedName -> B.Builder -{- -showScopedName (ScopedName n l) = - let uri = nsURI n ++ l - in quote uri --} -showScopedName = quoteB True . show - ----------------------------------------------------------------------- --- Graph-related helper functions ----------------------------------------------------------------------- - -newtype SortedArcs lb = SA [Arc lb] - -sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb -sortArcs = SA . sort - --- Rearrange a list of arcs into a tree of pairs which group together --- all statements for a single subject, and similarly for multiple --- objects of a common predicate. --- -arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb -arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as - where - spopair (Arc s p o) = (s,(p,o)) - -{- -arcTree as = map spopair $ sort as - where - spopair (Arc s p o) = (s,[(p,[o])]) --} - --- Rearrange a list of pairs so that multiple occurrences of the first --- are commoned up, and the supplied function is applied to each sublist --- with common first elements to obtain the corresponding second value -commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] -commonFstEq f ps = - [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] - where - fstEq (f1,_) (f2,_) = f1 == f2 - -{- --- Diagnostic code for checking arcTree logic: -testArcTree = (arcTree testArcTree1) == testArcTree2 -testArcTree1 = - [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" - ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" - ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" - ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" - ] -testArcTree2 = - [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) - ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) - ] --} - - -findMaxBnode :: RDFGraph -> Int -findMaxBnode = maximum . map getAutoBnodeIndex . labels - -getAutoBnodeIndex :: RDFLabel -> Int -getAutoBnodeIndex (Blank ('_':lns)) = res where - -- cf. prelude definition of read s ... - res = case [x | (x,t) <- reads lns, ("","") <- lex t] of - [x] -> x - _ -> 0 -getAutoBnodeIndex _ = 0 - -{- -Find all blank nodes that occur - - any number of times as a subject - - 0 or 1 times as an object - -Such nodes can be output using the "[..]" syntax. To make it simpler -to check we actually store those nodes that can not be expanded. - -Note that we do not try and expand any bNode that is used in -a predicate position. - -Should probably be using the SubjTree RDFLabel structure but this -is easier for now. - --} - -countBnodes :: SortedArcs RDFLabel -> [RDFLabel] -countBnodes (SA as) = snd (foldl' ctr ([],[]) as) - where - -- first element of tuple are those blank nodes only seen once, - -- second element those blank nodes seen multiple times - -- - inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (l:b1s, bms) - inc b _ = b - - -- if the bNode appears as a predicate we instantly add it to the - -- list of nodes not to expand, even if only used once - incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (b1s, l:bms) - incP b _ = b - - ctr orig (Arc _ p o) = inc (incP orig p) o - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/N3Parser.hs b/src/Swish/RDF/N3Parser.hs deleted file mode 100644 --- a/src/Swish/RDF/N3Parser.hs +++ /dev/null @@ -1,1145 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -- only used in 'fromMaybe "" mbase' line of parseN3 - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3Parser --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This Module implements a Notation 3 parser (see [1], [2], [3]), returning a --- new 'RDFGraph' consisting of triples and namespace information parsed from --- the supplied N3 input string, or an error indication. --- --- REFERENCES: --- --- 1 --- Notation3 (N3): A readable RDF syntax, --- W3C Team Submission 14 January 2008 --- --- 2 --- Tim Berners-Lee's design issues series notes and description --- --- 3 --- Notation 3 Primer by Sean Palmer --- --- NOTES: --- --- UTF-8 handling is not really tested. --- --- No performance testing has been applied. --- --- Not all N3 grammar elements are supported, including: --- --- - @\@forSome@ (we read it in but ignore the arguments) --- --- - @\@forAll@ (this causes a parse error) --- --- - formulae are lightly tested --- --- - string support is incomplete (e.g. unrecognized escape characters --- such as @\\q@ are probably handled incorrectly) --- --------------------------------------------------------------------------------- - -module Swish.RDF.N3Parser - ( ParseResult - , parseN3 - , parseN3fromText - , parseAnyfromText - , parseTextFromText, parseAltFromText - , parseNameFromText -- , parsePrefixFromText - , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText - - -- * Exports for parsers that embed Notation3 in a bigger syntax - , N3Parser, N3State(..), SpecialMap - - , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions - , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct - , quickVariable -- was varid - , lexUriRef - , document, subgraph - , newBlankNode - ) -where - -import Swish.RDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , ToRDFLabel(..) - , NamespaceMap - , LookupFormula(..) - , addArc - , setFormula - , setNamespaces - , emptyRDFGraph - ) - -import Swish.RDF.GraphClass (arc) - -import Swish.Utils.LookupMap - ( LookupMap(..) - , LookupEntryClass(..) - , mapFind, mapFindMaybe, mapReplaceOrAdd, mapAdd, mapReplace ) - -import Swish.Utils.Namespace - ( Namespace, makeNamespace - , ScopedName - , getScopeNamespace - , getScopedNameURI - , getScopeNamespace - , makeURIScopedName - , makeQNameScopedName - , makeNSScopedName - , nullScopedName - ) - -import Swish.Utils.QName (QName) - -import Swish.RDF.Vocabulary - ( langName - , rdfType - , rdfFirst, rdfRest, rdfNil - , owlSameAs, logImplies - , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble - ) - -import Swish.RDF.RDFParser - ( SpecialMap - , ParseResult - , runParserWithError - -- , mapPrefix - , prefixTable - , specialTable - , ignore - , notFollowedBy - , endBy - , sepEndBy - , manyTill - , noneOf - , char - , ichar - , string - , stringT - , symbol - , lexeme - , whiteSpace - , mkTypedLit - , hex4 - , hex8 - , appendURIs - ) - -import Control.Applicative -import Control.Monad (forM_, foldM) - -import Network.URI (URI(..), parseURIReference) - -import Data.Char (isSpace, isDigit, ord) -import Data.Maybe (fromMaybe, fromJust) - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import Text.ParserCombinators.Poly.StateText - ----------------------------------------------------------------------- --- Define parser state and helper functions ----------------------------------------------------------------------- - --- | N3 parser state -data N3State = N3State - { graphState :: RDFGraph -- Graph under construction - , thisNode :: RDFLabel -- current context node (aka 'this') - , prefixUris :: NamespaceMap -- namespace prefix mapping table - , syntaxUris :: SpecialMap -- special name mapping table - , nodeGen :: Int -- blank node id generator - , keywordsList :: [T.Text] -- contents of the @keywords statement - , allowLocalNames :: Bool -- True if @keywords used so that bare names are QNames in default namespace - } - --- | Functions to update N3State vector (use with stUpdate) - -setPrefix :: Maybe T.Text -> URI -> N3State -> N3State -setPrefix pre uri st = st { prefixUris=p' } - where - p' = mapReplaceOrAdd (makeNamespace pre uri) (prefixUris st) - --- | Set name for special syntax element -setSName :: String -> ScopedName -> N3State -> N3State -setSName nam snam st = st { syntaxUris=s' } - where - s' = mapReplaceOrAdd (nam,snam) (syntaxUris st) - -setSUri :: String -> URI -> N3State -> N3State -setSUri nam = setSName nam . makeURIScopedName - --- | Set the list of tokens that can be used without needing the leading --- \@ symbol. -setKeywordsList :: [T.Text] -> N3State -> N3State -setKeywordsList ks st = st { keywordsList = ks, allowLocalNames = True } - --- Functions to access state: - --- | Get name for special syntax element, default null -getSName :: N3State -> String -> ScopedName -getSName st nam = mapFind nullScopedName nam (syntaxUris st) - -getSUri :: N3State -> String -> URI -getSUri st nam = getScopedNameURI $ getSName st nam - --- Map prefix to URI -getPrefixURI :: N3State -> Maybe T.Text -> Maybe URI -getPrefixURI st pre = mapFindMaybe pre (prefixUris st) - -getKeywordsList :: N3State -> [T.Text] -getKeywordsList = keywordsList - -getAllowLocalNames :: N3State -> Bool -getAllowLocalNames = allowLocalNames - --- Return function to update graph in N3 parser state, --- using the supplied function of a graph --- -updateGraph :: (RDFGraph -> RDFGraph) -> N3State -> N3State -updateGraph f s = s { graphState = f (graphState s) } - ----------------------------------------------------------------------- --- Define top-level parser function: --- accepts a string and returns a graph or error ----------------------------------------------------------------------- - -type N3Parser a = Parser N3State a - --- | Parse a string as N3 (with no real base URI). --- --- See 'parseN3' if you need to provide a base URI. --- -parseN3fromText :: - L.Text -- ^ input in N3 format. - -> ParseResult -parseN3fromText = flip parseN3 Nothing - --- | Parse a string with an optional base URI. --- --- See also 'parseN3fromString'. --- -parseN3 :: - L.Text -- ^ input in N3 format. - -> Maybe QName -- ^ optional base URI - -> ParseResult -parseN3 txt mbase = parseAnyfromText document mbase txt - -{- --- useful for testing -test :: String -> RDFGraph -test = either error id . parseAnyfromString document Nothing --} - -hashURI :: URI -hashURI = fromJust $ parseURIReference "#" - -emptyState :: - Maybe QName -- ^ starting base for the graph - -> N3State -emptyState mbase = - let pmap = LookupMap [makeNamespace Nothing hashURI] - muri = fmap (makeQNameScopedName Nothing) mbase - smap = LookupMap $ specialTable muri - in N3State - { graphState = emptyRDFGraph - , thisNode = NoNode - , prefixUris = pmap - , syntaxUris = smap - , nodeGen = 0 - , keywordsList = ["a", "is", "of", "true", "false"] -- not 100% sure about true/false here - , allowLocalNames = False - } - - --- TODO: change from QName to URI for the base? - --- | Function to supply initial context and parse supplied term. --- -parseAnyfromText :: N3Parser a -- ^ parser to apply - -> Maybe QName -- ^ base URI of the input, or @Nothing@ to use default base value - -> L.Text -- ^ input to be parsed - -> Either String a -parseAnyfromText parser mbase = runParserWithError parser (emptyState mbase) - -newBlankNode :: N3Parser RDFLabel -newBlankNode = do - n <- stQuery (succ . nodeGen) - stUpdate $ \s -> s { nodeGen = n } - return $ Blank (show n) - --- Test functions for selected element parsing - --- TODO: remove these - -parseTextFromText :: String -> L.Text -> Either String String -parseTextFromText s = - parseAnyfromText (string s) Nothing - -parseAltFromText :: String -> String -> L.Text -> Either String String -parseAltFromText s1 s2 = - parseAnyfromText (string s1 <|> string s2) Nothing - -parseNameFromText :: L.Text -> Either String String -parseNameFromText = - parseAnyfromText n3NameStr Nothing - -{- -This has been made tricky by the attempt to remove the default list -of prefixes from the starting point of a N3 parse and the subsequent -attempt to add every new namespace we come across to the parser state. - -So we add in the original default namespaces for testing, since -this routine is really for testing. --} - -addTestPrefixes :: N3Parser () -addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map - -{- -parsePrefixFromText :: L.Text -> Either String URI -parsePrefixFromText = - parseAnyfromText p Nothing - where - p = do - addTestPrefixes - pref <- n3Name - st <- stGet - case getPrefixURI st (Just pref) of - Just uri -> return uri - _ -> fail $ "Undefined prefix: '" ++ pref ++ "'" --} - -parseAbsURIrefFromText :: L.Text -> Either String URI -parseAbsURIrefFromText = - parseAnyfromText explicitURI Nothing - -parseLexURIrefFromText :: L.Text -> Either String URI -parseLexURIrefFromText = - parseAnyfromText lexUriRef Nothing - -parseURIref2FromText :: L.Text -> Either String ScopedName -parseURIref2FromText = - parseAnyfromText (addTestPrefixes *> n3symbol) Nothing - ----------------------------------------------------------------------- --- Syntax productions ----------------------------------------------------------------------- - --- helper routines - -comma, semiColon , fullStop :: N3Parser () -comma = ignore $ symbol "," -semiColon = ignore $ symbol ";" -fullStop = ignore $ symbol "." - --- a specialization of bracket/between -br :: String -> String -> N3Parser a -> N3Parser a -br lsym rsym = bracket (symbol lsym) (symbol rsym) - --- to make porting from parsec to polyparse easier -between :: Parser s lbr -> Parser s rbr -> Parser s a -> Parser s a -between = bracket - --- The @ character is optional if the keyword is in the --- keyword list --- -atSign :: T.Text -> N3Parser () -atSign s = do - st <- stGet - - let p = ichar '@' - - if s `elem` getKeywordsList st - then ignore $ optional p - else p - -atWord :: T.Text -> N3Parser T.Text -atWord s = do - atSign s - - -- TODO: does it really make sense to add the not-followed-by-a-colon rule here? - -- apply to both cases even though should only really be necessary - -- when the at sign is not given - -- - lexeme $ stringT s *> notFollowedBy (== ':') - return s - -{- -Since operatorLabel can be used to add a label with an -unknown namespace, we need to ensure that the namespace -is added if not known. If the namespace prefix is already -in use then it is over-written (rather than add a new -prefix for the label). - -TODO: - - could we use the reverse lookupmap functionality to - find if the given namespace URI is in the namespace - list? If it is, use it's key otherwise do a - mapReplaceOrAdd for the input namespace. - --} -operatorLabel :: ScopedName -> N3Parser RDFLabel -operatorLabel snam = do - st <- stGet - let sns = getScopeNamespace snam - opmap = prefixUris st - pkey = entryKey sns - pval = entryVal sns - - rval = Res snam - - -- the lookup and the replacement could be fused - case mapFindMaybe pkey opmap of - Just val | val == pval -> return rval - | otherwise -> do - stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } - return rval - - _ -> do - stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } - return rval - -{- -Add statement to graph in N3 parser state. - -To support literals that are written directly/implicitly - i.e. as -true/false/1/1.0/1.0e23 - rather than a string with an explicit -datatype we need to special case handling of the object label for -literals. Is this actually needed? The N3 Formatter now doesn't -display the xsd: datatypes on output, but there may be issues with -other formats (e.g RDF/XML once it is supported). - --} - -type AddStatement = RDFLabel -> N3Parser () - -addStatement :: RDFLabel -> RDFLabel -> AddStatement -addStatement s p o@(Lit _ (Just dtype)) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do - ost <- stGet - let stmt = arc s p o - oldp = prefixUris ost - ogs = graphState ost - newp = mapReplaceOrAdd (getScopeNamespace dtype) oldp - stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } -addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) - -addStatementRev :: RDFLabel -> RDFLabel -> AddStatement -addStatementRev o p s = addStatement s p o - -{- -A number of productions require a name, which starts with - -[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff] - -and then has - -[\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* - -we encode this as the n3Name production --} - -isaz, is09, isaz09 :: Char -> Bool -isaz c = c >= 'a' && c <= 'z' -is09 c = c >= '0' && c <= '9' -isaz09 c = isaz c || is09 c - -match :: (Ord a) => a -> [(a,a)] -> Bool -match v = any (\(l,h) -> v >= l && v <= h) - -startChar :: Char -> Bool -startChar c = let i = ord c - in c == '_' || - match c [('A', 'Z'), ('a', 'z')] || - match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x02ff), - (0x0370, 0x037d), - (0x037f, 0x1fff), (0x200c, 0x200d), - (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), - (0xf900, 0xfdcf), (0xfdf0, 0xfffd), - (0x00010000, 0x000effff)] - -inBody :: Char -> Bool -inBody c = let i = ord c - in c `elem` "-_" || i == 0x007 || - match c [('0', '9'), ('A', 'Z'), ('a', 'z')] || - match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x037d), - (0x037f, 0x1fff), (0x200c, 0x200d), (0x203f, 0x2040), - (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), - (0xf900, 0xfdcf), (0xfdf0, 0xfffd), - (0x00010000, 0x000effff)] - --- should this be strict or lazy text? -n3Name :: N3Parser T.Text -n3Name = T.cons <$> n3Init <*> n3Body - where - n3Init = satisfy startChar - n3Body = L.toStrict <$> manySatisfy inBody - - -n3NameStr :: N3Parser String -n3NameStr = T.unpack <$> n3Name - -{- -quickvariable ::= \?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* --} - --- TODO: is mapping to Var correct? -quickVariable :: N3Parser RDFLabel -quickVariable = char '?' *> (Var <$> n3NameStr) - -{- -string ::= ("""[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""")|("[^"\\]*(?:\\.[^"\\]*)*") - -or - -string ::= tripleQuoted | singleQUoted - --} - -n3string :: N3Parser T.Text -n3string = tripleQuoted <|> singleQuoted - -{- -singleQuoted ::= "[^"\\]*(?:\\.[^"\\]*)*" - -asciiChars :: String -asciiChars = map chr [0x20..0x7e] - -asciiCharsN3 :: String -asciiCharsN3 = filter (`notElem` "\\\"") asciiChars - --} - -digit :: N3Parser Char -digit = satisfy isDigit - -{- -This is very similar to NTriples accept that also allow the escaping of ' -even though it is not required. - -The Python rules allow \N{name}, where name is the Unicode name. It's -not clear whether we need to support this too, so for now we do not. - --} -protectedChar :: N3Parser Char -protectedChar = - (char 't' *> return '\t') - <|> (char 'n' *> return '\n') - <|> (char 'r' *> return '\r') - <|> (char '"' *> return '"') - <|> (char '\'' *> return '\'') - <|> (char '\\' *> return '\\') - <|> (char 'u' *> hex4) - <|> (char 'U' *> hex8) - --- Accept an escape character or any character as long as it isn't --- a new-line or quote. Unrecognized escape sequences should therefore --- be left alone by this. --- -n3Character :: N3Parser Char -n3Character = - (char '\\' *> (protectedChar <|> return '\\')) - <|> noneOf "\"\n" - -{- - <|> (oneOf asciiCharsN3 "ASCII character") - -- TODO: bodyChar and asciiCharsN3 overlap - <|> (oneOf bodyChar "Unicode character") --} - -sQuot :: N3Parser Char -sQuot = char '"' - -{- -TODO: there must be a better way of building up the Text --} - -singleQuoted :: N3Parser T.Text -singleQuoted = fmap T.pack (bracket sQuot sQuot $ many n3Character) - -{- -tripleQUoted ::= """[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""" --} -tripleQuoted :: N3Parser T.Text -tripleQuoted = tQuot *> fmap T.pack (manyTill (n3Character <|> sQuot <|> char '\n') tQuot) - where - -- tQuot = try (count 3 sQuot) - tQuot = exactly 3 sQuot - -getDefaultPrefix :: N3Parser Namespace -getDefaultPrefix = do - s <- stGet - case getPrefixURI s Nothing of - Just uri -> return $ makeNamespace Nothing uri - _ -> fail "No default prefix defined; how unexpected!" - -addBase :: URI -> N3Parser () -addBase = stUpdate . setSUri "base" - -addPrefix :: Maybe T.Text -> URI -> N3Parser () -addPrefix p = stUpdate . setPrefix p - -{-| -Update the set of keywords that can be given without -an \@ sign. --} -updateKeywordsList :: [T.Text] -> N3Parser () -updateKeywordsList = stUpdate . setKeywordsList - -{- -document ::= | statements_optional EOF --} - -document :: N3Parser RDFGraph -document = mkGr <$> (whiteSpace *> statementsOptional *> eof *> stGet) - where - mkGr s = setNamespaces (prefixUris s) (graphState s) - -{- -statements_optional ::= | statement "." statements_optional - | void - --} - -statementsOptional :: N3Parser () -statementsOptional = ignore $ endBy (lexeme statement) fullStop - -{- -statement ::= | declaration - | existential - | simpleStatement - | universal - --} - -statement :: N3Parser () -statement = - declaration - <|> existential - <|> universal - <|> simpleStatement - -- having an error here leads to less informative errors in general, it seems - -- "statement (existential or universal quantification or a simple statement)" - -{- -declaration ::= | "@base" explicituri - | "@keywords" barename_csl - | "@prefix" prefix explicituri --} - --- TODO: do we need the try statements here? atWord would need to have a try on '@' --- (if applicable) which should mean being able to get rid of try --- -declaration :: N3Parser () -declaration = oneOf [ - atWord "base" >> explicitURI >>= addBase, - atWord "keywords" >> bareNameCsl >>= updateKeywordsList, - atWord "prefix" *> getPrefix - ] - - {- - (try (atWord "base") >> explicitURI >>= addBase) - <|> - (try (atWord "keywords") >> bareNameCsl >>= updateKeywordsList) - <|> - (try (atWord "prefix") *> getPrefix) - -} - -getPrefix :: N3Parser () -getPrefix = do - p <- lexeme prefix - u <- explicitURI - addPrefix p u - -{- -explicituri ::= <[^>]*> - -Note: white space is to be ignored within <> --} - -explicitURI :: N3Parser URI -explicitURI = do - let lb = char '<' - rb = char '>' - - -- TODO: do the whitespace definitions match? - ustr <- between lb rb $ many (satisfy (/= '>')) - let uclean = filter (not . isSpace) ustr - - case parseURIReference uclean of - Nothing -> fail $ "Unable to convert <" ++ uclean ++ "> to a URI" - Just uref -> do - s <- stGet - let base = getSUri s "base" - either fail return $ appendURIs base uref - --- production from the old parser; used in SwishScript -lexUriRef :: N3Parser URI -lexUriRef = lexeme explicitURI - -{- -barename ::= [A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* -barename_csl ::= | barename barename_csl_tail - | void -barename_csl_tail ::= | "," barename barename_csl_tail - | void --} - -bareNameCsl :: N3Parser [T.Text] -bareNameCsl = sepBy (lexeme bareName) comma - -bareName :: N3Parser T.Text -bareName = n3Name - -{- -prefix ::= ([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?: --} - -prefix :: N3Parser (Maybe T.Text) -prefix = optional (lexeme n3Name) <* char ':' - - -{- -symbol ::= | explicituri - | qname -symbol_csl ::= | symbol symbol_csl_tail - | void -symbol_csl_tail ::= | "," symbol symbol_csl_tail - | void - --} - -n3symbol :: N3Parser ScopedName -n3symbol = - (makeURIScopedName <$> explicitURI) - <|> qname - -symbolCsl :: N3Parser [ScopedName] -symbolCsl = sepBy (lexeme n3symbol) comma - -{- -qname ::= (([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?:)?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* - -TODO: - Note that, for now, we explicitly handle blank nodes - (of the form _:name) direcly in pathItem'. - This is not a good idea since qname' is used elsewhere - and so shouldn't we do the same thing there too? --} - -qname :: N3Parser ScopedName -qname = - fmap (uncurry makeNSScopedName) (char ':' >> g) - <|> (n3Name >>= fullOrLocalQName) - where - g = (,) <$> getDefaultPrefix <*> (n3Name <|> return "") - -fullOrLocalQName :: T.Text -> N3Parser ScopedName -fullOrLocalQName name = - (char ':' *> fullQName name) - <|> localQName name - -fullQName :: T.Text -> N3Parser ScopedName -fullQName name = makeNSScopedName <$> findPrefix name <*> (n3Name <|> pure "") - -findPrefix :: T.Text -> N3Parser Namespace -findPrefix pre = do - st <- stGet - case mapFindMaybe (Just pre) (prefixUris st) of - Just uri -> return $ makeNamespace (Just pre) uri - Nothing -> failBad $ "Prefix '" ++ T.unpack pre ++ ":' not bound." - -localQName :: T.Text -> N3Parser ScopedName -localQName name = do - st <- stGet - if getAllowLocalNames st - then let g = (,) <$> getDefaultPrefix <*> pure name - in uncurry makeNSScopedName <$> g - - else fail ("Invalid 'bare' word: " ++ T.unpack name)-- TODO: not ideal error message; can we handle this case differently? - -{- -existential ::= | "@forSome" symbol_csl - -For now we just read in the symbols and ignore them, -since we do not mark blank nodes as existentially quantified -(we assume this is the case). - -TODO: fix this? --} - -existential :: N3Parser () --- existential = try (atWord "forSome") *> symbolCsl >> return () -existential = atWord "forSome" *> symbolCsl *> pure () - -{- -simpleStatement ::= | subject propertylist --} - -simpleStatement :: N3Parser () -simpleStatement = subject >>= propertyListWith - -{- -subject ::= | expression --} - -subject :: N3Parser RDFLabel -subject = lexeme expression - -{- -expression ::= | pathitem pathtail -pathtail ::= | "!" expression - | "^" expression - | void - --} - -expression :: N3Parser RDFLabel -expression = do - i <- pathItem - - let backwardExpr = char '!' *> return addStatementRev - forwardExpr = char '^' *> return addStatement - - mpt <- optional - ( (,) <$> lexeme (forwardExpr <|> backwardExpr) <*> lexeme expression ) - case mpt of - Nothing -> return i - Just (addFunc, pt) -> do - bNode <- newBlankNode - addFunc bNode pt i - return bNode - -{- -pathitem ::= | "(" pathlist ")" - | "[" propertylist "]" - | "{" formulacontent "}" - | boolean - | literal - | numericliteral - | quickvariable - | symbol - -pathlist ::= | expression pathlist - | void - -Need to think about how to handle formulae, since need to know the context -of the call to know where to add them. - -TOOD: may include direct support for blank nodes here, -namely convert _:stringval -> Blank stringval since although -this should be done by symbol the types don't seem to easily match -up (at first blush anyway) --} - -pathItem :: N3Parser RDFLabel -pathItem = - br "(" ")" pathList - <|> br "[" "]" propertyListBNode - <|> br "{" "}" formulaContent - -- <|> try boolean - <|> boolean - <|> literal - <|> numericLiteral - <|> quickVariable - <|> Blank <$> (string "_:" *> n3NameStr) -- TODO a hack that needs fixing - <|> Res <$> n3symbol - -{- -we create a blank node for the list and return it, whilst -adding the list contents to the graph --} -pathList :: N3Parser RDFLabel -pathList = do - cts <- many (lexeme expression) - eNode <- operatorLabel rdfNil - case cts of - [] -> return eNode - - (c:cs) -> do - sNode <- newBlankNode - first <- operatorLabel rdfFirst - addStatement sNode first c - lNode <- foldM addElem sNode cs - rest <- operatorLabel rdfRest - addStatement lNode rest eNode - return sNode - - where - addElem prevNode curElem = do - bNode <- newBlankNode - first <- operatorLabel rdfFirst - rest <- operatorLabel rdfRest - addStatement prevNode rest bNode - addStatement bNode first curElem - return bNode - -{- -formulacontent ::= | statementlist - -statementlist ::= | statement statementtail - | void -statementtail ::= | "." statementlist - | void --} - -restoreState :: N3State -> N3Parser N3State -restoreState origState = do - oldState <- stGet - stUpdate $ \_ -> origState { nodeGen = nodeGen oldState } - return oldState - -{- -We create a subgraph and assign it to a blank node, returning the -blank node. At present it is a combination of the subgraph and formula -productions from the origial parser. - -TODO: is it correct? --} -formulaContent :: N3Parser RDFLabel -formulaContent = do - bNode <- newBlankNode - pstate <- stGet - stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = bNode } - statementList - oldState <- restoreState pstate - stUpdate $ updateGraph $ setFormula (Formula bNode (graphState oldState)) - return bNode - -subgraph :: RDFLabel -> N3Parser RDFGraph -subgraph this = do - pstate <- stGet - stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = this } - statementsOptional -- parse statements of formula - oldState <- restoreState pstate - return $ graphState oldState - -statementList :: N3Parser () -statementList = ignore $ sepEndBy (lexeme statement) fullStop - -{- -boolean ::= | "@false" - | "@true" --} - -boolean :: N3Parser RDFLabel -boolean = mkTypedLit xsdBoolean <$> - (atWord "false" <|> atWord "true") - -- (try (atWord "false") <|> atWord "true") - -{- -dtlang ::= | "@" langcode - | "^^" symbol - | void -literal ::= | string dtlang - -langcode ::= [a-z]+(-[a-z0-9]+)* - --} - -literal :: N3Parser RDFLabel -literal = Lit <$> n3string <*> optional dtlang - -dtlang :: N3Parser ScopedName -dtlang = - (char '@' *> langcode) - <|> string "^^" *> n3symbol - -- <|> (try (string "^^") *> n3symbol) - -langcode :: N3Parser ScopedName -langcode = do - h <- many1Satisfy isaz - mt <- optional ( L.append <$> (char '-' *> pure (L.singleton '-')) <*> many1Satisfy isaz09) - return $ langName $ L.toStrict $ L.append h (fromMaybe L.empty mt) - -{- -decimal ::= [-+]?[0-9]+(\.[0-9]+)? -double ::= [-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+) -integer ::= [-+]?[0-9]+ -numericliteral ::= | decimal - | double - | integer - -We actually support 1. for decimal values which isn't supported -by the above production. - -TODO: we could convert via something like - - maybeRead value :: Double >>= Just . toRDFLabel - -which would mean we store the canonical XSD value in the -label, but it is not useful for the xsd:decimal case -since we currently don't have a Haskell type that -goes with it. --} - -numericLiteral :: N3Parser RDFLabel -numericLiteral = - -- -- try (mkTypedLit xsdDouble <$> n3double) - -- try (d2s <$> n3double) - -- <|> try (mkTypedLit xsdDecimal <$> n3decimal) - d2s <$> n3double - <|> mkTypedLit xsdDecimal . T.pack <$> n3decimal - <|> mkTypedLit xsdInteger . T.pack <$> n3integer - -n3sign :: N3Parser Char -n3sign = char '+' <|> char '-' - -n3integer :: N3Parser String -n3integer = do - ms <- optional n3sign - ds <- many1 digit - case ms of - Just s -> return $ s : ds - _ -> return ds - -n3decimal :: N3Parser String --- n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many1 digit ) -n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many digit ) - -n3double :: N3Parser String -n3double = (++) <$> n3decimal <*> ( (:) <$> satisfy (`elem` "eE") <*> n3integer ) - --- Convert a double, as returned by n3double, into it's --- canonical XSD form. We assume that n3double returns --- a syntactivally valid Double, so do not bother with reads here --- -d2s :: String -> RDFLabel -d2s s = toRDFLabel (read s :: Double) - -{- -propertylist ::= | verb object objecttail propertylisttail - | void -propertylisttail ::= | ";" propertylist - | void - --} - --- it's probably important that bNode is created *after* --- processing the plist (mainly for the assumptions made by --- formatting the output as N3; e.g. list/sequence ordering) --- -propertyListBNode :: N3Parser RDFLabel -propertyListBNode = do - plist <- sepEndBy ((,) <$> lexeme verb <*> objectList) semiColon - bNode <- newBlankNode - let addList ((addFunc,vrb),items) = mapM_ (addFunc bNode vrb) items - forM_ plist addList - return bNode - -propertyListWith :: RDFLabel -> N3Parser () -propertyListWith subj = - let -- term = lexeme verb >>= objectListWith subj - term = lexeme verb >>= \(addFunc, vrb) -> objectListWith (addFunc subj vrb) - in ignore $ sepEndBy term semiColon - -{- -object ::= | expression -objecttail ::= | "," object objecttail - | void - -We change the production rule from objecttail to objectlist for lists of -objects (may change back). - --} - -object :: N3Parser RDFLabel -object = lexeme expression - -objectList :: N3Parser [RDFLabel] -objectList = sepBy1 object comma - -objectWith :: AddStatement -> N3Parser () -objectWith addFunc = object >>= addFunc - -objectListWith :: AddStatement -> N3Parser () -objectListWith addFunc = - ignore $ sepBy1 (objectWith addFunc) comma - -{- -objectList1 :: N3Parser [RDFLabel] -objectList1 = sepBy1 object comma --} - -{- -verb ::= | "<=" - | "=" - | "=>" - | "@a" - | "@has" expression - | "@is" expression "@of" - | expression - --} - -verb :: N3Parser (RDFLabel -> RDFLabel -> AddStatement, RDFLabel) -verb = - -- we check reverse first so that <= is tried before looking for a URI via expression rule - (,) addStatementRev <$> verbReverse - <|> (,) addStatement <$> verbForward - --- those verbs for which subject is on the right and object on the left -verbReverse :: N3Parser RDFLabel -verbReverse = - string "<=" *> operatorLabel logImplies - <|> between (atWord "is") (atWord "of") (lexeme expression) - -{- - try (string "<=") *> operatorLabel logImplies - <|> between (try (atWord "is")) (atWord "of") (lexeme expression) --} - --- those verbs with subject on the left and object on the right -verbForward :: N3Parser RDFLabel -verbForward = - -- (try (string "=>") *> operatorLabel logImplies) - (string "=>" *> operatorLabel logImplies) - <|> (string "=" *> operatorLabel owlSameAs) - -- <|> (try (atWord "a") *> operatorLabel rdfType) - <|> (atWord "a" *> operatorLabel rdfType) - <|> (atWord "has" *> lexeme expression) - <|> lexeme expression - -{- -universal ::= | "@forAll" symbol_csl - -TODO: what needs to be done to support universal quantification --} -universal :: N3Parser () -universal = - -- try (atWord "forAll") *> - atWord "forAll" *> - failBad "universal (@forAll) currently unsupported." - -- will be something like: *> symbolCsl - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/NTFormatter.hs b/src/Swish/RDF/NTFormatter.hs deleted file mode 100644 --- a/src/Swish/RDF/NTFormatter.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3Formatter --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This Module implements a NTriples formatter (see [1]) --- for an RDFGraph value. --- --- --- REFERENCES: --- --- 1 --- RDF Test Cases --- W3C Recommendation 10 February 2004 --- --------------------------------------------------------------------------------- - -module Swish.RDF.NTFormatter - ( NodeGenLookupMap - , formatGraphAsText - , formatGraphAsLazyText - , formatGraphAsBuilder - ) -where - -import Swish.RDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , getArcs - ) - -import Swish.RDF.GraphClass - ( Arc(..) ) - -import Swish.Utils.Namespace (ScopedName, getQName) -import Swish.RDF.Vocabulary (isLang, langTag) - -import Swish.Utils.LookupMap - ( LookupMap, emptyLookupMap - , mapFind, mapAdd - ) - -import Data.Char (ord, intToDigit, toUpper) - -import Control.Monad.State -import Control.Applicative ((<$>)) -import Data.Monoid - --- it strikes me that using Lazy Text here is likely to be --- wrong; however I have done no profiling to back this --- assumption up! - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B - ----------------------------------------------------------------------- --- Graph formatting state monad ----------------------------------------------------------------------- --- --- This is a lot simpler than other formatters. - --- | Node name generation state information that carries through --- and is updated by nested formulae -type NodeGenLookupMap = LookupMap (RDFLabel,Int) - -data NTFormatterState = NTFS { - ntfsNodeMap :: NodeGenLookupMap, - ntfsNodeGen :: Int - } deriving Show - -emptyNTFS :: NTFormatterState -emptyNTFS = NTFS { - ntfsNodeMap = emptyLookupMap, - ntfsNodeGen = 0 - } - -type Formatter a = State NTFormatterState a - --- | Convert a RDF graph to NTriples format. -formatGraphAsText :: RDFGraph -> T.Text -formatGraphAsText = L.toStrict . formatGraphAsLazyText - --- | Convert a RDF graph to NTriples format. -formatGraphAsLazyText :: RDFGraph -> L.Text -formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder - --- | Convert a RDF graph to NTriples format. -formatGraphAsBuilder :: RDFGraph -> B.Builder -formatGraphAsBuilder gr = fst $ runState (formatGraph gr) emptyNTFS - ----------------------------------------------------------------------- --- Formatting as a monad-based computation ----------------------------------------------------------------------- - -formatGraph :: RDFGraph -> Formatter B.Builder -formatGraph gr = mconcat <$> mapM formatArc (getArcs gr) - --- TODO: this reverses the contents but may be faster? --- that is if I've got the order right in the mappend call --- formatGraphBuilder gr = foldl' (\a b -> b `mappend` (formatArcBuilder a)) B.empty (getArcs gr) - -space, nl :: B.Builder -space = B.singleton ' ' -nl = " .\n" - -formatArc :: Arc RDFLabel -> Formatter B.Builder -formatArc (Arc s p o) = do - sl <- formatLabel s - pl <- formatLabel p - ol <- formatLabel o - return $ mconcat [sl, space, pl, space, ol, nl] - -- return $ sl `mappend` $ space `mappend` $ pl `mappend` $ space `mappend` $ ol `mappend` nl - -{- -If we have a blank node then can - - - use the label it contains - - generate a new one on output - -For now we create new labels whatever the input was since this -simplifies things, but it may be changed. - -formatLabel :: RDFLabel -> Formatter String -formatLabel lab@(Blank (lnc:_)) = - if isDigit lnc then mapBlankNode lab else return $ show lab -formatLabel lab = return $ show lab --} - -squote, at, carets :: B.Builder -squote = "\"" -at = "@" -carets = "^^" - -formatLabel :: RDFLabel -> Formatter B.Builder -formatLabel lab@(Blank _) = mapBlankNode lab -formatLabel (Res sn) = return $ showScopedName sn -formatLabel (Lit lit Nothing) = return $ quoteText lit -formatLabel (Lit lit (Just nam)) | isLang nam = return $ mconcat [quoteText lit, at, B.fromText (langTag nam)] - | otherwise = return $ mconcat [quoteText lit, carets, showScopedName nam] - --- do not expect to get the following, but include --- just in case rather than failing -formatLabel lab = return $ B.fromString $ show lab - -mapBlankNode :: RDFLabel -> Formatter B.Builder -mapBlankNode lab = do - st <- get - let cmap = ntfsNodeMap st - cval = ntfsNodeGen st - - nv <- case mapFind 0 lab cmap of - 0 -> do - let nval = succ cval - nmap = mapAdd cmap (lab, nval) - - put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval } - return nval - - n -> return n - - return $ "_:swish" `mappend` B.fromString (show nv) - --- TODO: can we use Network.URI to protect the URI? -showScopedName :: ScopedName -> B.Builder -{- -showScopedName (ScopedName n l) = - let uri = T.pack (show (nsURI n)) `mappend` l - in mconcat ["<", B.fromText (quote uri), ">"] --} --- showScopedName s = mconcat ["<", B.fromText (quote (T.pack (show (getQName s)))), ">"] -showScopedName s = B.fromText (quote (T.pack (show (getQName s)))) -- looks like qname already adds the <> around this - -{- -Swish.Utils.MiscHelpers contains a quote routine -which we expand upon here to match the NT syntax. --} - -quoteText :: T.Text -> B.Builder -quoteText st = mconcat [squote, B.fromText (quote st), squote] - -{- -QUS: should we be operating on Text like this? --} - -quote :: T.Text -> T.Text -quote = T.concatMap quoteT - -quoteT :: Char -> T.Text -quoteT '\\' = "\\\\" -quoteT '"' = "\\\"" -quoteT '\n' = "\\n" -quoteT '\t' = "\\t" -quoteT '\r' = "\\r" -quoteT c = - let nc = ord c - - in if nc > 0xffff - then T.pack ('\\':'U': numToHex 8 nc) - else if nc > 0x7e || nc < 0x20 - then T.pack ('\\':'u': numToHex 4 nc) - else T.singleton c - --- we assume c > 0, n >= 0 and that the input value fits --- into the requested number of digits -numToHex :: Int -> Int -> String -numToHex c = go [] - where - go s 0 = replicate (c - length s) '0' ++ s - go s n = - let (m,x) = divMod n 16 - in go (iToD x:s) m - - -- Data.Char.intToDigit uses lower-case Hex - iToD x | x < 10 = intToDigit x - | otherwise = toUpper $ intToDigit x - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/NTParser.hs b/src/Swish/RDF/NTParser.hs deleted file mode 100644 --- a/src/Swish/RDF/NTParser.hs +++ /dev/null @@ -1,427 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : NTParser --- Copyright : (c) 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This Module implements a NTriples parser (see [1]), returning a --- new 'RDFGraph' consisting of triples and namespace information parsed from --- the supplied NTriples input string, or an error indication. --- --- REFERENCES: --- --- 1 --- RDF Test Cases --- W3C Recommendation 10 February 2004 --- --------------------------------------------------------------------------------- - -module Swish.RDF.NTParser - ( ParseResult - , parseNT - , parsefromString - - {- - -- * Exports for parsers that embed NTriples in a bigger syntax - , NTParser, NTState(..) - , ntripleDoc - , line, ws, comment, eoln - , character, name, triple - , subject, predicate, object - , uriref, urirefLbl - , nodeID, literal, language - -} - - ) -where - -import Swish.RDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , addArc - , emptyRDFGraph - ) - -import Swish.RDF.GraphClass (arc) - -import Swish.Utils.Namespace (ScopedName, makeURIScopedName) - -import Swish.RDF.Vocabulary (langName) - -import Swish.RDF.RDFParser ( ParseResult - , runParserWithError - , ignore - , skipMany - , noneOf - , char - , string - , eoln - , fullStop - , hex4 - , hex8 - ) - -{- -import Swish.RDF.RDFParser - ( ParseResult, RDFParser - , ignore - , annotateParsecError - ) --} - -import Control.Applicative - -import Network.URI (parseURI) - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L - -import Data.Char (ord) -import Data.Maybe (fromMaybe) - -import Text.ParserCombinators.Poly.StateText - ----------------------------------------------------------------------- --- Define parser state and helper functions ----------------------------------------------------------------------- - --- | NT parser state -data NTState = NTState - { graphState :: RDFGraph -- Graph under construction - } - -emptyState :: NTState -emptyState = NTState { graphState = emptyRDFGraph } - --- Return function to update graph in NT parser state, --- using the supplied function of a graph. This is for use --- with stUpdate. --- -updateGraph :: (RDFGraph -> RDFGraph) -> NTState -> NTState -updateGraph f s = s { graphState = f (graphState s) } - ----------------------------------------------------------------------- --- Define top-level parser function: --- accepts a string and returns a graph or error ----------------------------------------------------------------------- - --- | Parser that carries around a `NTState` record. -type NTParser a = Parser NTState a - --- | Parse a string. --- -parseNT :: - L.Text -- ^ input in NTriples format. - -> ParseResult -parseNT = parsefromText ntripleDoc - -{- --- useful for testing -test :: String -> RDFGraph -test = either error id . parseNT --} - --- | Function to supply initial context and parse supplied term. --- -parsefromString :: - NTParser a -- ^ parser to apply - -> String -- ^ input to be parsed - -> Either String a -parsefromString parser = parsefromText parser . L.pack - --- | Function to supply initial context and parse supplied term. --- -parsefromText :: - NTParser a -- ^ parser to apply - -> L.Text -- ^ input to be parsed - -> Either String a -parsefromText parser = runParserWithError parser emptyState - --- helper routines - -{- -lineFeed :: NTParser () -lineFeed = ignore (char '\r') --} - --- Add statement to graph in NT parser state - -addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> NTParser () -addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) - ----------------------------------------------------------------------- --- Syntax productions ----------------------------------------------------------------------- - -{- - -EBNF from the specification, using the notation from XML 1.0, second edition, -is included inline below. - -We do not force ASCII 7-bit semantics here yet. - -space ::= #x20 /* US-ASCII space - decimal 32 */ -cr ::= #xD /* US-ASCII carriage return - decimal 13 */ -lf ::= #xA /* US-ASCII line feed - decimal 10 */ -tab ::= #x9 /* US-ASCII horizontal tab - decimal 9 */ - -The productions are kept as close as possible to the specification -for now. - --} - -{- -ntripleDoc ::= line* -line ::= ws* ( comment | triple )? eoln - -We relax the rule that the input must be empty or end with a new line. - -ntripleDoc :: NTParser RDFGraph -ntripleDoc = graphState <$> (many line *> eof *> getState) - -line :: NTParser () -line = skipMany ws *> optional (comment <|> triple) *> eoln --} - -ntripleDoc :: NTParser RDFGraph -ntripleDoc = graphState <$> (sepBy line eoln *> optional eoln *> skipWS *> eof *> stGet) - -line :: NTParser () -line = skipWS *> ignore (optional (comment <|> triple)) - -{- -ws ::= space | tab - -Could use whiteSpace rule here, but that would permit -constructs (e.g. comments) where we do not support them. --} - -isWS :: Char -> Bool -isWS = (`elem` " \t") - -{- -ws :: NTParser () --- ws = ignore (char ' ' <|> tab) -ws = ignore $ satisfy isWS --} - -skipWS :: NTParser () -skipWS = ignore $ manySatisfy isWS - -skip1WS :: NTParser () -skip1WS = ignore $ many1Satisfy isWS - -{- -comment ::= '#' ( character - ( cr | lf ) )* --} - -comment :: NTParser () -comment = char '#' *> skipMany (noneOf "\r\n") - -{- -eoln ::= cr | lf | cr lf --} - -{- -name ::= [A-Za-z][A-Za-z0-9]* --} - -isaz, isAZ, is09 :: Char -> Bool -isaz c = c >= 'a' && c <= 'z' -isAZ c = c >= 'A' && c <= 'Z' -is09 c = c >= '0' && c <= '9' - -isHeadChar, isBodyChar :: Char -> Bool -isHeadChar c = isaz c || isAZ c -isBodyChar c = isHeadChar c || is09 c - -name :: NTParser L.Text -name = L.cons <$> satisfy isHeadChar <*> manySatisfy isBodyChar - -nameStr :: NTParser String -nameStr = L.unpack <$> name - -{- -triple ::= subject ws+ predicate ws+ object ws* '.' ws* - --} - -triple :: NTParser () -triple = - {- tryin to be fancy but addStatement is a Parser not a pure function - addStatement - <$> (subject <* skip1WS) - <*> (predicate <* skip1WS) - <*> (object <* (skipWS *> fullStop *> skipWS)) - -} - - do - s <- subject - skip1WS - p <- predicate - skip1WS - o <- object - skipWS - fullStop - skipWS - addStatement s p o - -{- -subject ::= uriref | nodeID -predicate ::= uriref -object ::= uriref | nodeID | literal --} - -subject :: NTParser RDFLabel -subject = urirefLbl <|> nodeID - -predicate :: NTParser RDFLabel -predicate = urirefLbl - -object :: NTParser RDFLabel -object = urirefLbl <|> nodeID <|> literal - -{- -uriref ::= '<' absoluteURI '>' -absoluteURI ::= character+ with escapes as defined in section URI References - --} - -uriref :: NTParser ScopedName -uriref = do - -- not ideal, as want to reject invalid characters immediately rather than via parseURI - ustr <- L.unpack <$> bracket (char '<') (char '>') (many1Satisfy (/= '>')) - -- ustr <- bracket (char '<') (char '>') $ many1 character -- looks like need to exclude > from character - -- ustr <- char '<' *> manyTill character (char '>') - - maybe (failBad ("Invalid URI: <" ++ ustr ++ ">")) - (return . makeURIScopedName) - (parseURI ustr) - -urirefLbl :: NTParser RDFLabel -urirefLbl = Res <$> uriref - -{- -nodeID ::= '_:' name --} - -nodeID :: NTParser RDFLabel -nodeID = Blank <$> (string "_:" *> nameStr) - -{- -literal ::= langString | datatypeString -langString ::= '"' string '"' ( '@' language )? -datatypeString ::= '"' string '"' '^^' uriref -language ::= [a-z]+ ('-' [a-z0-9]+ )* -encoding a language tag. -string ::= character* with escapes as defined in section Strings - --} - -literal :: NTParser RDFLabel -literal = Lit <$> (T.pack <$> ntstring) <*> optional dtlang - -ntstring :: NTParser String -ntstring = bracket (char '"') (char '"') (many character) - -dtlang :: NTParser ScopedName -dtlang = - (char '@' *> language) - <|> (string "^^" *> uriref) - -language :: NTParser ScopedName -language = do - h <- many1Satisfy isaz - mt <- optional ( L.cons <$> char '-' <*> many1Satisfy (\c -> isaz c || is09 c) ) - return $ langName $ L.toStrict $ L.append h $ fromMaybe L.empty mt - -{- -String handling: - -EBNF has: - -character ::= [#x20-#x7E] /* US-ASCII space to decimal 126 */ - -Additional information from: - - http://www.w3.org/TR/rdf-testcases/#ntrip_strings - -N-Triples strings are sequences of US-ASCII character productions encoding [UNICODE] character strings. The characters outside the US-ASCII range and some other specific characters are made available by \-escape sequences as follows: - - Unicode character - (with code point u) N-Triples encoding - [#x0-#x8] \uHHHH - 4 required hexadecimal digits HHHH encoding Unicode character u - #x9 \t - #xA \n - [#xB-#xC] \uHHHH - 4 required hexadecimal digits HHHH encoding Unicode character u - #xD \r - [#xE-#x1F] \uHHHH - 4 required hexadecimal digits HHHH encoding Unicode character u - [#x20-#x21] the character u - #x22 \" - [#x23-#x5B] the character u - #x5C \\ - [#x5D-#x7E] the character u - [#x7F-#xFFFF] \uHHHH - 4 required hexadecimal digits HHHH encoding Unicode character u - [#10000-#x10FFFF] \UHHHHHHHH - 8 required hexadecimal digits HHHHHHHH encoding Unicode character u - where H is a hexadecimal digit: [#x30-#x39],[#x41-#x46] (0-9, uppercase A-F). - -This escaping satisfies the [CHARMOD] section Reference Processing Model on making the full Unicode character range U+0 to U+10FFFF available to applications and providing only one way to escape any character. - --} - --- 0x22 is " and 0x5c is \ - -isAsciiChar :: Char -> Bool -isAsciiChar c = let i = ord c - in i >= 0x20 && i <= 0x21 || - i >= 0x23 && i <= 0x5b || - i >= 0x5d && i <= 0x7e - -protectedChar :: NTParser Char -protectedChar = - (char 't' *> return '\t') - <|> (char 'n' *> return '\n') - <|> (char 'r' *> return '\r') - <|> (char '"' *> return '"') - <|> (char '\\' *> return '\\') - <|> (char 'u' *> hex4) - <|> (char 'U' *> hex8) - -character :: NTParser Char -character = - (char '\\' *> protectedChar) - <|> satisfy isAsciiChar - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Parser/N3.hs b/src/Swish/RDF/Parser/N3.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Parser/N3.hs @@ -0,0 +1,1190 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3 +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Notation 3 parser, returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied N3 input string, or an error indication. +-- +-- REFERENCES: +-- +-- - \"Notation3 (N3): A readable RDF syntax\", +-- W3C Team Submission 14 January 2008, +-- +-- +-- - Tim Berners-Lee's design issues series notes and description, +-- +-- +-- - Notation 3 Primer by Sean Palmer, +-- +-- +-- NOTES: +-- +-- UTF-8 handling is not really tested. +-- +-- No performance testing has been applied. +-- +-- Not all N3 grammar elements are supported, including: +-- +-- - @\@forSome@ (we read it in but ignore the arguments) +-- +-- - @\@forAll@ (this causes a parse error) +-- +-- - formulae are lightly tested +-- +-- - string support is incomplete (e.g. unrecognized escape characters +-- such as @\\q@ are probably handled incorrectly) +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Parser.N3 + ( ParseResult + , parseN3 + , parseN3fromText + , parseAnyfromText + , parseTextFromText, parseAltFromText + , parseNameFromText -- , parsePrefixFromText + , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText + + -- * Exports for parsers that embed Notation3 in a bigger syntax + , N3Parser, N3State(..), SpecialMap + + , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions + , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct + , quickVariable -- was varid + , lexUriRef + , document, subgraph + , newBlankNode + ) +where + +import Swish.GraphClass (arc) +import Swish.Namespace + ( Namespace + , ScopedName + , makeNamespace + , getScopeNamespace + , getScopedNameURI + , getScopeNamespace + , makeURIScopedName + , makeQNameScopedName + , makeNSScopedName + , nullScopedName + ) +import Swish.QName (QName, newLName) + +import Swish.RDF.Graph + ( RDFGraph, RDFLabel(..) + , ToRDFLabel(..) + , NamespaceMap + , LookupFormula(..) + , addArc + , setFormula + , setNamespaces + , emptyRDFGraph + ) + +import Swish.RDF.Datatype (makeDatatypedLiteral) + +import Swish.RDF.Vocabulary + ( LanguageTag + , toLangTag + , rdfType + , rdfFirst, rdfRest, rdfNil + , owlSameAs, logImplies + , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble + ) + +import Swish.RDF.Parser.Utils + ( SpecialMap + , ParseResult + , runParserWithError + -- , mapPrefix + , prefixTable + , specialTable + , ignore + , notFollowedBy + , endBy + , sepEndBy + , manyTill + , noneOf + , char + , ichar + , string + , stringT + , symbol + , lexeme + , whiteSpace + , hex4 + , hex8 + , appendURIs + ) + +import Control.Applicative +import Control.Monad (forM_, foldM) + +import Data.Char (isSpace, isDigit, ord, isAsciiLower) +import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) +import Data.LookupMap (mapFind, mapFindMaybe, mapAdd, mapReplace) +import Data.Maybe (fromMaybe, fromJust) +import Data.Word (Word32) + +import Network.URI (URI(..), parseURIReference) + +import Text.ParserCombinators.Poly.StateText + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | N3 parser state +data N3State = N3State + { graphState :: RDFGraph -- Graph under construction + , thisNode :: RDFLabel -- current context node (aka 'this') + , prefixUris :: NamespaceMap -- namespace prefix mapping table + , syntaxUris :: SpecialMap -- special name mapping table + , nodeGen :: Word32 -- blank node id generator + , keywordsList :: [T.Text] -- contents of the @keywords statement + , allowLocalNames :: Bool -- True if @keywords used so that bare names are QNames in default namespace + } + +-- | Functions to update N3State vector (use with stUpdate) + +setPrefix :: Maybe T.Text -> URI -> N3State -> N3State +setPrefix pre uri st = st { prefixUris=p' } + where + p' = mapReplace (prefixUris st) (makeNamespace pre uri) + +-- | Set name for special syntax element +setSName :: String -> ScopedName -> N3State -> N3State +setSName nam snam st = st { syntaxUris=s' } + where + s' = mapReplace (syntaxUris st) (nam,snam) + +setSUri :: String -> URI -> N3State -> N3State +setSUri nam = setSName nam . makeURIScopedName + +-- | Set the list of tokens that can be used without needing the leading +-- \@ symbol. +setKeywordsList :: [T.Text] -> N3State -> N3State +setKeywordsList ks st = st { keywordsList = ks, allowLocalNames = True } + +-- Functions to access state: + +-- | Get name for special syntax element, default null +getSName :: N3State -> String -> ScopedName +getSName st nam = mapFind nullScopedName nam (syntaxUris st) + +getSUri :: N3State -> String -> URI +getSUri st nam = getScopedNameURI $ getSName st nam + +-- Map prefix to URI +getPrefixURI :: N3State -> Maybe T.Text -> Maybe URI +getPrefixURI st pre = mapFindMaybe pre (prefixUris st) + +getKeywordsList :: N3State -> [T.Text] +getKeywordsList = keywordsList + +getAllowLocalNames :: N3State -> Bool +getAllowLocalNames = allowLocalNames + +-- Return function to update graph in N3 parser state, +-- using the supplied function of a graph +-- +updateGraph :: (RDFGraph -> RDFGraph) -> N3State -> N3State +updateGraph f s = s { graphState = f (graphState s) } + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +-- | The N3 parser. +type N3Parser a = Parser N3State a + +-- | Parse a string as N3 (with no real base URI). +-- +-- See 'parseN3' if you need to provide a base URI. +-- +parseN3fromText :: + L.Text -- ^ input in N3 format. + -> ParseResult +parseN3fromText = flip parseN3 Nothing + +-- | Parse a string with an optional base URI. +-- +-- See also 'parseN3fromString'. +-- +parseN3 :: + L.Text -- ^ input in N3 format. + -> Maybe QName -- ^ optional base URI + -> ParseResult +parseN3 txt mbase = parseAnyfromText document mbase txt + +{- +-- useful for testing +test :: String -> RDFGraph +test = either error id . parseAnyfromString document Nothing +-} + +hashURI :: URI +hashURI = fromJust $ parseURIReference "#" + +emptyState :: + Maybe QName -- ^ starting base for the graph + -> N3State +emptyState mbase = + let pmap = LookupMap [makeNamespace Nothing hashURI] + muri = fmap (makeQNameScopedName Nothing) mbase + smap = LookupMap $ specialTable muri + in N3State + { graphState = emptyRDFGraph + , thisNode = NoNode + , prefixUris = pmap + , syntaxUris = smap + , nodeGen = 0 + , keywordsList = ["a", "is", "of", "true", "false"] -- not 100% sure about true/false here + , allowLocalNames = False + } + + +-- TODO: change from QName to URI for the base? + +-- | Function to supply initial context and parse supplied term. +-- +parseAnyfromText :: N3Parser a -- ^ parser to apply + -> Maybe QName -- ^ base URI of the input, or @Nothing@ to use default base value + -> L.Text -- ^ input to be parsed + -> Either String a +parseAnyfromText parser mbase = runParserWithError parser (emptyState mbase) + +-- | Create a new blank node. +newBlankNode :: N3Parser RDFLabel +newBlankNode = do + n <- stQuery (succ . nodeGen) + stUpdate $ \s -> s { nodeGen = n } + return $ Blank (show n) + +-- Test functions for selected element parsing + +-- TODO: remove these + +-- | Used in testing. +parseTextFromText :: String -> L.Text -> Either String String +parseTextFromText s = + parseAnyfromText (string s) Nothing + +-- | Used in testing. +parseAltFromText :: String -> String -> L.Text -> Either String String +parseAltFromText s1 s2 = + parseAnyfromText (string s1 <|> string s2) Nothing + +-- | Used in testing. +parseNameFromText :: L.Text -> Either String String +parseNameFromText = + parseAnyfromText n3NameStr Nothing + +{- +This has been made tricky by the attempt to remove the default list +of prefixes from the starting point of a N3 parse and the subsequent +attempt to add every new namespace we come across to the parser state. + +So we add in the original default namespaces for testing, since +this routine is really for testing. +-} + +addTestPrefixes :: N3Parser () +addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map + +{- +parsePrefixFromText :: L.Text -> Either String URI +parsePrefixFromText = + parseAnyfromText p Nothing + where + p = do + addTestPrefixes + pref <- n3Name + st <- stGet + case getPrefixURI st (Just pref) of + Just uri -> return uri + _ -> fail $ "Undefined prefix: '" ++ pref ++ "'" +-} + +-- | Used in testing. +parseAbsURIrefFromText :: L.Text -> Either String URI +parseAbsURIrefFromText = + parseAnyfromText explicitURI Nothing + +-- | Used in testing. +parseLexURIrefFromText :: L.Text -> Either String URI +parseLexURIrefFromText = + parseAnyfromText lexUriRef Nothing + +-- | Used in testing. +parseURIref2FromText :: L.Text -> Either String ScopedName +parseURIref2FromText = + parseAnyfromText (addTestPrefixes *> n3symbol) Nothing + +---------------------------------------------------------------------- +-- Syntax productions +---------------------------------------------------------------------- + +-- helper routines + +comma, semiColon , fullStop :: N3Parser () +comma = ignore $ symbol "," +semiColon = ignore $ symbol ";" +fullStop = ignore $ symbol "." + +-- a specialization of bracket/between +br :: String -> String -> N3Parser a -> N3Parser a +br lsym rsym = bracket (symbol lsym) (symbol rsym) + +-- to make porting from parsec to polyparse easier +between :: Parser s lbr -> Parser s rbr -> Parser s a -> Parser s a +between = bracket + +-- The @ character is optional if the keyword is in the +-- keyword list +-- +atSign :: T.Text -> N3Parser () +atSign s = do + st <- stGet + + let p = ichar '@' + + if s `elem` getKeywordsList st + then ignore $ optional p + else p + +atWord :: T.Text -> N3Parser T.Text +atWord s = do + atSign s + + -- TODO: does it really make sense to add the not-followed-by-a-colon rule here? + -- apply to both cases even though should only really be necessary + -- when the at sign is not given + -- + lexeme $ stringT s *> notFollowedBy (== ':') + return s + +{- +Since operatorLabel can be used to add a label with an +unknown namespace, we need to ensure that the namespace +is added if not known. If the namespace prefix is already +in use then it is over-written (rather than add a new +prefix for the label). + +TODO: + - could we use the reverse lookupmap functionality to + find if the given namespace URI is in the namespace + list? If it is, use it's key otherwise do a + mapReplace for the input namespace. + +-} +operatorLabel :: ScopedName -> N3Parser RDFLabel +operatorLabel snam = do + st <- stGet + let sns = getScopeNamespace snam + opmap = prefixUris st + pkey = entryKey sns + pval = entryVal sns + + rval = Res snam + + -- the lookup and the replacement could be fused + case mapFindMaybe pkey opmap of + Just val | val == pval -> return rval + | otherwise -> do + stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } + return rval + + _ -> do + stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } + return rval + +{- +Add statement to graph in N3 parser state. + +To support literals that are written directly/implicitly - i.e. as +true/false/1/1.0/1.0e23 - rather than a string with an explicit +datatype we need to special case handling of the object label for +literals. Is this actually needed? The N3 Formatter now doesn't +display the xsd: datatypes on output, but there may be issues with +other formats (e.g RDF/XML once it is supported). + +-} + +type AddStatement = RDFLabel -> N3Parser () + +addStatement :: RDFLabel -> RDFLabel -> AddStatement +addStatement s p o@(TypedLit _ dtype) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do + ost <- stGet + let stmt = arc s p o + oldp = prefixUris ost + ogs = graphState ost + newp = mapReplace oldp (getScopeNamespace dtype) + stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } +addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) + +addStatementRev :: RDFLabel -> RDFLabel -> AddStatement +addStatementRev o p s = addStatement s p o + +{- +A number of productions require a name, which starts with + +[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff] + +and then has + +[\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* + +we encode this as the n3Name production +-} + +isaz, is09, isaz09 :: Char -> Bool +isaz = isAsciiLower +is09 = isDigit +isaz09 c = isaz c || is09 c + +match :: (Ord a) => a -> [(a,a)] -> Bool +match v = any (\(l,h) -> v >= l && v <= h) + +startChar :: Char -> Bool +startChar c = let i = ord c + in c == '_' || + match c [('A', 'Z'), ('a', 'z')] || + match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x02ff), + (0x0370, 0x037d), + (0x037f, 0x1fff), (0x200c, 0x200d), + (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), + (0xf900, 0xfdcf), (0xfdf0, 0xfffd), + (0x00010000, 0x000effff)] + +inBody :: Char -> Bool +inBody c = let i = ord c + in c `elem` "-_" || i == 0x007 || + match c [('0', '9'), ('A', 'Z'), ('a', 'z')] || + match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x037d), + (0x037f, 0x1fff), (0x200c, 0x200d), (0x203f, 0x2040), + (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), + (0xf900, 0xfdcf), (0xfdf0, 0xfffd), + (0x00010000, 0x000effff)] + +-- should this be strict or lazy text? +n3Name :: N3Parser T.Text +n3Name = T.cons <$> n3Init <*> n3Body + where + n3Init = satisfy startChar + n3Body = L.toStrict <$> manySatisfy inBody + + +n3NameStr :: N3Parser String +n3NameStr = T.unpack <$> n3Name + +{- +quickvariable ::= \?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* +-} + +-- TODO: is mapping to Var correct? +-- | Match @?@. +quickVariable :: N3Parser RDFLabel +quickVariable = char '?' *> (Var <$> n3NameStr) + +{- +string ::= ("""[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""")|("[^"\\]*(?:\\.[^"\\]*)*") + +or + +string ::= tripleQuoted | singleQUoted + +-} + +n3string :: N3Parser T.Text +n3string = tripleQuoted <|> singleQuoted + +{- +singleQuoted ::= "[^"\\]*(?:\\.[^"\\]*)*" + +asciiChars :: String +asciiChars = map chr [0x20..0x7e] + +asciiCharsN3 :: String +asciiCharsN3 = filter (`notElem` "\\\"") asciiChars + +-} + +digit :: N3Parser Char +digit = satisfy isDigit + +{- +This is very similar to NTriples accept that also allow the escaping of ' +even though it is not required. + +The Python rules allow \N{name}, where name is the Unicode name. It's +not clear whether we need to support this too, so for now we do not. + +-} +protectedChar :: N3Parser Char +protectedChar = + (char 't' *> return '\t') + <|> (char 'n' *> return '\n') + <|> (char 'r' *> return '\r') + <|> (char '"' *> return '"') + <|> (char '\'' *> return '\'') + <|> (char '\\' *> return '\\') + <|> (char 'u' *> hex4) + <|> (char 'U' *> hex8) + +-- Accept an escape character or any character as long as it isn't +-- a new-line or quote. Unrecognized escape sequences should therefore +-- be left alone by this. +-- +n3Character :: N3Parser Char +n3Character = + (char '\\' *> (protectedChar <|> return '\\')) + <|> noneOf "\"\n" + +{- + <|> (oneOf asciiCharsN3 "ASCII character") + -- TODO: bodyChar and asciiCharsN3 overlap + <|> (oneOf bodyChar "Unicode character") +-} + +sQuot :: N3Parser Char +sQuot = char '"' + +{- +TODO: there must be a better way of building up the Text +-} + +singleQuoted :: N3Parser T.Text +singleQuoted = fmap T.pack (bracket sQuot sQuot $ many n3Character) + +{- +tripleQUoted ::= """[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""" +-} +tripleQuoted :: N3Parser T.Text +tripleQuoted = tQuot *> fmap T.pack (manyTill (n3Character <|> sQuot <|> char '\n') tQuot) + where + -- tQuot = try (count 3 sQuot) + tQuot = exactly 3 sQuot + +getDefaultPrefix :: N3Parser Namespace +getDefaultPrefix = do + s <- stGet + case getPrefixURI s Nothing of + Just uri -> return $ makeNamespace Nothing uri + _ -> fail "No default prefix defined; how unexpected!" + +addBase :: URI -> N3Parser () +addBase = stUpdate . setSUri "base" + +addPrefix :: Maybe T.Text -> URI -> N3Parser () +addPrefix p = stUpdate . setPrefix p + +{-| +Update the set of keywords that can be given without +an \@ sign. +-} +updateKeywordsList :: [T.Text] -> N3Parser () +updateKeywordsList = stUpdate . setKeywordsList + +{- +document ::= | statements_optional EOF +-} + +-- | Process a N3 document, returning a graph. +document :: N3Parser RDFGraph +document = mkGr <$> (whiteSpace *> statementsOptional *> eof *> stGet) + where + mkGr s = setNamespaces (prefixUris s) (graphState s) + +{- +statements_optional ::= | statement "." statements_optional + | void + +-} + +statementsOptional :: N3Parser () +statementsOptional = ignore $ endBy (lexeme statement) fullStop + +{- +statement ::= | declaration + | existential + | simpleStatement + | universal + +-} + +statement :: N3Parser () +statement = + declaration + <|> existential + <|> universal + <|> simpleStatement + -- having an error here leads to less informative errors in general, it seems + -- "statement (existential or universal quantification or a simple statement)" + +{- +declaration ::= | "@base" explicituri + | "@keywords" barename_csl + | "@prefix" prefix explicituri +-} + +-- TODO: do we need the try statements here? atWord would need to have a try on '@' +-- (if applicable) which should mean being able to get rid of try +-- +declaration :: N3Parser () +declaration = oneOf [ + atWord "base" >> explicitURI >>= addBase, + atWord "keywords" >> bareNameCsl >>= updateKeywordsList, + atWord "prefix" *> getPrefix + ] + + {- + (try (atWord "base") >> explicitURI >>= addBase) + <|> + (try (atWord "keywords") >> bareNameCsl >>= updateKeywordsList) + <|> + (try (atWord "prefix") *> getPrefix) + -} + +-- | Process the remainder of an @\@prefix@ line (after this +-- has been processed). The prefix value and URI are added to the parser +-- state. +getPrefix :: N3Parser () +getPrefix = do + p <- lexeme prefix + u <- explicitURI + addPrefix p u + +{- +explicituri ::= <[^>]*> + +Note: white space is to be ignored within <> +-} + +explicitURI :: N3Parser URI +explicitURI = do + let lb = char '<' + rb = char '>' + + -- TODO: do the whitespace definitions match? + ustr <- between lb rb $ many (satisfy (/= '>')) + let uclean = filter (not . isSpace) ustr + + case parseURIReference uclean of + Nothing -> fail $ "Unable to convert <" ++ uclean ++ "> to a URI" + Just uref -> do + s <- stGet + let base = getSUri s "base" + either fail return $ appendURIs base uref + +-- production from the old parser; used in SwishScript +-- | An explicitly given URI followed by white space. +lexUriRef :: N3Parser URI +lexUriRef = lexeme explicitURI + +{- +barename ::= [A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* +barename_csl ::= | barename barename_csl_tail + | void +barename_csl_tail ::= | "," barename barename_csl_tail + | void +-} + +bareNameCsl :: N3Parser [T.Text] +bareNameCsl = sepBy (lexeme bareName) comma + +bareName :: N3Parser T.Text +bareName = n3Name + +{- +prefix ::= ([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?: +-} + +prefix :: N3Parser (Maybe T.Text) +prefix = optional (lexeme n3Name) <* char ':' + + +{- +symbol ::= | explicituri + | qname +symbol_csl ::= | symbol symbol_csl_tail + | void +symbol_csl_tail ::= | "," symbol symbol_csl_tail + | void + +-} + +-- | Match a N3 symbol (an explicit URI or a QName) +-- and convert it to a 'ScopedName'. +n3symbol :: N3Parser ScopedName +n3symbol = + (makeURIScopedName <$> explicitURI) + <|> qname + +symbolCsl :: N3Parser [ScopedName] +symbolCsl = sepBy (lexeme n3symbol) comma + +{- +qname ::= (([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?:)?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* + +TODO: + Note that, for now, we explicitly handle blank nodes + (of the form _:name) direcly in pathItem'. + This is not a good idea since qname' is used elsewhere + and so shouldn't we do the same thing there too? +-} + +-- for now assume that the parsing rule for the local part +-- will not create an invalid LName. +toName :: Namespace -> T.Text -> ScopedName +toName ns l = + case newLName l of + Just local -> makeNSScopedName ns local + _ -> error $ "Invalid local name: " ++ T.unpack l + +qname :: N3Parser ScopedName +qname = qname1 <|> qname2 + +qname1 :: N3Parser ScopedName +qname1 = fmap (uncurry toName) (char ':' >> g) + where + g = (,) <$> getDefaultPrefix <*> (n3Name <|> return "") + +qname2 :: N3Parser ScopedName +qname2 = n3Name >>= fullOrLocalQName + +fullOrLocalQName :: T.Text -> N3Parser ScopedName +fullOrLocalQName name = + (char ':' *> fullQName name) + <|> localQName name + +fullQName :: T.Text -> N3Parser ScopedName +fullQName name = toName <$> findPrefix name <*> (n3Name <|> pure "") + +findPrefix :: T.Text -> N3Parser Namespace +findPrefix pre = do + st <- stGet + case mapFindMaybe (Just pre) (prefixUris st) of + Just uri -> return $ makeNamespace (Just pre) uri + Nothing -> failBad $ "Prefix '" ++ T.unpack pre ++ ":' not bound." + +localQName :: T.Text -> N3Parser ScopedName +localQName name = do + st <- stGet + if getAllowLocalNames st + then let g = (,) <$> getDefaultPrefix <*> pure name + in uncurry toName <$> g + + else fail ("Invalid 'bare' word: " ++ T.unpack name)-- TODO: not ideal error message; can we handle this case differently? + +{- +existential ::= | "@forSome" symbol_csl + +For now we just read in the symbols and ignore them, +since we do not mark blank nodes as existentially quantified +(we assume this is the case). + +TODO: fix this? +-} + +existential :: N3Parser () +-- existential = try (atWord "forSome") *> symbolCsl >> return () +existential = atWord "forSome" *> symbolCsl *> pure () + +{- +simpleStatement ::= | subject propertylist +-} + +simpleStatement :: N3Parser () +simpleStatement = subject >>= propertyListWith + +{- +subject ::= | expression +-} + +subject :: N3Parser RDFLabel +subject = lexeme expression + +{- +expression ::= | pathitem pathtail +pathtail ::= | "!" expression + | "^" expression + | void + +-} + +expression :: N3Parser RDFLabel +expression = do + i <- pathItem + + let backwardExpr = char '!' *> return addStatementRev + forwardExpr = char '^' *> return addStatement + + mpt <- optional + ( (,) <$> lexeme (forwardExpr <|> backwardExpr) <*> lexeme expression ) + case mpt of + Nothing -> return i + Just (addFunc, pt) -> do + bNode <- newBlankNode + addFunc bNode pt i + return bNode + +{- +pathitem ::= | "(" pathlist ")" + | "[" propertylist "]" + | "{" formulacontent "}" + | boolean + | literal + | numericliteral + | quickvariable + | symbol + +pathlist ::= | expression pathlist + | void + +Need to think about how to handle formulae, since need to know the context +of the call to know where to add them. + +TOOD: may include direct support for blank nodes here, +namely convert _:stringval -> Blank stringval since although +this should be done by symbol the types don't seem to easily match +up (at first blush anyway) +-} + +pathItem :: N3Parser RDFLabel +pathItem = + br "(" ")" pathList + <|> br "[" "]" propertyListBNode + <|> br "{" "}" formulaContent + -- <|> try boolean + <|> boolean + <|> literal + <|> numericLiteral + <|> quickVariable + <|> Blank <$> (string "_:" *> n3NameStr) -- TODO a hack that needs fixing + <|> Res <$> n3symbol + +{- +we create a blank node for the list and return it, whilst +adding the list contents to the graph +-} +pathList :: N3Parser RDFLabel +pathList = do + cts <- many (lexeme expression) + eNode <- operatorLabel rdfNil + case cts of + [] -> return eNode + + (c:cs) -> do + sNode <- newBlankNode + first <- operatorLabel rdfFirst + addStatement sNode first c + lNode <- foldM addElem sNode cs + rest <- operatorLabel rdfRest + addStatement lNode rest eNode + return sNode + + where + addElem prevNode curElem = do + bNode <- newBlankNode + first <- operatorLabel rdfFirst + rest <- operatorLabel rdfRest + addStatement prevNode rest bNode + addStatement bNode first curElem + return bNode + +{- +formulacontent ::= | statementlist + +statementlist ::= | statement statementtail + | void +statementtail ::= | "." statementlist + | void +-} + +restoreState :: N3State -> N3Parser N3State +restoreState origState = do + oldState <- stGet + stUpdate $ \_ -> origState { nodeGen = nodeGen oldState } + return oldState + +{- +We create a subgraph and assign it to a blank node, returning the +blank node. At present it is a combination of the subgraph and formula +productions from the origial parser. + +TODO: is it correct? +-} +formulaContent :: N3Parser RDFLabel +formulaContent = do + bNode <- newBlankNode + pstate <- stGet + stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = bNode } + statementList + oldState <- restoreState pstate + stUpdate $ updateGraph $ setFormula (Formula bNode (graphState oldState)) + return bNode + +-- | Process a sub graph and assign it to the given label. +subgraph :: RDFLabel -> N3Parser RDFGraph +subgraph this = do + pstate <- stGet + stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = this } + statementsOptional -- parse statements of formula + oldState <- restoreState pstate + return $ graphState oldState + +statementList :: N3Parser () +statementList = ignore $ sepEndBy (lexeme statement) fullStop + +{- +boolean ::= | "@false" + | "@true" +-} + +boolean :: N3Parser RDFLabel +boolean = makeDatatypedLiteral xsdBoolean <$> + (atWord "false" <|> atWord "true") + -- (try (atWord "false") <|> atWord "true") + +{- +dtlang ::= | "@" langcode + | "^^" symbol + | void +literal ::= | string dtlang + +langcode ::= [a-z]+(-[a-z0-9]+)* + +-} + +literal :: N3Parser RDFLabel +literal = do + lit <- n3string + opt <- optional dtlang + return $ case opt of + Just (Left lcode) -> LangLit lit lcode + Just (Right dtype) -> TypedLit lit dtype + _ -> Lit lit + +dtlang :: N3Parser (Either LanguageTag ScopedName) +dtlang = + (char '@' *> (Left <$> langcode)) + <|> string "^^" *> (Right <$> n3symbol) + +-- Note that toLangTag may fail since it does some extra +-- validation not done by the parser (mainly on the length of the +-- primary and secondary tags). +-- +-- NOTE: This parser does not accept multiple secondary tags which RFC3066 +-- does. +-- +langcode :: N3Parser LanguageTag +langcode = do + h <- many1Satisfy isaz + mt <- optional (L.cons <$> char '-' <*> many1Satisfy isaz09) + let lbl = L.toStrict $ L.append h $ fromMaybe L.empty mt + case toLangTag lbl of + Just lt -> return lt + _ -> fail ("Invalid language tag: " ++ T.unpack lbl) -- should this be failBad? + +{- +decimal ::= [-+]?[0-9]+(\.[0-9]+)? +double ::= [-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+) +integer ::= [-+]?[0-9]+ +numericliteral ::= | decimal + | double + | integer + +We actually support 1. for decimal values which isn't supported +by the above production. + +TODO: we could convert via something like + + maybeRead value :: Double >>= Just . toRDFLabel + +which would mean we store the canonical XSD value in the +label, but it is not useful for the xsd:decimal case +since we currently don't have a Haskell type that +goes with it. +-} + +numericLiteral :: N3Parser RDFLabel +numericLiteral = + -- -- try (makeDatatypedLiteral xsdDouble <$> n3double) + -- try (d2s <$> n3double) + -- <|> try (makeDatatypedLiteral xsdDecimal <$> n3decimal) + d2s <$> n3double + <|> makeDatatypedLiteral xsdDecimal . T.pack <$> n3decimal + <|> makeDatatypedLiteral xsdInteger . T.pack <$> n3integer + +n3sign :: N3Parser Char +n3sign = char '+' <|> char '-' + +n3integer :: N3Parser String +n3integer = do + ms <- optional n3sign + ds <- many1 digit + case ms of + Just s -> return $ s : ds + _ -> return ds + +n3decimal :: N3Parser String +-- n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many1 digit ) +n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many digit ) + +n3double :: N3Parser String +n3double = (++) <$> n3decimal <*> ( (:) <$> satisfy (`elem` "eE") <*> n3integer ) + +-- Convert a double, as returned by n3double, into it's +-- canonical XSD form. We assume that n3double returns +-- a syntactivally valid Double, so do not bother with reads here +-- +d2s :: String -> RDFLabel +d2s s = toRDFLabel (read s :: Double) + +{- +propertylist ::= | verb object objecttail propertylisttail + | void +propertylisttail ::= | ";" propertylist + | void + +-} + +-- it's probably important that bNode is created *after* +-- processing the plist (mainly for the assumptions made by +-- formatting the output as N3; e.g. list/sequence ordering) +-- +propertyListBNode :: N3Parser RDFLabel +propertyListBNode = do + plist <- sepEndBy ((,) <$> lexeme verb <*> objectList) semiColon + bNode <- newBlankNode + let addList ((addFunc,vrb),items) = mapM_ (addFunc bNode vrb) items + forM_ plist addList + return bNode + +propertyListWith :: RDFLabel -> N3Parser () +propertyListWith subj = + let -- term = lexeme verb >>= objectListWith subj + term = lexeme verb >>= \(addFunc, vrb) -> objectListWith (addFunc subj vrb) + in ignore $ sepEndBy term semiColon + +{- +object ::= | expression +objecttail ::= | "," object objecttail + | void + +We change the production rule from objecttail to objectlist for lists of +objects (may change back). + +-} + +object :: N3Parser RDFLabel +object = lexeme expression + +objectList :: N3Parser [RDFLabel] +objectList = sepBy1 object comma + +objectWith :: AddStatement -> N3Parser () +objectWith addFunc = object >>= addFunc + +objectListWith :: AddStatement -> N3Parser () +objectListWith addFunc = + ignore $ sepBy1 (objectWith addFunc) comma + +{- +objectList1 :: N3Parser [RDFLabel] +objectList1 = sepBy1 object comma +-} + +{- +verb ::= | "<=" + | "=" + | "=>" + | "@a" + | "@has" expression + | "@is" expression "@of" + | expression + +-} + +verb :: N3Parser (RDFLabel -> RDFLabel -> AddStatement, RDFLabel) +verb = + -- we check reverse first so that <= is tried before looking for a URI via expression rule + (,) addStatementRev <$> verbReverse + <|> (,) addStatement <$> verbForward + +-- those verbs for which subject is on the right and object on the left +verbReverse :: N3Parser RDFLabel +verbReverse = + string "<=" *> operatorLabel logImplies + <|> between (atWord "is") (atWord "of") (lexeme expression) + +{- + try (string "<=") *> operatorLabel logImplies + <|> between (try (atWord "is")) (atWord "of") (lexeme expression) +-} + +-- those verbs with subject on the left and object on the right +verbForward :: N3Parser RDFLabel +verbForward = + -- (try (string "=>") *> operatorLabel logImplies) + (string "=>" *> operatorLabel logImplies) + <|> (string "=" *> operatorLabel owlSameAs) + -- <|> (try (atWord "a") *> operatorLabel rdfType) + <|> (atWord "a" *> operatorLabel rdfType) + <|> (atWord "has" *> lexeme expression) + <|> lexeme expression + +{- +universal ::= | "@forAll" symbol_csl + +TODO: what needs to be done to support universal quantification +-} +universal :: N3Parser () +universal = + -- try (atWord "forAll") *> + atWord "forAll" *> + failBad "universal (@forAll) currently unsupported." + -- will be something like: *> symbolCsl + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Parser/NTriples.hs b/src/Swish/RDF/Parser/NTriples.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Parser/NTriples.hs @@ -0,0 +1,410 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- + +-- | +-- Module : NTriples +-- Copyright : (c) 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module implements a NTriples parser, returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied NTriples input string, or an error indication. +-- +-- REFERENCES: +-- +-- - \"RDF Test Cases\", +-- W3C Recommendation 10 February 2004, +-- +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Parser.NTriples + ( ParseResult + , parseNT + ) +where + +import Swish.GraphClass (arc) +import Swish.Namespace (ScopedName, makeURIScopedName) + +import Swish.RDF.Graph (RDFGraph, RDFLabel(..), addArc, emptyRDFGraph) +import Swish.RDF.Vocabulary (LanguageTag, toLangTag) + +import Swish.RDF.Parser.Utils (ParseResult + , runParserWithError + , ignore + , skipMany + , noneOf + , char + , string + , eoln + , fullStop + , hex4 + , hex8 + ) + +import Control.Applicative + +import Network.URI (parseURI) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L + +import Data.Char (isAsciiLower, isAsciiUpper, isDigit, ord) +import Data.Maybe (fromMaybe) + +import Text.ParserCombinators.Poly.StateText + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | NT parser state +data NTState = NTState + { graphState :: RDFGraph -- Graph under construction + } + +emptyState :: NTState +emptyState = NTState { graphState = emptyRDFGraph } + +-- Return function to update graph in NT parser state, +-- using the supplied function of a graph. This is for use +-- with stUpdate. +-- +updateGraph :: (RDFGraph -> RDFGraph) -> NTState -> NTState +updateGraph f s = s { graphState = f (graphState s) } + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +-- | Parser that carries around a NTState record. +type NTParser a = Parser NTState a + +-- | Parse a string. +-- +parseNT :: + L.Text -- ^ input in NTriples format. + -> ParseResult +parseNT = parsefromText ntripleDoc + +{- +-- useful for testing +test :: String -> RDFGraph +test = either error id . parseNT +-} + +-- | Function to supply initial context and parse supplied term. +-- +-- Used for debugging. +parsefromText :: + NTParser a -- ^ parser to apply + -> L.Text -- ^ input to be parsed + -> Either String a +parsefromText parser = runParserWithError parser emptyState + +-- helper routines + +{- +lineFeed :: NTParser () +lineFeed = ignore (char '\r') +-} + +-- Add statement to graph in NT parser state + +addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> NTParser () +addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) + +---------------------------------------------------------------------- +-- Syntax productions +---------------------------------------------------------------------- + +{- + +EBNF from the specification, using the notation from XML 1.0, second edition, +is included inline below. + +We do not force ASCII 7-bit semantics here yet. + +space ::= #x20 /* US-ASCII space - decimal 32 */ +cr ::= #xD /* US-ASCII carriage return - decimal 13 */ +lf ::= #xA /* US-ASCII line feed - decimal 10 */ +tab ::= #x9 /* US-ASCII horizontal tab - decimal 9 */ + +The productions are kept as close as possible to the specification +for now. + +-} + +{- +ntripleDoc ::= line* +line ::= ws* ( comment | triple )? eoln + +We relax the rule that the input must be empty or end with a new line. + +ntripleDoc :: NTParser RDFGraph +ntripleDoc = graphState <$> (many line *> eof *> getState) + +line :: NTParser () +line = skipMany ws *> optional (comment <|> triple) *> eoln +-} + +ntripleDoc :: NTParser RDFGraph +ntripleDoc = graphState <$> (sepBy line eoln *> optional eoln *> skipWS *> eof *> stGet) + +line :: NTParser () +line = skipWS *> ignore (optional (comment <|> triple)) + +{- +ws ::= space | tab + +Could use whiteSpace rule here, but that would permit +constructs (e.g. comments) where we do not support them. +-} + +isWS :: Char -> Bool +isWS = (`elem` " \t") + +{- +ws :: NTParser () +-- ws = ignore (char ' ' <|> tab) +ws = ignore $ satisfy isWS +-} + +skipWS :: NTParser () +skipWS = ignore $ manySatisfy isWS + +skip1WS :: NTParser () +skip1WS = ignore $ many1Satisfy isWS + +{- +comment ::= '#' ( character - ( cr | lf ) )* +-} + +comment :: NTParser () +comment = char '#' *> skipMany (noneOf "\r\n") + +{- +eoln ::= cr | lf | cr lf +-} + +{- +name ::= [A-Za-z][A-Za-z0-9]* +-} + +isaz, isAZ, is09 :: Char -> Bool +isaz = isAsciiLower +isAZ = isAsciiUpper +is09 = isDigit + +isHeadChar, isBodyChar :: Char -> Bool +isHeadChar c = isaz c || isAZ c +isBodyChar c = isHeadChar c || is09 c + +name :: NTParser L.Text +name = L.cons <$> satisfy isHeadChar <*> manySatisfy isBodyChar + +nameStr :: NTParser String +nameStr = L.unpack <$> name + +{- +triple ::= subject ws+ predicate ws+ object ws* '.' ws* + +-} + +triple :: NTParser () +triple = + {- tryin to be fancy but addStatement is a Parser not a pure function + addStatement + <$> (subject <* skip1WS) + <*> (predicate <* skip1WS) + <*> (object <* (skipWS *> fullStop *> skipWS)) + -} + + do + s <- subject + skip1WS + p <- predicate + skip1WS + o <- object + skipWS + fullStop + skipWS + addStatement s p o + +{- +subject ::= uriref | nodeID +predicate ::= uriref +object ::= uriref | nodeID | literal +-} + +subject :: NTParser RDFLabel +subject = urirefLbl <|> nodeID + +predicate :: NTParser RDFLabel +predicate = urirefLbl + +object :: NTParser RDFLabel +object = urirefLbl <|> nodeID <|> literal + +{- +uriref ::= '<' absoluteURI '>' +absoluteURI ::= character+ with escapes as defined in section URI References + +-} + +uriref :: NTParser ScopedName +uriref = do + -- not ideal, as want to reject invalid characters immediately rather than via parseURI + ustr <- L.unpack <$> bracket (char '<') (char '>') (many1Satisfy (/= '>')) + -- ustr <- bracket (char '<') (char '>') $ many1 character -- looks like need to exclude > from character + -- ustr <- char '<' *> manyTill character (char '>') + + maybe (failBad ("Invalid URI: <" ++ ustr ++ ">")) + (return . makeURIScopedName) + (parseURI ustr) + +urirefLbl :: NTParser RDFLabel +urirefLbl = Res <$> uriref + +{- +nodeID ::= '_:' name +-} + +nodeID :: NTParser RDFLabel +nodeID = Blank <$> (string "_:" *> nameStr) + +{- +literal ::= langString | datatypeString +langString ::= '"' string '"' ( '@' language )? +datatypeString ::= '"' string '"' '^^' uriref +language ::= [a-z]+ ('-' [a-z0-9]+ )* +encoding a language tag. +string ::= character* with escapes as defined in section Strings + +-} + +literal :: NTParser RDFLabel +literal = do + lit <- T.pack <$> ntstring + opt <- optional dtlang + return $ case opt of + Just (Left lcode) -> LangLit lit lcode + Just (Right dtype) -> TypedLit lit dtype + _ -> Lit lit + +ntstring :: NTParser String +ntstring = bracket (char '"') (char '"') (many character) + +dtlang :: NTParser (Either LanguageTag ScopedName) +dtlang = + (char '@' *> (Left <$> language)) + <|> (string "^^" *> (Right <$> uriref)) + +-- Note that toLangTag may fail since it does some extra +-- validation not done by the parser (mainly on the length of the +-- primary and secondary tags). +-- +-- NOTE: This parser does not accept multiple secondary tags which RFC3066 +-- does. +-- +language :: NTParser LanguageTag +language = do + h <- many1Satisfy isaz + mt <- optional ( L.cons <$> char '-' <*> many1Satisfy (\c -> isaz c || is09 c) ) + let lbl = L.toStrict $ L.append h $ fromMaybe L.empty mt + case toLangTag lbl of + Just lt -> return lt + _ -> fail ("Invalid language tag: " ++ T.unpack lbl) -- should this be failBad? + +{- +String handling: + +EBNF has: + +character ::= [#x20-#x7E] /* US-ASCII space to decimal 126 */ + +Additional information from: + + http://www.w3.org/TR/rdf-testcases/#ntrip_strings + +N-Triples strings are sequences of US-ASCII character productions encoding [UNICODE] character strings. The characters outside the US-ASCII range and some other specific characters are made available by \-escape sequences as follows: + + Unicode character + (with code point u) N-Triples encoding + [#x0-#x8] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + #x9 \t + #xA \n + [#xB-#xC] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + #xD \r + [#xE-#x1F] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + [#x20-#x21] the character u + #x22 \" + [#x23-#x5B] the character u + #x5C \\ + [#x5D-#x7E] the character u + [#x7F-#xFFFF] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + [#10000-#x10FFFF] \UHHHHHHHH + 8 required hexadecimal digits HHHHHHHH encoding Unicode character u + where H is a hexadecimal digit: [#x30-#x39],[#x41-#x46] (0-9, uppercase A-F). + +This escaping satisfies the [CHARMOD] section Reference Processing Model on making the full Unicode character range U+0 to U+10FFFF available to applications and providing only one way to escape any character. + +-} + +-- 0x22 is " and 0x5c is \ + +isAsciiChar :: Char -> Bool +isAsciiChar c = let i = ord c + in i >= 0x20 && i <= 0x21 || + i >= 0x23 && i <= 0x5b || + i >= 0x5d && i <= 0x7e + +protectedChar :: NTParser Char +protectedChar = + (char 't' *> return '\t') + <|> (char 'n' *> return '\n') + <|> (char 'r' *> return '\r') + <|> (char '"' *> return '"') + <|> (char '\\' *> return '\\') + <|> (char 'u' *> hex4) + <|> (char 'U' *> hex8) + +character :: NTParser Char +character = + (char '\\' *> protectedChar) + <|> satisfy isAsciiChar + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Parser/Turtle.hs b/src/Swish/RDF/Parser/Turtle.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Parser/Turtle.hs @@ -0,0 +1,1077 @@ +{-# LANGUAGE OverloadedStrings #-} -- only used in 'fromMaybe "" mbase' line of parseN3 + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Turtle +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Turtle parser, returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied input string, or an error indication. +-- +-- REFERENCES: +-- +-- - \"Turtle, Terse RDF Triple Language\", +-- W3C Working Draft 09 August 2011 (), +-- +-- +-- Notes: +-- +-- At present there is a lot of overlap with the N3 Parser. +-- +-- The parser needs to be updated to the latest working draft (10 July 2012, +-- ). +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Parser.Turtle + ( ParseResult + , parseTurtle + , parseTurtlefromText + {- + , parseAnyfromText + , parseTextFromText, parseAltFromText + , parseNameFromText -- , parsePrefixFromText + , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText + -} + + {- + -- * Exports for parsers that embed Turtle in a bigger syntax + , TurtleParser, TurtleState(..), SpecialMap + + , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions + , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct + , quickVariable -- was varid + , lexUriRef + , document, subgraph + , newBlankNode + -} + ) +where + +import Swish.GraphClass (arc) +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (makeNamespace, getScopeNamespace, getScopedNameURI + , getScopeNamespace, makeURIScopedName, makeNSScopedName) +import Swish.QName (newLName, emptyLName) + +import Swish.RDF.Graph + ( RDFGraph, RDFLabel(..) + , ToRDFLabel(..) + , NamespaceMap + , addArc + , setNamespaces + , emptyRDFGraph + ) + +import Swish.RDF.Vocabulary + ( LanguageTag + , toLangTag + , rdfType + , rdfFirst, rdfRest, rdfNil + , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble + , defaultBase + ) + +import Swish.RDF.Datatype (makeDatatypedLiteral) + +import Swish.RDF.Parser.Utils + ( ParseResult + , runParserWithError + , ignore + , noneOf + , char + , ichar + , string + , stringT + , symbol + , isymbol + , lexeme + , whiteSpace + , hex4 + , hex8 + , appendURIs + ) + +import Control.Applicative +import Control.Monad (foldM) + +import Data.Char (ord, isAsciiLower, isAsciiUpper, isDigit) +import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) +import Data.LookupMap (mapFindMaybe, mapAdd, mapReplace) +import Data.Maybe (fromMaybe, fromJust) +import Data.Word (Word32) + +import Network.URI (URI(..), parseURIReference) + +import Text.ParserCombinators.Poly.StateText + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | Turtle parser state +data TurtleState = TurtleState + { graphState :: RDFGraph -- Graph under construction + , prefixUris :: NamespaceMap -- namespace prefix mapping table + , baseUri :: URI -- base URI + , nodeGen :: Word32 -- blank node id generator + } deriving Show + +-- | Functions to update TurtleState vector (use with stUpdate) + +setPrefix :: Maybe T.Text -> URI -> TurtleState -> TurtleState +setPrefix pre uri st = st { prefixUris=p' } + where + p' = mapReplace (prefixUris st) (makeNamespace pre uri) + +-- | Change the base +setBase :: URI -> TurtleState -> TurtleState +setBase buri st = st { baseUri = buri } + +-- Functions to access state: + +-- | Return the default prefix +getDefaultPrefix :: TurtleParser Namespace +getDefaultPrefix = do + s <- stGet + case getPrefixURI s Nothing of + Just uri -> return $ makeNamespace Nothing uri + _ -> failBad "No default prefix defined; how unexpected (probably a programming error)!" + +-- Map prefix to URI (naming needs a scrub here) +getPrefixURI :: TurtleState -> Maybe T.Text -> Maybe URI +getPrefixURI st pre = mapFindMaybe pre (prefixUris st) + +findPrefixNamespace :: Maybe L.Text -> TurtleParser Namespace +findPrefixNamespace (Just p) = findPrefix (L.toStrict p) +findPrefixNamespace Nothing = getDefaultPrefix + +-- Return function to update graph in Turtle parser state, +-- using the supplied function of a graph +-- +updateGraph :: (RDFGraph -> RDFGraph) -> TurtleState -> TurtleState +updateGraph f s = s { graphState = f (graphState s) } + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +type TurtleParser a = Parser TurtleState a + +-- | Parse as Turtle (with no real base URI). +-- +-- See 'parseTurtle' if you need to provide a base URI. +-- +parseTurtlefromText :: + L.Text -- ^ input in N3 format. + -> ParseResult +parseTurtlefromText = flip parseTurtle Nothing + +-- | Parse a string with an optional base URI. +-- +-- Unlike 'parseN3' we treat the base URI as a URI and not +-- a QName. +-- +parseTurtle :: + L.Text -- ^ input in N3 format. + -> Maybe URI -- ^ optional base URI + -> ParseResult +parseTurtle txt mbase = parseAnyfromText turtleDoc mbase txt + +hashURI :: URI +hashURI = fromJust $ parseURIReference "#" + +emptyState :: + Maybe URI -- ^ starting base for the graph + -> TurtleState +emptyState mbase = + let pmap = LookupMap [makeNamespace Nothing hashURI] + buri = fromMaybe (getScopedNameURI defaultBase) mbase + in TurtleState + { graphState = emptyRDFGraph + , prefixUris = pmap + , baseUri = buri + , nodeGen = 0 + } + +-- | Function to supply initial context and parse supplied term. +-- +parseAnyfromText :: + TurtleParser a -- ^ parser to apply + -> Maybe URI -- ^ base URI of the input, or @Nothing@ to use default base value + -> L.Text -- ^ input to be parsed + -> Either String a +parseAnyfromText parser mbase = runParserWithError parser (emptyState mbase) + +newBlankNode :: TurtleParser RDFLabel +newBlankNode = do + n <- stQuery (succ . nodeGen) + stUpdate $ \s -> s { nodeGen = n } + return $ Blank (show n) + +{- +This has been made tricky by the attempt to remove the default list +of prefixes from the starting point of a parse and the subsequent +attempt to add every new namespace we come across to the parser state. + +So we add in the original default namespaces for testing, since +this routine is really for testing. + +addTestPrefixes :: TurtleParser () +addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map + +-} + +-- helper routines + +comma, semiColon , fullStop :: TurtleParser () +comma = isymbol "," +semiColon = isymbol ";" +fullStop = isymbol "." + +sQuot, dQuot, sQuot3, dQuot3 :: TurtleParser () +sQuot = ichar '\'' +dQuot = ichar '"' +sQuot3 = ignore $ string "'''" +dQuot3 = ignore $ string "\"\"\"" + +match :: (Ord a) => a -> [(a,a)] -> Bool +match v = any (\(l,h) -> v >= l && v <= h) + +-- a specialization of bracket +br :: String -> String -> TurtleParser a -> TurtleParser a +br lsym rsym = bracket (symbol lsym) (symbol rsym) + +-- this is a lot simpler than N3 +atWord :: T.Text -> TurtleParser () +atWord s = char '@' *> lexeme (stringT s) *> pure () + +{- +Add statement to graph in the parser state; there is a special case +for the special-case literals in the grammar since we need to ensure +the necessary namespaces (in other words xsd) are added to the +namespace store. +-} + +addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> TurtleParser () +addStatement s p o@(TypedLit _ dtype) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do + ost <- stGet + let stmt = arc s p o + oldp = prefixUris ost + ogs = graphState ost + newp = mapReplace oldp (getScopeNamespace dtype) + stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } +addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) + +isaz, isAZ, isaZ, is09, isaZ09 :: Char -> Bool +isaz = isAsciiLower +isAZ = isAsciiUpper +isaZ c = isaz c || isAZ c +is09 = isDigit +isaZ09 c = isaZ c || is09 c + +{- +Convert a string representing a double into canonical +XSD form. The input string is assumed to be syntactically +valid so we use read rather than reads. We use the String read +rather than Text one because of issues I have had in some tests +with the accuracy of the Text one. +-} +d2s :: L.Text -> RDFLabel +d2s = + let conv :: String -> Double + conv = read + in toRDFLabel . conv . L.unpack + +{- +Since operatorLabel can be used to add a label with an +unknown namespace, we need to ensure that the namespace +is added if not known. If the namespace prefix is already +in use then it is over-written (rather than add a new +prefix for the label). + +TODO: + - could we use the reverse lookupmap functionality to + find if the given namespace URI is in the namespace + list? If it is, use it's key otherwise do a + mapReplace for the input namespace. + +-} +operatorLabel :: ScopedName -> TurtleParser RDFLabel +operatorLabel snam = do + st <- stGet + let sns = getScopeNamespace snam + opmap = prefixUris st + pkey = entryKey sns + pval = entryVal sns + + rval = Res snam + + -- the lookup and the replacement could be fused + case mapFindMaybe pkey opmap of + Just val | val == pval -> return rval + | otherwise -> do + stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } + return rval + + _ -> do + stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } + return rval + +findPrefix :: T.Text -> TurtleParser Namespace +findPrefix pre = do + st <- stGet + case mapFindMaybe (Just pre) (prefixUris st) of + Just uri -> return $ makeNamespace (Just pre) uri + Nothing -> failBad $ "Undefined prefix '" ++ T.unpack pre ++ ":'." + +{- + +Syntax productions; the Turtle NBF grammar elements are from +http://www.w3.org/TR/turtle/turtle.bnf + +The element names are converted to match Haskell syntax +and idioms where possible: + + - camel Case rather than underscores and all upper case + + - upper-case identifiers prepended by _ after above form + +-} + +{- +[1] turtleDoc ::= (statement)* +-} +turtleDoc :: TurtleParser RDFGraph +turtleDoc = mkGr <$> (whiteSpace *> many statement *> eof *> stGet) + where + mkGr s = setNamespaces (prefixUris s) (graphState s) + +{- +[2] statement ::= directive "." + | triples "." +-} +statement :: TurtleParser () +statement = (directive <|> triples) *> fullStop + +{- +[3] directive ::= prefixID + | base +-} +directive :: TurtleParser () +directive = lexeme (prefixID <|> base) + +{- +[4] prefixID ::= PREFIX PNAME_NS IRI_REF +-} +prefixID :: TurtleParser () +prefixID = do + _prefix + p <- lexeme _pnameNS + u <- _iriRef + stUpdate (setPrefix (fmap L.toStrict p) u) + +{- +[5] base ::= BASE IRI_REF +-} +base :: TurtleParser () +base = _base >> _iriRef >>= stUpdate . setBase + +{- +[6] triples ::= subject predicateObjectList +-} + +triples :: TurtleParser () +triples = subject >>= predicateObjectList + +{- +[7] predicateObjectList ::= verb objectList ( ";" verb objectList )* (";")? +-} + +predicateObjectList :: RDFLabel -> TurtleParser () +predicateObjectList subj = + let term = verb >>= objectList subj + in sepBy1 term semiColon *> ignore (optional semiColon) + -- in sepBy1 (lexeme term) semiColon *> ignore (optional semiColon) + +{- +[8] objectList ::= object ( "," object )* +-} + +objectList :: RDFLabel -> RDFLabel -> TurtleParser () +objectList subj prd = sepBy1 object comma >>= mapM_ (addStatement subj prd) + +{- +[9] verb ::= predicate + | "a" +-} + +verb :: TurtleParser RDFLabel +verb = predicate <|> (lexeme (char 'a') *> operatorLabel rdfType) + +{- +[10] subject ::= IRIref + | blank +-} + +subject :: TurtleParser RDFLabel +subject = (Res <$> iriref) <|> blank + +{- +[11] predicate ::= IRIref +-} + +predicate :: TurtleParser RDFLabel +predicate = Res <$> iriref + +{- +[12] object ::= IRIref + | blank + | literal +-} + +object :: TurtleParser RDFLabel +object = (Res <$> iriref) <|> blank <|> literal + +{- +[13] literal ::= RDFLiteral + | NumericLiteral + | BooleanLiteral +-} + +literal :: TurtleParser RDFLabel +literal = lexeme $ rdfLiteral <|> numericLiteral <|> booleanLiteral + +{- +[14] blank ::= BlankNode + | blankNodePropertyList + | collection + +Since both BlankNode and blankNodePropertyList can match '[ ... ]' we pull +that out and treat this as + + blank ::= BLANK_NODE_LABEL + | "[" (predicateObjectList | WS*) "]" + | collection + +blank :: TurtleParser RDFLabel +blank = lexeme (blankNode <|> blankNodePropertyList <|> collection) + +-} + +blank :: TurtleParser RDFLabel +blank = lexeme (_blankNodeLabel + <|> + bracket (char '[') (char ']') handleBlankNode + <|> + collection + ) + +{- +[15] blankNodePropertyList ::= "[" predicateObjectList "]" + +We now match the brackets in the parent rule. + +blankNodePropertyList :: TurtleParser RDFLabel +blankNodePropertyList = do + bNode <- newBlankNode + -- br "[" "]" (predicateObjectList bNode) + bracket (satisfy (=='[')) + (satisfy (==']')) + (_manyws *> predicateObjectList bNode *> _manyws) + -- ignore (optional _manyws) -- TODO: this is a hack + return bNode + +-} + +handleBlankNode :: TurtleParser RDFLabel +handleBlankNode = do + bNode <- newBlankNode + _manyws + ignore $ optional $ predicateObjectList bNode + _manyws + return bNode + + +{- +[16] collection ::= "(" object* ")" +-} + +collection :: TurtleParser RDFLabel +collection = do + os <- br "(" ")" (many object) + eNode <- operatorLabel rdfNil + case os of + [] -> return eNode + + (x:xs) -> do + sNode <- newBlankNode + first <- operatorLabel rdfFirst + addStatement sNode first x + lNode <- foldM addElem sNode xs + rest <- operatorLabel rdfRest + addStatement lNode rest eNode + return sNode + + where + addElem prevNode curElem = do + bNode <- newBlankNode + first <- operatorLabel rdfFirst + rest <- operatorLabel rdfRest + addStatement prevNode rest bNode + addStatement bNode first curElem + return bNode + +{- +[17] ::= "@base" +-} + +_base :: TurtleParser () +_base = atWord "base" + +{- +[18] ::= "@prefix" +-} + +_prefix :: TurtleParser () +_prefix = atWord "prefix" + +{- +[19] ::= ( "\\u" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) + | ( "\\U" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] + [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) + +-} + +_uchar :: TurtleParser Char +_uchar = char '\\' *> _uchar' + +_uchar' :: TurtleParser Char +_uchar' = (char 'u' *> hex4) <|> (char 'U' *> hex8) + +{- +[60s] RDFLiteral ::= String ( LANGTAG | ( "^^" IRIref ) )? +-} + +rdfLiteral :: TurtleParser RDFLabel +rdfLiteral = do + lbl <- L.toStrict <$> turtleString + opt <- optional ((Left <$> _langTag) <|> (string "^^" *> (Right <$> iriref))) + return $ case opt of + Just (Left lcode) -> LangLit lbl lcode + Just (Right dtype) -> TypedLit lbl dtype + _ -> Lit lbl + +{- +[61s] NumericLiteral ::= NumericLiteralUnsigned + | NumericLiteralPositive + | NumericLiteralNegative +-} + +numericLiteral :: TurtleParser RDFLabel +numericLiteral = numericLiteralNegative <|> numericLiteralPositive <|> numericLiteralUnsigned + +{- +[62s] NumericLiteralUnsigned ::= INTEGER + | DECIMAL + | DOUBLE +-} + +numericLiteralUnsigned :: TurtleParser RDFLabel +numericLiteralUnsigned = + d2s <$> _double + <|> + (makeDatatypedLiteral xsdDecimal . L.toStrict <$> _decimal) + <|> + (makeDatatypedLiteral xsdInteger . L.toStrict <$> _integer) + +{- +[63s] NumericLiteralPositive ::= INTEGER_POSITIVE + | DECIMAL_POSITIVE + | DOUBLE_POSITIVE +-} + +numericLiteralPositive :: TurtleParser RDFLabel +numericLiteralPositive = + d2s <$> _doublePositive + <|> + (makeDatatypedLiteral xsdDecimal . L.toStrict <$> _decimalPositive) + <|> + (makeDatatypedLiteral xsdInteger . L.toStrict <$> _integerPositive) + +{- +[64s] NumericLiteralNegative ::= INTEGER_NEGATIVE + | DECIMAL_NEGATIVE + | DOUBLE_NEGATIVE +-} + +numericLiteralNegative :: TurtleParser RDFLabel +numericLiteralNegative = + d2s <$> _doubleNegative + <|> + (makeDatatypedLiteral xsdDecimal . L.toStrict <$> _decimalNegative) + <|> + (makeDatatypedLiteral xsdInteger . L.toStrict <$> _integerNegative) + +{- +[65s] BooleanLiteral ::= "true" + | "false" +-} + +booleanLiteral :: TurtleParser RDFLabel +booleanLiteral = makeDatatypedLiteral xsdBoolean . T.pack <$> (string "true" <|> string "false") + +{- +[66s] String ::= STRING_LITERAL1 + | STRING_LITERAL2 + | STRING_LITERAL_LONG1 + | STRING_LITERAL_LONG2 +-} + +turtleString :: TurtleParser L.Text +turtleString = + lexeme ( + _stringLiteralLong1 <|> _stringLiteral1 <|> + _stringLiteralLong2 <|> _stringLiteral2) + +{- +[67s] IRIref ::= IRI_REF + | PrefixedName +-} + +iriref :: TurtleParser ScopedName +iriref = lexeme ((makeURIScopedName <$> _iriRef) <|> prefixedName) + +{- +[68s] PrefixedName ::= PNAME_LN + | PNAME_NS +-} + +prefixedName :: TurtleParser ScopedName +prefixedName = + _pnameLN <|> + flip makeNSScopedName emptyLName <$> (_pnameNS >>= findPrefixNamespace) + +{- +[69s] BlankNode ::= BLANK_NODE_LABEL + | ANON + +blankNode :: TurtleParser RDFLabel +blankNode = lexeme (_blankNodeLabel <|> _anon) + +-} + +{- +[70s] ::= "<" ( [^<>\"{}|^`\\] - [#0000- ] | UCHAR )* ">" + +Read [#0000- ] as [#x00-#x20] from +http://lists.w3.org/Archives/Public/public-rdf-comments/2011Aug/0011.html + +Unlike N3, whitespace is significant within the surrounding <>. + +At present relying on Network.URI to define what characters are valid +in a URI. This is not necessarily ideal. +-} + +_iriRef :: TurtleParser URI +_iriRef = do + utxt <- bracket (char '<') (char '>') $ manySatisfy (/= '>') -- TODO: fix + let ustr = L.unpack utxt + case parseURIReference ustr of + Nothing -> fail $ "Unable to convert <" ++ ustr ++ "> to a URI" + Just uref -> do + s <- stGet + either fail return $ appendURIs (baseUri s) uref + +{- +[71s] ::= (PN_PREFIX)? ":" +-} + +_pnameNS :: TurtleParser (Maybe L.Text) +_pnameNS = optional _pnPrefix <* char ':' + +{- +[72s] ::= PNAME_NS PN_LOCAL +-} + +_pnameLN :: TurtleParser ScopedName +_pnameLN = do + ns <- _pnameNS >>= findPrefixNamespace + l <- fmap L.toStrict _pnLocal + case newLName l of + Just lname -> return $ makeNSScopedName ns lname + _ -> fail $ "Invalid local name: '" ++ T.unpack l ++ "'" + +{- +[73s] ::= "_:" PN_LOCAL +-} + +_blankNodeLabel :: TurtleParser RDFLabel +_blankNodeLabel = (Blank . L.unpack) <$> (string "_:" *> _pnLocal) + +{- + +These are unused in the grammar. + +[74s] ::= "?" VARNAME +[75s] ::= "$" VARNAME +-} + +{- +[76s] ::= BASE + | PREFIX + | "@" [a-zA-Z]+ ( "-" [a-zA-Z0-9]+ )* + +I am ignoring the BASE and PREFIX lines here as they don't make sense to me. +-} + +-- Note that toLangTag may fail since it does some extra +-- validation not done by the parser (mainly on the length of the +-- primary and secondary tags). +-- +-- NOTE: This parser does not accept multiple secondary tags which RFC3066 +-- does. +-- +_langTag :: TurtleParser LanguageTag +_langTag = do + ichar '@' + h <- many1Satisfy isaZ + mt <- optional (L.cons <$> char '-' <*> many1Satisfy isaZ09) + let lbl = L.toStrict $ L.append h $ fromMaybe L.empty mt + case toLangTag lbl of + Just lt -> return lt + _ -> fail ("Invalid language tag: " ++ T.unpack lbl) -- should this be failBad? + +{- +[77s] ::= [0-9]+ +-} + +_integer :: TurtleParser L.Text +_integer = many1Satisfy is09 + +{- +[78s] ::= [0-9]+ "." [0-9]* + | "." [0-9]+ + +We try to produce a canonical form for the +numbers. +-} + +_decimal :: TurtleParser L.Text +_decimal = + let dpart = L.cons <$> char '.' <*> (fromMaybe "0" <$> optional _integer) + in + (L.append <$> _integer <*> dpart) + <|> + (L.append "0." <$> (char '.' *> _integer)) + +{- +[79s] ::= [0-9]+ "." [0-9]* EXPONENT + | "." ( [0-9] )+ EXPONENT + | ( [0-9] )+ EXPONENT + +Unlike _decimal, the canonical form is enforced +later on, although it could be done here. +-} + +_double :: TurtleParser L.Text +_double = + (L.append <$> _decimal <*> _exponent) + <|> + (L.append <$> _integer <*> _exponent) + +{- +[80s] ::= "+" INTEGER +[81s] ::= "+" DECIMAL +[82s] ::= "+" DOUBLE +-} + +_integerPositive, _decimalPositive, _doublePositive :: TurtleParser L.Text +_integerPositive = char '+' *> _integer +_decimalPositive = char '+' *> _decimal +_doublePositive = char '+' *> _double + +{- +[83s] ::= "-" INTEGER +[84s] ::= "-" DECIMAL +[85s] ::= "-" DOUBLE +-} + +_integerNegative, _decimalNegative, _doubleNegative :: TurtleParser L.Text +_integerNegative = L.cons <$> char '-' <*> _integer +_decimalNegative = L.cons <$> char '-' <*> _decimal +_doubleNegative = L.cons <$> char '-' <*> _double + +{- +[86s] ::= [eE] [+-]? [0-9]+ +-} + +_exponent :: TurtleParser L.Text +_exponent = do + ignore $ satisfy (`elem` "eE") + ms <- optional (satisfy (`elem` "+-")) + e <- _integer + case ms of + Just '-' -> return $ L.append "E-" e + _ -> return $ L.cons 'E' e + +{- +[87s] ::= "'" ( ( [^'\\\n\r] ) | ECHAR | UCHAR )* "'" +[88s] ::= '"' ( ( [^\"\\\n\r] ) | ECHAR | UCHAR )* '"' +[89s] ::= "'''" ( ( "'" | "''" )? ( [^'\\] | ECHAR | UCHAR ) )* "'''" +[90s] ::= '"""' ( ( '"' | '""' )? ( [^\"\\] | ECHAR | UCHAR ) )* '"""' +-} + +_stringLiteral1, _stringLiteral2 :: TurtleParser L.Text +_stringLiteral1 = _stringIt sQuot (_tChars "'\\\n\r") +_stringLiteral2 = _stringIt dQuot (_tChars "\"\\\n\r") + +_stringLiteralLong1, _stringLiteralLong2 :: TurtleParser L.Text +_stringLiteralLong1 = _stringItLong sQuot3 (_tCharsLong '\'' "'\\") +_stringLiteralLong2 = _stringItLong dQuot3 (_tCharsLong '"' "\"\\") + +_stringIt :: TurtleParser a -> TurtleParser Char -> TurtleParser L.Text +_stringIt sep chars = L.pack <$> bracket sep sep (many chars) + +_stringItLong :: TurtleParser a -> TurtleParser L.Text -> TurtleParser L.Text +_stringItLong sep chars = L.concat <$> bracket sep sep (many chars) + +_tChars :: String -> TurtleParser Char +_tChars excl = (char '\\' *> (_echar' <|> _uchar')) + <|> noneOf excl + +_tCharsLong :: Char -> String -> TurtleParser L.Text +_tCharsLong c excl = do + mq <- optional $ oneOrTwo c + r <- _tChars excl + return $ L.append (fromMaybe L.empty mq) (L.singleton r) + +oneOrTwo :: Char -> TurtleParser L.Text +oneOrTwo c = do + a <- char c + mb <- optional (char c) + case mb of + Just b -> return $ L.pack [a,b] + _ -> return $ L.singleton a + +{- +[91s] ::= "\\" [tbnrf\\\"'] +-} + +_echar :: TurtleParser Char +_echar = char '\\' *> _echar' + +_echar' :: TurtleParser Char +_echar' = + (char 't' *> pure '\t') <|> + (char 'b' *> pure '\b') <|> + (char 'n' *> pure '\n') <|> + (char 'r' *> pure '\r') <|> + (char '\\' *> pure '\\') <|> + (char '"' *> pure '"') <|> + (char '\'' *> pure '\'') + + +{- + +Unused. + +[92s] ::= "(" (WS)* ")" +-} + +{- +[93s] ::= " " + | "\t" + | "\r" + | "\n" + +_ws :: TurtleParser () +_ws = ignore $ satisfy (`elem` " \t\r\n") + +-} + +_manyws :: TurtleParser () +_manyws = ignore $ manySatisfy (`elem` " \t\r\n") + +{- +[94s] ::= "[" (WS)* "]" + +Unused as we do not support the use of ANON in the BlankNode +terminal. + +_anon :: TurtleParser RDFLabel +_anon = br "[" "]" _manyws *> newBlankNode + +-} + +{- +[95s] ::= [A-Z] + | [a-z] + | [#00C0-#00D6] + | [#00D8-#00F6] + | [#00F8-#02FF] + | [#0370-#037D] + | [#037F-#1FFF] + | [#200C-#200D] + | [#2070-#218F] + | [#2C00-#2FEF] + | [#3001-#D7FF] + | [#F900-#FDCF] + | [#FDF0-#FFFD] + | [#10000-#EFFFF] + | UCHAR + +TODO: may want to make this a Char -> Bool selector for +use with manySatisfy rather than a combinator. +-} + +_pnCharsBase :: TurtleParser Char +_pnCharsBase = + let f c = let i = ord c + in isaZ c || + match i [(0xc0, 0xd6), (0xd8, 0xf6), (0xf8, 0x2ff), + (0x370, 0x37d), (0x37f, 0x1fff), (0x200c, 0x200d), + (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), + (0xf900, 0xfdcf), (0xfdf0, 0xfffd), (0x10000, 0xeffff)] + in satisfy f <|> _uchar + +{- +[96s] ::= PN_CHARS_BASE + | "_" +-} + +_pnCharsU :: TurtleParser Char +_pnCharsU = _pnCharsBase <|> char '_' + +{- + +Only used in VAR1/2 rules which are themselves unused. + +Unused in the grammar (other than +[97s] ::= ( PN_CHARS_U | [0-9] ) ( PN_CHARS_U | [0-9] | #00B7 | [#0300-#036F] | [# + 203F-#2040] )* +-} + +{- +[98s] ::= PN_CHARS_U + | "-" + | [0-9] + | #00B7 + | [#0300-#036F] + | [#203F-#2040] +-} + +_pnChars :: TurtleParser Char +_pnChars = + _pnCharsU + <|> + satisfy (\c -> let i = ord c + in c == '-' || isDigit c || i == 0xb7 || + match i [(0x0300, 0x036f), (0x203f, 0x2040)]) + +{- +[99s] ::= PN_CHARS_BASE ( ( PN_CHARS | "." )* PN_CHARS )? +-} + +_pnPrefix :: TurtleParser L.Text +_pnPrefix = L.cons <$> _pnCharsBase <*> _pnRest + +{- +[100s] ::= ( PN_CHARS_U | [0-9] ) ( ( PN_CHARS | "." )* PN_CHARS )? +-} + +_pnLocal :: TurtleParser L.Text +_pnLocal = L.cons <$> (_pnCharsU <|> satisfy is09) + <*> _pnRest + +{- +Extracted from PN_PREFIX and PN_LOCAL is + + :== ( ( PN_CHARS | "." )* PN_CHARS )? + +We assume below that the match is only ever done for small strings, so +the cost of the foldr isn't likely to be large. Let's see how well +this assumption holds up. + +-} + +_pnRest :: TurtleParser L.Text +_pnRest = do + lbl <- many (_pnChars <|> char '.') + let (nret, lclean) = clean lbl + + -- a simple difference list implementation + edl = id + snocdl x xs = xs . (x:) + appenddl = (.) + replicatedl n x = (replicate n x ++) + + -- this started out as a simple automaton/transducer from + -- http://www.haskell.org/pipermail/haskell-cafe/2011-September/095347.html + -- but then I decided to complicate it + -- + clean :: String -> (Int, String) + clean = go 0 edl + where + go n acc [] = (n, acc []) + go n acc ('.':xs) = go (n+1) acc xs + go 0 acc (x:xs) = go 0 (snocdl x acc) xs + go n acc (x:xs) = go 0 (appenddl acc (snocdl x (replicatedl n '.'))) xs + + reparse $ L.replicate (fromIntegral nret) (L.singleton '.') + return $ L.pack lclean + +{- +Original from + + chop = go 0 [] + where + -- go :: State -> Stack -> String -> String + go 0 _ [] = [] + go 0 _ (x:xs) + | isSpace x = go 1 [x] xs + | otherwise = x : go 0 xs + + go 1 ss [] = [] + go 1 ss (x:xs) + | isSpace c = go 1 (x:ss) xs + | otherwise = reverse ss ++ x : go 0 xs + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Parser/Utils.hs b/src/Swish/RDF/Parser/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Parser/Utils.hs @@ -0,0 +1,385 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Utils +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- Support for the RDF Parsing modules. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Parser.Utils + ( SpecialMap + -- , mapPrefix + + -- tables + , prefixTable, specialTable + + -- parser + , runParserWithError + , ParseResult + , ignore + , char + , ichar + , string + , stringT + , symbol + , isymbol + , lexeme + , notFollowedBy + , whiteSpace + , skipMany + , skipMany1 + , endBy + , sepEndBy + , sepEndBy1 + , manyTill + , noneOf + , eoln + , fullStop + , hex4 + , hex8 + , appendURIs + ) + where + +import Swish.Namespace (Namespace, makeNamespace, ScopedName) + +import Swish.RDF.Graph (RDFGraph) +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceOWL + , namespaceLOG + , rdfType + , rdfFirst, rdfRest, rdfNil + , owlSameAs, logImplies + , defaultBase + ) + +import Data.Char (isSpace, isHexDigit, chr) +import Data.LookupMap (LookupMap(..)) +import Data.Maybe (fromMaybe, fromJust) + +import Network.URI (URI(..), relativeTo, parseURIReference) + +import Text.ParserCombinators.Poly.StateText + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Read as R + +-- Code + +-- | Append the two URIs. Should probably be moved +-- out of RDFParser. It is also just a thin wrapper around +-- `Network.URI.relativeTo`. +appendURIs :: + URI -- ^ The base URI + -> URI -- ^ The URI to append (it can be an absolute URI). + -> Either String URI +appendURIs base uri = + case uriScheme uri of + "" -> case uri `relativeTo` base of + Just out -> Right out + _ -> Left $ "Unable to append <" ++ show uri ++ "> to base=<" ++ show base ++ ">" + _ -> Right uri + +-- | Type for special name lookup table +type SpecialMap = LookupMap (String, ScopedName) + +{- +-- | Lookup prefix in table and return the matching URI. +-- +-- If the prefix is unknown then we currently error +-- out (used to return 'prefix:' or ':' but now using +-- URIs I am changing this behavior). This may well be +-- backed out. +mapPrefix :: NamespaceMap -> Maybe String -> URI +mapPrefix pmap pfix = + case mapFindMaybe pfix pmap of + Just uri -> uri + Nothing -> error $ "Unable to find prefix: " ++ show pfix -- fromMaybe "" pfix ++ ":" +-} + +{- +mapPrefix ps p@(Just pre) = mapFind (pre++":") p ps +mapPrefix ps _ = mapFind ":" Nothing ps +-} + +-- | Define default table of namespaces +prefixTable :: [Namespace] +prefixTable = [ namespaceRDF + , namespaceRDFS + , namespaceRDFD -- datatypes + , namespaceOWL + , namespaceLOG + , makeNamespace Nothing $ fromJust (parseURIReference "#") -- is this correct? + ] + +-- | Define default special-URI table. +specialTable :: + Maybe ScopedName -- ^ initial base URI, otherwise uses 'defaultBase' + -> [(String,ScopedName)] +specialTable mbase = + [ ("a", rdfType ), + ("equals", owlSameAs ), + ("implies", logImplies ), + ("listfirst", rdfFirst ), + ("listrest", rdfRest ), + ("listnull", rdfNil ), + ("base", fromMaybe defaultBase mbase ) + ] + +-- Parser routines, heavily based on Parsec combinators + +-- | Run the parser and return the successful parse or an error +-- message which consists of the standard Polyparse error plus +-- a fragment of the unparsed input to provide context. +-- +runParserWithError :: + Parser a b -- ^ parser (carrying state) to apply + -> a -- ^ starting state for the parser + -> L.Text -- ^ input to be parsed + -> Either String b +runParserWithError parser state0 input = + let (result, _, unparsed) = runParser parser state0 input + + -- TODO: work out how best to report error context; for now just take the + -- next 40 characters and assume there is enough context. + econtext = if L.null unparsed + then "\n(at end of the text)\n" + else "\nRemaining input:\n" ++ + case L.compareLength unparsed 40 of + GT -> L.unpack (L.take 40 unparsed) ++ "..." + _ -> L.unpack unparsed + + in case result of + Left emsg -> Left $ emsg ++ econtext + _ -> result + +-- | The result of a parse, which is either an error message or a graph. +type ParseResult = Either String RDFGraph + + +-- | Run the parser and ignore the result. +ignore :: (Applicative f) => f a -> f () +ignore f = f *> pure () + +-- | Match the character. +char :: Char -> Parser s Char +char c = satisfy (==c) + +-- | Match the character, ignoring the result. +ichar :: Char -> Parser s () +ichar = ignore . char + +-- TODO: is there a better way to do this? +-- | Match the text. +string :: String -> Parser s String +string = mapM char + +-- | Match the text. +stringT :: T.Text -> Parser s T.Text +stringT s = string (T.unpack s) >> return s + +-- | Run the parser 'many' times and ignore the result. +skipMany :: Parser s a -> Parser s () +skipMany = ignore . many + +-- | Run the parser 'many1' times and ignore the result. +skipMany1 :: Parser s a -> Parser s () +skipMany1 = ignore . many1 + +-- | Match zero or more occurences of +-- parser followed by separator. +endBy :: + Parser s a -- ^ parser + -> Parser s b -- ^ separator + -> Parser s [a] +endBy p sep = many (p <* sep) + +-- | Match zero or more occurences of the parser followed +-- by the separator. +sepEndBy :: + Parser s a -- ^ parser + -> Parser s b -- ^ separator + -> Parser s [a] +sepEndBy p sep = sepEndBy1 p sep <|> pure [] + +-- | Accept one or more occurences of the parser +-- separated by the separator. Unlike 'endBy' the +-- last separator is optional. +sepEndBy1 :: + Parser s a -- ^ parser + -> Parser s b -- ^ separator + -> Parser s [a] +sepEndBy1 p sep = do + x <- p + (sep *> ((x:) <$> sepEndBy p sep)) <|> return [x] + +-- | Accept zero or more runs of the parser +-- ending with the delimiter. +manyTill :: + Parser s a -- ^ parser + -> Parser s b -- ^ delimiter + -> Parser s [a] +manyTill p end = go + where + go = (end *> return []) + <|> + ((:) <$> p <*> go) + +-- | Accept any character that is not a member of the given string. +noneOf :: String -> Parser s Char +noneOf istr = satisfy (`notElem` istr) + +-- | Matches '.'. +fullStop :: Parser s () +fullStop = ichar '.' + +-- | Match the end-of-line sequence (@"\\n"@, @"\\r"@, or @"\\r\\n"@). +eoln :: Parser s () +-- eoln = ignore (newline <|> (lineFeed *> optional newline)) +-- eoln = ignore (try (string "\r\n") <|> string "\r" <|> string "\n") +eoln = ignore (oneOf [string "\r\n", string "\r", string "\n"]) + +-- | Succeed if the next character does not match the given function. +notFollowedBy :: (Char -> Bool) -> Parser s () +notFollowedBy p = do + c <- next + if p c + then fail $ "Unexpected character: " ++ show [c] + else reparse $ L.singleton c + +-- | Match the given string and any trailing 'whiteSpace'. +symbol :: String -> Parser s String +symbol = lexeme . string + +-- | As 'symbol' but ignoring the result. +isymbol :: String -> Parser s () +isymbol = ignore . symbol + +-- | Convert a parser into one that also matches, and ignores, +-- trailing 'whiteSpace'. +lexeme :: Parser s a -> Parser s a +lexeme p = p <* whiteSpace + +-- | Match white space: a space or a comment (@#@ character and anything following it +-- up to to a new line). +whiteSpace :: Parser s () +whiteSpace = skipMany (simpleSpace <|> oneLineComment) + +simpleSpace :: Parser s () +simpleSpace = ignore $ many1Satisfy isSpace + +-- TODO: this should use eoln rather than a check on \n +oneLineComment :: Parser s () +oneLineComment = ichar '#' *> manySatisfy (/= '\n') *> pure () + +{- + +Not sure we can get this with polyparse + +-- | Annotate a Parsec error with the local context - i.e. the actual text +-- that caused the error and preceeding/succeeding lines (if available) +-- +annotateParsecError :: + Int -- ^ the number of extra lines to include in the context (<=0 is ignored) + -> [String] -- ^ text being parsed + -> ParseError -- ^ the parse error + -> String -- ^ Parsec error with additional context +annotateParsecError extraLines ls err = + -- the following is based on the show instance of ParseError + let ePos = errorPos err + lNum = sourceLine ePos + cNum = sourceColumn ePos + -- it is possible to be at the end of the input so need + -- to check; should produce better output than this in this + -- case + nLines = length ls + ln1 = lNum - 1 + eln = max 0 extraLines + lNums = [max 0 (ln1 - eln) .. min (nLines-1) (ln1 + eln)] + + beforeLines = map (ls !!) $ filter (< ln1) lNums + afterLines = map (ls !!) $ filter (> ln1) lNums + + -- in testing was able to get a line number after the text so catch this + -- case; is it still necessary? + errorLine = if ln1 >= nLines then "" else ls !! ln1 + arrowLine = replicate (cNum-1) ' ' ++ "^" + finalLine = "(line " ++ show lNum ++ ", column " ++ show cNum ++ " indicated by the '^' sign above):" + + eHdr = "" : beforeLines ++ errorLine : arrowLine : afterLines ++ [finalLine] + eMsg = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" + (errorMessages err) + + in unlines eHdr ++ eMsg + +-} + +{- +Handle hex encoding; the spec for N3 and NTriples suggest that +only upper-case A..F are valid but you can find lower-case values +out there so support these too. +-} + +hexDigit :: Parser a Char +-- hexDigit = satisfy (`elem` ['0'..'9'] ++ ['A'..'F']) +hexDigit = satisfy isHexDigit + +-- | A four-digit hex value (e.g. @1a34@ or @03F1@). +hex4 :: Parser a Char +hex4 = do + digs <- exactly 4 hexDigit + let mhex = R.hexadecimal (T.pack digs) + case mhex of + Left emsg -> failBad $ "Internal error: unable to parse hex4: " ++ emsg + Right (v, "") -> return $ chr v + Right (_, vs) -> failBad $ "Internal error: hex4 remainder = " ++ T.unpack vs + +-- | An eight-digit hex value that has a maximum of @0010FFFF@. +hex8 :: Parser a Char +hex8 = do + digs <- exactly 8 hexDigit + let mhex = R.hexadecimal (T.pack digs) + case mhex of + Left emsg -> failBad $ "Internal error: unable to parse hex8: " ++ emsg + Right (v, "") -> if v <= 0x10FFFF + then return $ chr v + else failBad "\\UHHHHHHHH format is limited to a maximum of \\U0010FFFF" + Right (_, vs) -> failBad $ "Internal error: hex8 remainder = " ++ T.unpack vs + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Proof.hs b/src/Swish/RDF/Proof.hs --- a/src/Swish/RDF/Proof.hs +++ b/src/Swish/RDF/Proof.hs @@ -1,279 +1,357 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE UndecidableInstances #-} + -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Proof --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : H98 --- --- This module defines a framework for constructing proofs --- over some expression form. It is intended to be used --- with RDF graphs, but the structures aim to be quite --- generic with respect to the expression forms allowed. +-- Portability : FlexibleInstances, UndecidableInstances -- --- It does not define any proof-finding strategy. +-- This module instantiates the 'Proof' framework for +-- constructing proofs over 'RDFGraph' expressions. +-- The intent is that this can be used to test some +-- correspondences between the RDF Model theory and +-- corresponding proof theory based on closure rules +-- applied to the graph, per . -- -------------------------------------------------------------------------------- module Swish.RDF.Proof - ( Proof(..), Step(..) - , checkProof, explainProof, checkStep, showProof, showsProof, showsFormula ) + ( RDFProof, RDFProofStep + , makeRDFProof, makeRDFProofStep + , makeRdfInstanceEntailmentRule + , makeRdfSubgraphEntailmentRule + , makeRdfSimpleEntailmentRule ) where -import Swish.RDF.Ruleset (Ruleset(..)) +import Swish.GraphClass (Label(..), LDGraph(..)) +import Swish.Namespace (ScopedName) +import Swish.Proof (Proof(..), Step(..)) +import Swish.Rule (Expression(..), Rule(..)) +import Swish.VarBinding (makeVarBinding) -import Swish.RDF.Rule - ( Expression(..), Formula(..), Rule(..) - , showsFormula, showsFormulae ) +import Swish.RDF.Graph (RDFLabel(..), RDFGraph) +import Swish.RDF.Graph (merge, allLabels, remapLabelList) +import Swish.RDF.Query (rdfQueryInstance, rdfQuerySubs) +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) -import Swish.Utils.ShowM (ShowM(..)) +import Swish.Utils.ListHelpers (subset, flist) -import Swish.Utils.ListHelpers (subset) +import Data.List (subsequences) +import Data.LookupMap (makeLookupMap, mapFind) +import Data.Monoid (Monoid(..)) -import Data.List (union, intersect, intercalate, foldl') -import Data.Maybe (catMaybes, isNothing) +------------------------------------------------------------ +-- Type instantiation of Proof framework for RDFGraph data +------------------------------------------------------------ +-- +-- This is a partial instantiation of the proof framework. +-- Details for applying inference rules are specific to the +-- graph instance type. ------------------------------------------------------------ --- Proof framework +-- Proof datatypes for graph values ------------------------------------------------------------ --- |Step in proof chain --- --- The display name for a proof step comes from the display name of its --- consequence formula. -data Step ex = Step - { stepRule :: Rule ex -- ^ Inference rule used - , stepAnt :: [Formula ex] -- ^ Antecedents of inference rule - , stepCon :: Formula ex -- ^ Named consequence of inference rule - } deriving Show +-- The following is an orphan instance --- |Proof is a structure that presents a chain of rule applications --- that yield a result expression from a given expression -data Proof ex = Proof - { proofContext :: [Ruleset ex] -- ^ Proof context: list of rulesets, - -- each of which provides a number of - -- axioms and rules. - , proofInput :: Formula ex -- ^ Given expression - , proofResult :: Formula ex -- ^ Result expression - , proofChain :: [Step ex] -- ^ Chain of inference rule applications - -- progressing from input to result - } +-- |Instances of 'LDGraph' are also instance of the +-- @Expression@ class, for which proofs can be constructed. +-- The empty RDF graph is always @True@ (other enduring +-- truths are asserted as axioms). +instance (Label lb, LDGraph lg lb) => Expression (lg lb) where + isValid = null . getArcs --- |Return a list of axioms from all the rulesets in a proof -proofAxioms :: Proof a -> [Formula a] -proofAxioms = concatMap rsAxioms . proofContext +------------------------------------------------------------ +-- Define RDF-specific types for proof framework +------------------------------------------------------------ --- |Return a list of rules from all the rulesets in a proof -proofRules :: Proof a -> [Rule a] -proofRules = concatMap rsRules . proofContext +-- | An RDF proof. +type RDFProof = Proof RDFGraph --- |Return list of axioms actually referenced by a proof -proofAxiomsUsed :: Proof ex -> [Formula ex] -proofAxiomsUsed proof = foldl' union [] $ map stepAxioms (proofChain proof) - where - stepAxioms st = stepAnt st `intersect` proofAxioms proof +-- | A step in an RDF proof. +type RDFProofStep = Step RDFGraph --- |Check consistency of given proof. --- The supplied rules and axioms are assumed to be correct. -checkProof :: (Expression ex) => Proof ex -> Bool -checkProof pr = - checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr - where - initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) - goalExpr = formExpr $ proofResult pr +------------------------------------------------------------ +-- Helper functions for constructing proofs on RDF graphs +------------------------------------------------------------ -checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool -checkProof1 _ prev [] res = res `elem` prev -checkProof1 rules prev (st:steps) res = - checkStep rules prev st && - checkProof1 rules (formExpr (stepCon st):prev) steps res +-- |Make an RDF graph proof step. +-- +makeRDFProofStep :: + RDFRule -- ^ rule to use for this step + -> [RDFFormula] -- ^ antecedent RDF formulae for this step + -> RDFFormula -- ^ RDF formula that is the consequent for this step + -> RDFProofStep +makeRDFProofStep rul ants con = Step + { stepRule = rul + , stepAnt = ants + , stepCon = con + } --- | A proof step is valid if rule is in list of rules --- and the antecedents are sufficient to obtain the conclusion --- and the antecedents are in the list of formulae already proven. +-- |Make an RDF proof. -- --- Note: this function depends on the ruleName of any rule being --- unique among all rules. In particular the name of the step rule --- being in correspondence with the name of one of the indicated --- valid rules of inference. -checkStep :: - (Expression ex) - => [Rule ex] -- ^ rules - -> [ex] -- ^ antecedants - -> Step ex -- ^ the step to validate - -> Bool -- ^ @True@ if the step is valid +makeRDFProof :: + [RDFRuleset] -- ^ RDF rulesets that constitute a proof context for this proof + -> RDFFormula -- ^ initial statement from which the goal is claimed to be proven + -> RDFFormula -- ^ statement that is claimed to be proven + -> [RDFProofStep] -- ^ the chain of inference rules in the proof. + -> RDFProof +makeRDFProof rsets base goal steps = Proof + { proofContext = rsets + , proofInput = base + , proofResult = goal + , proofChain = steps + } -checkStep rules prev step = isNothing $ explainStep rules prev step +------------------------------------------------------------ +-- RDF instance entailment inference rule +------------------------------------------------------------ -{- +-- |Make an inference rule dealing with RDF instance entailment; +-- i.e. entailments that are due to replacement of a URI or literal +-- node with a blank node. +-- +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' and 'bwdApply' functions defined here may return +-- rather large results if applied to graphs with many variables or +-- a large vocabulary, and are defined for experimentation. +-- +-- Forward and backward chaining is performed with respect to a +-- specified vocabulary. In the case of backward chaining, it would +-- otherwise be impossible to bound the options thus generated. +-- In the case of forward chaining, it is often not desirable to +-- have the properties generalized. If forward or backward backward +-- chaining will not be used, supply an empty vocabulary. +-- Note: graph method 'Swish.RDF.Graph.allNodes' can be used to obtain a list of all +-- the subjects and objects used in a graph, not counting nested +-- formulae; use a call of the form: +-- +-- > allNodes (not . labelIsVar) graph +-- +makeRdfInstanceEntailmentRule :: + ScopedName -- ^ name + -> [RDFLabel] -- ^ vocabulary + -> RDFRule +makeRdfInstanceEntailmentRule name vocab = newrule + where + newrule = Rule + { ruleName = name + , fwdApply = rdfInstanceEntailFwdApply vocab + , bwdApply = rdfInstanceEntailBwdApply vocab + , checkInference = rdfInstanceEntailCheckInference + } -Is the following an optimisation of the above? +-- Instance entailment forward chaining +-- +-- Note: unless the initial graph is small, the total result +-- here could be very large. The existential generalizations are +-- sequenced in increasing number of substitutions applied. +-- +-- The instances generated are all copies of the merge of the +-- supplied graphs, with some or all of the non-variable nodes +-- replaced by blank nodes. +rdfInstanceEntailFwdApply :: [RDFLabel] -> [RDFGraph] -> [RDFGraph] +rdfInstanceEntailFwdApply vocab ante = + let + -- Merge antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + mergeGraph = if null ante then mempty + else foldl1 merge ante + -- Obtain lists of variable and non-variable nodes + -- (was: nonvarNodes = allLabels (not . labelIsVar) mergeGraph) + nonvarNodes = vocab + varNodes = allLabels labelIsVar mergeGraph + -- Obtain list of possible remappings for non-variable nodes + mapList = remapLabelList nonvarNodes varNodes + mapSubLists = (tail . subsequences) mapList + mapGr ls = fmap (\l -> mapFind l l (makeLookupMap ls)) + in + -- Return all remappings of the original merged graph + flist (map mapGr mapSubLists) mergeGraph -checkStep rules prev step = - -- Rule name is one of supplied rules, and - (ruleName srul `elem` map ruleName rules) && - -- Antecedent expressions are all previously accepted expressions - (sant `subset` prev) && - -- Inference rule yields concequence from antecendents - checkInference srul sant scon - where - -- Rule from proof step: - srul = stepRule step - -- Antecedent expressions from proof step: - sant = map formExpr $ stepAnt step - -- Consequentent expression from proof step: - scon = formExpr $ stepCon step --} +-- Instance entailment backward chaining (for specified vocabulary) +-- +-- [[[TODO: this is an incomplete implementation, there being no +-- provision for instantiating some variables and leaving others +-- alone. This can be overcome in many cases by combining instance +-- and subgraph chaining. +-- Also, there is no provision for instantiating some variables in +-- a triple and leaving others alone. This may be fixed later if +-- this function is really needed to be completely faithful to the +-- precise notion of instance entailment.]]] +rdfInstanceEntailBwdApply :: [RDFLabel] -> RDFGraph -> [[RDFGraph]] +rdfInstanceEntailBwdApply vocab cons = + let + -- Obtain list of variable nodes + varNodes = allLabels labelIsVar cons + -- Generate a substitution for each combination of variable + -- and vocabulary node. + varBindings = map (makeVarBinding . zip varNodes) vocSequences + vocSequences = powerSequencesLen (length varNodes) vocab + in + -- Generate a substitution for each combination of variable + -- and vocabulary: + [ rdfQuerySubs [v] cons | v <- varBindings ] +-- Instance entailment inference checker +rdfInstanceEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfInstanceEntailCheckInference ante cons = + let + mante = if null ante then mempty -- merged antecedents + else foldl1 merge ante + qvars = rdfQueryInstance cons mante -- all query matches + bsubs = rdfQuerySubs qvars cons -- all back substitutions + in + -- Return True if any back-substitution matches the original + -- merged antecendent graph. + elem mante bsubs -{- - (formExpr (stepCon step) `elem` sfwd) - -- (or $ map (`subset` sant) sbwd) - where - -- Rule from proof step: - srul = stepRule step - -- Antecedent expressions from proof step: - sant = map formExpr $ stepAnt step - -- Forward chaining from antecedents of proof step - scon = map formExpr $ stepCon step - -- Forward chaining from antecedents of proof step +------------------------------------------------------------ +-- Powersequence (?) -- all sequences from some base values +------------------------------------------------------------ - sfwd = fwdApply srul sant - -- Backward chaining from consequent of proof step - -- (Does not work because of introduction of existentials) - sbwd = bwdApply srul (formExpr $ stepCon step) --} +-- |Construct list of lists of sequences of increasing length +powerSeqBylen :: [a] -> [[a]] -> [[[a]]] +powerSeqBylen rs ps = ps : powerSeqBylen rs (powerSeqNext rs ps) --- |Check proof. If there is an error then return information --- about the failing step. -explainProof :: - (Expression ex) => Proof ex -> Maybe String -explainProof pr = - explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr - where - initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) - goalExpr = formExpr $ proofResult pr +-- |Return sequences of length n+1 given original sequence +-- and list of all sequences of length n +powerSeqNext :: [a] -> [[a]] -> [[a]] +powerSeqNext rs rss = [ h:t | t <- rss, h <- rs ] -explainProof1 :: - (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String -explainProof1 _ prev [] res = - if res `elem` prev then Nothing else Just "Result not demonstrated" -explainProof1 rules prev (st:steps) res = - case explainStep rules prev st of - Nothing -> explainProof1 rules (formExpr (stepCon st):prev) steps res - Just ex -> Just ("Invalid step: "++show (formName $ stepCon st)++": "++ex) +-- |Return all powersequences of a given length +powerSequencesLen :: Int -> [a] -> [[a]] +powerSequencesLen len rs = powerSeqBylen rs [[]] !! len --- | A proof step is valid if rule is in list of rules --- and the antecedents are sufficient to obtain the conclusion --- and the antecedents are in the list of formulae already proven. +-- Instance entailment notes. -- --- Note: this function depends on the ruleName of any rule being --- unique among all rules. In particular the name of the step rule --- being in correspondence with the name of one of the indicated --- valid rules of inference. +-- Relation to simple entailment (s-entails): -- -explainStep :: - (Expression ex) - => [Rule ex] -- ^ rules - -> [ex] -- ^ previous - -> Step ex -- ^ step - -> Maybe String -- ^ @Nothing@ if step is okay, otherwise a string indicating the error -explainStep rules prev step = - if null errors then Nothing else Just $ intercalate ", " errors - where - -- Rule from proof step: - srul = stepRule step - -- Antecedent expressions from proof step: - sant = map formExpr $ stepAnt step - -- Consequentent expression from proof step: - scon = formExpr $ stepCon step - -- Tests for step to be valid - errors = catMaybes - -- Rule name is one of supplied rules, and - [ require (ruleName srul `elem` map ruleName rules) - ("rule "++show (ruleName srul)++" not present") - -- Antecedent expressions are all previously accepted expressions - , require (sant `subset` prev) - "antecedent not axiom or previous result" - -- Inference rule yields consequence from antecedents - , require (checkInference srul sant scon) - "rule does not deduce consequence from antecedents" - ] - require b s = if b then Nothing else Just s - --- |Create a displayable form of a proof, returned as a `ShowS` value. +-- (1) back-substitution yields original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o1 by [_:o1/ex:o1] -- --- This function is intended to allow the calling function some control --- of multiline displays by providing: +-- (2) back-substitution yields original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] +-- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/_:o1] -- --- (1) the first line of the proof is not preceded by any text, so --- it may be appended to some preceding text on the same line, +-- (3) back-substitution does not yield original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] +-- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/ex:o1] -- --- (2) the supplied newline string is used to separate lines of the --- formatted text, and may include any desired indentation, and +-- (4) consider +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 ex:o1 +-- ex:s1 ex:p1 ex:o2 ex:s1 ex:p1 ex:o2 +-- ex:s1 ex:p1 ex:o3 ex:s1 ex:p1 _:o1 +-- ex:s1 ex:p1 _:o2 +-- where [_:o1/ex:o1,_:o2/ex:o2] yields a simple entailment but not +-- an instance entailment, but [_:o1/ex:o3,_:o2/ex:o3] is also +-- (arguably) an instance entailment. Therefore, it is not sufficient +-- to look only at the "largest" substitutions to determine instance +-- entailment. -- --- (3) no newline is output following the final line of text. -showsProof :: - (ShowM ex) - => String -- ^ newline string - -> Proof ex - -> ShowS -showsProof newline proof = - if null axioms then shProof else shAxioms . shProof +-- All this means that when checking for instance entailment by +-- back substitution, all of the query results must be checked. +-- This seems clumsy. If this function is heavily used with +-- multiple query matches, a modified query that uses each +-- triple of the target graph exactly once may be required. + +------------------------------------------------------------ +-- RDF subgraph entailment inference rule +------------------------------------------------------------ + +-- |Make an inference rule dealing with RDF subgraph entailment. +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' function defined here may return rather large +-- results. But in the name of completeness and experimentation +-- with the possibilities of lazy evaluation, it has been defined. +-- +-- Backward chaining is not performed, as there is no reasonable way +-- to choose a meaningful supergraph of that supplied. +makeRdfSubgraphEntailmentRule :: ScopedName -> RDFRule +makeRdfSubgraphEntailmentRule name = newrule where - axioms = proofAxiomsUsed proof - shAxioms = - showString ("Axioms:" ++ newline) . - showsFormulae newline (proofAxiomsUsed proof) newline - shProof = - showString ("Input:" ++ newline) . - showsFormula newline (proofInput proof) . - showString (newline ++ "Proof:" ++ newline) . - showsSteps newline (proofChain proof) + newrule = Rule + { ruleName = name + , fwdApply = rdfSubgraphEntailFwdApply + , bwdApply = const [] + , checkInference = rdfSubgraphEntailCheckInference + } --- |Returns a simple string representation of a proof. -showProof :: - (ShowM ex) - => String -- ^ newline string - -> Proof ex - -> String -showProof newline proof = showsProof newline proof "" +-- Subgraph entailment forward chaining +-- +-- Note: unless the initial graph is small, the total result +-- here could be very large. The subgraphs are sequenced in +-- increasing size of the sub graph. +rdfSubgraphEntailFwdApply :: [RDFGraph] -> [RDFGraph] +rdfSubgraphEntailFwdApply ante = + let + -- Merge antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + mergeGraph = if null ante then mempty + else foldl1 merge ante + in + -- Return all subgraphs of the full graph constructed above + map (setArcs mergeGraph) (init $ tail $ subsequences $ getArcs mergeGraph) --- |Create a displayable form of a list of labelled proof steps -showsSteps :: (ShowM ex) => String -> [Step ex] -> ShowS -showsSteps _ [] = id -showsSteps newline [s] = showsStep newline s -showsSteps newline (s:ss) = showsStep newline s . - showString newline . - showsSteps newline ss +-- Subgraph entailment inference checker +-- +-- This is of dubious utiltiy, as it doesn't allow for node renaming. +-- The simple entailment inference rule is probably more useful here. +rdfSubgraphEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfSubgraphEntailCheckInference ante cons = + let + -- Combine antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + fullGraph = if null ante then mempty + else foldl1 addGraphs ante + in + -- Check each consequent graph arc is in the antecedent graph + getArcs cons `subset` getArcs fullGraph --- |Create a displayable form of a labelled proof step. -showsStep :: (ShowM ex) => String -> Step ex -> ShowS -showsStep newline s = showsFormula newline (stepCon s) . - showString newline . - showString (" (by ["++rulename++"] from "++antnames++")") +------------------------------------------------------------ +-- RDF simple entailment inference rule +------------------------------------------------------------ + +-- |Make an inference rule dealing with RDF simple entailment. +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' and 'bwdApply' functions defined return null +-- results, indicating that they are not useful for the purposes +-- of proof discovery. +makeRdfSimpleEntailmentRule :: ScopedName -> RDFRule +makeRdfSimpleEntailmentRule name = newrule where - rulename = show . ruleName $ stepRule s - antnames = showNames $ map (show . formName) (stepAnt s) + newrule = Rule + { ruleName = name + , fwdApply = const [] + , bwdApply = const [] + , checkInference = rdfSimpleEntailCheckInference + } --- |Return a string containing a list of names. -showNames :: [String] -> String -showNames [] = "" -showNames [n] = showName n -showNames [n1,n2] = showName n1 ++ " and " ++ showName n2 -showNames (n1:ns) = showName n1 ++ ", " ++ showNames ns +-- Simple entailment inference checker +-- +-- Note: antecedents here are presumed to share bnodes. +-- (Use 'merge' instead of 'add' for non-shared bnodes) +-- +rdfSimpleEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfSimpleEntailCheckInference ante cons = + let agr = if null ante then mempty else foldl1 addGraphs ante + in not $ null $ rdfQueryInstance cons agr --- |Return a string representing a single name. -showName :: String -> String -showName n = "["++n++"]" +{- original.. + not $ null $ rdfQueryInstance cons (foldl1 merge ante) +-} -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/ProofContext.hs b/src/Swish/RDF/ProofContext.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/ProofContext.hs @@ -0,0 +1,852 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : ProofContext +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This module contains proof-context declarations based on +-- the RDF, RDFS, and RDF datatyping semantics specifications. +-- These definitions consist of namespaces (for identification +-- in proofs), axioms and inference rules. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.ProofContext ( rulesetRDF + , rulesetRDFS + , rulesetRDFD) where + +import Swish.Datatype (typeMkCanonicalForm) +import Swish.Namespace (Namespace, makeNSScopedName) +import Swish.QName (LName) +import Swish.Ruleset (makeRuleset) +import Swish.VarBinding (VarBindingModify(..)) +import Swish.VarBinding (applyVarBinding, addVarBinding, makeVarFilterModify, varFilterDisjunction) + +import Swish.RDF.BuiltIn.Datatypes (findRDFDatatype) + +import Swish.RDF.Proof (makeRdfSubgraphEntailmentRule + , makeRdfSimpleEntailmentRule ) + +import Swish.RDF.Ruleset + ( RDFFormula, RDFRule, RDFRuleset + , makeRDFFormula + , makeN3ClosureRule + , makeN3ClosureSimpleRule + , makeN3ClosureModifyRule + , makeN3ClosureAllocatorRule + , makeNodeAllocTo ) + +import Swish.RDF.VarBinding + ( RDFVarBinding + , RDFVarBindingModify + , RDFVarBindingFilter + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) + +import Swish.RDF.Graph (RDFLabel(..), isUri) + +import Swish.RDF.Vocabulary + ( namespaceRDFD + , scopeRDF + , scopeRDFS + , scopeRDFD + ) + +import Data.Monoid (Monoid(..)) + +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Define query binding filter auxiliaries +------------------------------------------------------------ + +makeFormula :: Namespace -> LName -> B.Builder -> RDFFormula +makeFormula = makeRDFFormula + +requireAny :: [RDFVarBindingFilter] -> RDFVarBindingFilter +requireAny = varFilterDisjunction + +isLiteralV :: String -> RDFVarBindingFilter +isLiteralV = rdfVarBindingLiteral . Var + +isUntypedLitV :: String -> RDFVarBindingFilter +isUntypedLitV = rdfVarBindingUntypedLiteral . Var + +isXMLLitV :: String -> RDFVarBindingFilter +isXMLLitV = rdfVarBindingXMLLiteral . Var + +isUriRefV :: String -> RDFVarBindingFilter +isUriRefV = rdfVarBindingUriRef . Var + +isBlankV :: String -> RDFVarBindingFilter +isBlankV = rdfVarBindingBlank . Var + +isDatatypedV :: String -> String -> RDFVarBindingFilter +isDatatypedV d l = rdfVarBindingDatatyped (Var d) (Var l) + +isMemberPropV :: String -> RDFVarBindingFilter +isMemberPropV = rdfVarBindingMemberProp . Var + +allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify +allocateTo bv av = makeNodeAllocTo (Var bv) (Var av) + +-- Create new binding for datatype +valueSame :: String -> String -> String -> String -> RDFVarBindingModify +valueSame val1 typ1 val2 typ2 = + sameDatatypedValue (Var val1) (Var typ1) (Var val2) (Var typ2) + +-- Variable binding modifier to create new binding to a canonical +-- form of a datatyped literal. +sameDatatypedValue :: + RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel -> RDFVarBindingModify +sameDatatypedValue val1 typ1 val2 typ2 = VarBindingModify + { vbmName = makeNSScopedName namespaceRDFD "sameValue" + , vbmApply = sameDatatypedValueApplyAll val1 typ1 val2 typ2 + , vbmVocab = [val1,typ1,val2,typ2] + , vbmUsage = [[val2]] + } + +sameDatatypedValueApplyAll :: + RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel + -> [RDFVarBinding] + -> [RDFVarBinding] +sameDatatypedValueApplyAll val1 typ1 val2 typ2 = + concatMap (sameDatatypedValueApply val1 typ1 val2 typ2) + +-- Auxiliary function that handles variable binding updates +-- for sameDatatypedValue +sameDatatypedValueApply :: + RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel + -> RDFVarBinding + -> [RDFVarBinding] +sameDatatypedValueApply val1 typ1 val2 typ2 vbind = + result + where + v1 = applyVarBinding vbind val1 + t1 = applyVarBinding vbind typ1 + t2 = applyVarBinding vbind typ2 + sametype = getCanonical v1 t1 t2 + result = + if isUri t1 && isUri t2 then + if t1 == t2 then + case sametype of + Just st -> [addVarBinding val2 st vbind] + _ -> [] + else + error "subtype conversions not yet defined" + else + [] + +{- +getCanonical :: RDFLabel -> RDFLabel -> RDFLabel -> Maybe RDFLabel +getCanonical v1 t1 t2 = + if isDatatyped dqn1 v1 && isJust mdt1 then + liftM mkLit $ typeMkCanonicalForm dt1 (getLiteralText v1) + else + Nothing + where + dqn1 = getRes t1 + dqn2 = getRes t2 + mdt1 = findRDFDatatype dqn1 + dt1 = fromJust mdt1 + mkLit = flip Lit (Just dqn2) + + getRes (Res dqnam) = dqnam + getRes x = error $ "Expected a Resource, sent " ++ show x -- for -Wall +-} + +getCanonical :: RDFLabel -> RDFLabel -> RDFLabel -> Maybe RDFLabel +getCanonical (TypedLit v dt) (Res dqn1) (Res dqn2) = + if dt == dqn1 + then case findRDFDatatype dqn1 of + Just dt1 -> flip TypedLit dqn2 `fmap` typeMkCanonicalForm dt1 v + _ -> Nothing + + else Nothing + +getCanonical _ _ _ = Nothing + + + +{- -- Test data +qnamint = ScopedName namespaceXSD "integer" +xsdint = Res qnamint +lab010 = Lit "010" (Just qnamint) +can010 = getCanonical lab010 xsdint xsdint +nsex = Namespace "ex" "http://example.org/" +resexp = Res (ScopedName nsex "p") +resexs = Res (ScopedName nsex "s") + +vara = Var "a" +varb = Var "b" +varc = Var "c" +vard = Var "d" +varp = Var "p" +vars = Var "s" +vart = Var "t" + +vb1 = makeVarBinding [(vara,lab010),(varb,xsdint),(vard,xsdint)] +vb2 = sameDatatypedValueApply vara varb varc vard vb1 +vb3 = vbmApply (sameDatatypedValue vara varb varc vard) [vb1] +vb3t = vb3 == vb2 +vb4 = vbmApply (valueSame "a" "b" "c" "d") [vb1] +vb4t = vb4 == vb2 +vb5 = vbmApply (valueSame "a" "b" "c" "b") [vb1] +vb5t = vb5 == vb2 + +vb6 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint)] +vb7 = vbmApply (valueSame "s" "d" "t" "d") [vb6] +vb8 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint) + ,(vart,fromJust can010)] +vb8t = vb7 == [vb8] +-- -} + +------------------------------------------------------------ +-- Common definitions +------------------------------------------------------------ + +------------------------------------------------------------ +-- Define RDF axioms +------------------------------------------------------------ + +-- scopeRDF = Namespace "rs-rdf" "http://id.ninebynine.org/2003/Ruleset/rdf#" + +-- RDF axioms (from RDF semantics document, section 3.1) +-- +-- (See also, container property rules below) +-- +rdfa1 :: RDFFormula +rdfa1 = makeFormula scopeRDF "a1" "rdf:type rdf:type rdf:Property ." + +rdfa2 :: RDFFormula +rdfa2 = makeFormula scopeRDF "a2" "rdf:subject rdf:type rdf:Property ." + +rdfa3 :: RDFFormula +rdfa3 = makeFormula scopeRDF "a3" "rdf:predicate rdf:type rdf:Property ." + +rdfa4 :: RDFFormula +rdfa4 = makeFormula scopeRDF "a4" "rdf:object rdf:type rdf:Property ." + +rdfa5 :: RDFFormula +rdfa5 = makeFormula scopeRDF "a5" "rdf:first rdf:type rdf:Property ." + +rdfa6 :: RDFFormula +rdfa6 = makeFormula scopeRDF "a6" "rdf:rest rdf:type rdf:Property ." + +rdfa7 :: RDFFormula +rdfa7 = makeFormula scopeRDF "a7" "rdf:value rdf:type rdf:Property ." + +rdfa8 :: RDFFormula +rdfa8 = makeFormula scopeRDF "a8" "rdf:nil rdf:type rdf:List ." + +axiomsRDF :: [RDFFormula] +axiomsRDF = + [ rdfa1, rdfa2, rdfa3, rdfa4, rdfa5 + , rdfa6, rdfa7, rdfa8 + ] + +------------------------------------------------------------ +-- Define RDF rules +------------------------------------------------------------ + +-- RDF subgraph entailment (from RDF semantics document section 2) +-- +rdfsub :: RDFRule +rdfsub = makeRdfSubgraphEntailmentRule (makeNSScopedName scopeRDF "sub") + +-- RDF simple entailment (from RDF semantics document section 7.1) +-- (Note: rules se1 and se2 are combined here, because the scope of +-- the "allocatedTo" modifier is the application of a single rule.) +-- +rdfse :: RDFRule +rdfse = makeRdfSimpleEntailmentRule (makeNSScopedName scopeRDF "se") + +-- RDF bnode-for-literal assignments (from RDF semantics document section 7.1) +-- +rdflg :: RDFRule +rdflg = makeN3ClosureAllocatorRule scopeRDF "lg" + "?x ?a ?l . " + "?x ?a ?b . ?b rdf:_allocatedTo ?l ." + (makeVarFilterModify $ isLiteralV "l") + (allocateTo "b" "l") + +-- RDF bnode-for-literal back-tracking (from RDF semantics document section 7.1) +-- +rdfgl :: RDFRule +rdfgl = makeN3ClosureSimpleRule scopeRDF "gl" + "?x ?a ?l . ?b rdf:_allocatedTo ?l . " + "?x ?a ?b ." + +-- RDF entailment rules (from RDF semantics document section 7.2) +-- +-- (Note, statements with property rdf:_allocatedTo are introduced to +-- track bnodes introduced according to rule rdflf [presumably this +-- is actually rdflg?]) +-- +rdfr1 :: RDFRule +rdfr1 = makeN3ClosureSimpleRule scopeRDF "r1" + "?x ?a ?y ." + "?a rdf:type rdf:Property ." + +rdfr2 :: RDFRule +rdfr2 = makeN3ClosureRule scopeRDF "r2" + "?x ?a ?b . ?b rdf:_allocatedTo ?l . " + "?b rdf:type rdf:XMLLiteral ." + (makeVarFilterModify $ isXMLLitV "l") + +-- Container property axioms (from RDF semantics document section 3.1) +-- +-- (Using here an inference rule with a filter in place of an axiom schema) +-- +-- This is a restricted form of the given axioms, in that the axioms +-- are asserted only for container membership terms that appear in +-- the graph. +-- +-- (This may be very inefficient for forward chaining when dealing with +-- large graphs: may need to look at query logic to see if the search for +-- container membership properties can be optimized. This may call for a +-- custom inference rule.) +-- +rdfcp1 :: RDFRule +rdfcp1 = makeN3ClosureRule scopeRDF "cp1" + "?x ?c ?y . " + "?c rdf:type rdf:Property ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfcp2 :: RDFRule +rdfcp2 = makeN3ClosureRule scopeRDF "cp2" + "?c ?p ?y . " + "?c rdf:type rdf:Property ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfcp3 :: RDFRule +rdfcp3 = makeN3ClosureRule scopeRDF "cp3" + "?x ?p ?c . " + "?c rdf:type rdf:Property ." + (makeVarFilterModify $ isMemberPropV "c") + +-- Collect RDF rules +-- +rulesRDF :: [RDFRule] +rulesRDF = + [ rdfsub, rdfse + , rdflg, rdfgl + , rdfr1, rdfr2 + , rdfcp1, rdfcp2, rdfcp3 + ] + +-- | Ruleset for RDF inference. + +rulesetRDF :: RDFRuleset +rulesetRDF = makeRuleset scopeRDF axiomsRDF rulesRDF + +------------------------------------------------------------ +-- Define RDFS axioms +------------------------------------------------------------ + +-- scopeRDFS = Namespace "rdfs" "http://id.ninebynine.org/2003/Ruleset/rdfs#" + +-- RDFS axioms (from RDF semantics document, section 4.1) +-- +-- (See also, container property rules below) +-- + +rdfsa01 :: RDFFormula +rdfsa01 = makeFormula scopeRDFS "a01" + "rdf:type rdfs:domain rdfs:Resource ." + +rdfsa02 :: RDFFormula +rdfsa02 = makeFormula scopeRDFS "a02" + "rdf:type rdfs:range rdfs:Class ." + +rdfsa03 :: RDFFormula +rdfsa03 = makeFormula scopeRDFS "a03" + "rdfs:domain rdfs:domain rdf:Property ." + +rdfsa04 :: RDFFormula +rdfsa04 = makeFormula scopeRDFS "a04" + "rdfs:domain rdfs:range rdfs:Class ." + +rdfsa05 :: RDFFormula +rdfsa05 = makeFormula scopeRDFS "a05" + "rdfs:range rdfs:domain rdf:Property ." + +rdfsa06 :: RDFFormula +rdfsa06 = makeFormula scopeRDFS "a06" + "rdfs:range rdfs:range rdfs:Class ." + +rdfsa07 :: RDFFormula +rdfsa07 = makeFormula scopeRDFS "a07" + "rdfs:subPropertyOf rdfs:domain rdf:Property ." + +rdfsa08 :: RDFFormula +rdfsa08 = makeFormula scopeRDFS "a08" + "rdfs:subPropertyOf rdfs:range rdf:Property ." + +rdfsa09 :: RDFFormula +rdfsa09 = makeFormula scopeRDFS "a09" + "rdfs:subClassOf rdfs:domain rdfs:Class ." + +rdfsa10 :: RDFFormula +rdfsa10 = makeFormula scopeRDFS "a10" + "rdfs:subClassOf rdfs:range rdfs:Class ." + +rdfsa11 :: RDFFormula +rdfsa11 = makeFormula scopeRDFS "a11" + "rdf:subject rdfs:domain rdf:Statement ." + +rdfsa12 :: RDFFormula +rdfsa12 = makeFormula scopeRDFS "a12" + "rdf:subject rdfs:range rdfs:Resource ." + +rdfsa13 :: RDFFormula +rdfsa13 = makeFormula scopeRDFS "a13" + "rdf:predicate rdfs:domain rdf:Statement ." + +rdfsa14 :: RDFFormula +rdfsa14 = makeFormula scopeRDFS "a14" + "rdf:predicate rdfs:range rdfs:Resource ." + +rdfsa15 :: RDFFormula +rdfsa15 = makeFormula scopeRDFS "a15" + "rdf:object rdfs:domain rdf:Statement ." + +rdfsa16 :: RDFFormula +rdfsa16 = makeFormula scopeRDFS "a16" + "rdf:object rdfs:range rdfs:Resource ." + +rdfsa17 :: RDFFormula +rdfsa17 = makeFormula scopeRDFS "a17" + "rdfs:member rdfs:domain rdfs:Resource ." + +rdfsa18 :: RDFFormula +rdfsa18 = makeFormula scopeRDFS "a18" + "rdfs:member rdfs:range rdfs:Resource ." + +rdfsa19 :: RDFFormula +rdfsa19 = makeFormula scopeRDFS "a19" + "rdf:first rdfs:domain rdf:List ." + +rdfsa20 :: RDFFormula +rdfsa20 = makeFormula scopeRDFS "a20" + "rdf:first rdfs:range rdfs:Resource ." + +rdfsa21 :: RDFFormula +rdfsa21 = makeFormula scopeRDFS "a21" + "rdf:rest rdfs:domain rdf:List ." + +rdfsa22 :: RDFFormula +rdfsa22 = makeFormula scopeRDFS "a22" + "rdf:rest rdfs:range rdf:List ." + +rdfsa23 :: RDFFormula +rdfsa23 = makeFormula scopeRDFS "a23" + "rdfs:seeAlso rdfs:domain rdfs:Resource ." + +rdfsa24 :: RDFFormula +rdfsa24 = makeFormula scopeRDFS "a24" + "rdfs:seeAlso rdfs:range rdfs:Resource ." + +rdfsa25 :: RDFFormula +rdfsa25 = makeFormula scopeRDFS "a25" + "rdfs:isDefinedBy rdfs:domain rdfs:Resource ." + +rdfsa26 :: RDFFormula +rdfsa26 = makeFormula scopeRDFS "a26" + "rdfs:isDefinedBy rdfs:range rdfs:Resource ." + +rdfsa27 :: RDFFormula +rdfsa27 = makeFormula scopeRDFS "a27" + "rdfs:isDefinedBy rdfs:subPropertyOf rdfs:seeAlso ." + +rdfsa28 :: RDFFormula +rdfsa28 = makeFormula scopeRDFS "a28" + "rdfs:comment rdfs:domain rdfs:Resource ." + +rdfsa29 :: RDFFormula +rdfsa29 = makeFormula scopeRDFS "a29" + "rdfs:comment rdfs:range rdfs:Literal ." + +rdfsa30 :: RDFFormula +rdfsa30 = makeFormula scopeRDFS "a30" + "rdfs:label rdfs:domain rdfs:Resource ." + +rdfsa31 :: RDFFormula +rdfsa31 = makeFormula scopeRDFS "a31" + "rdfs:label rdfs:range rdfs:Literal ." + +rdfsa32 :: RDFFormula +rdfsa32 = makeFormula scopeRDFS "a32" + "rdf:value rdfs:domain rdfs:Resource ." + +rdfsa33 :: RDFFormula +rdfsa33 = makeFormula scopeRDFS "a33" + "rdf:value rdfs:range rdfs:Resource ." + +rdfsa34 :: RDFFormula +rdfsa34 = makeFormula scopeRDFS "a34" + "rdf:Alt rdfs:subClassOf rdfs:Container ." + +rdfsa35 :: RDFFormula +rdfsa35 = makeFormula scopeRDFS "a35" + "rdf:Bag rdfs:subClassOf rdfs:Container ." + +rdfsa36 :: RDFFormula +rdfsa36 = makeFormula scopeRDFS "a36" + "rdf:Seq rdfs:subClassOf rdfs:Container ." + +rdfsa37 :: RDFFormula +rdfsa37 = makeFormula scopeRDFS "a37" + "rdfs:ContainerMembershipProperty rdfs:subClassOf rdf:Property ." + +rdfsa38 :: RDFFormula +rdfsa38 = makeFormula scopeRDFS "a38" + "rdf:XMLLiteral rdf:type rdfs:Datatype ." + +rdfsa39 :: RDFFormula +rdfsa39 = makeFormula scopeRDFS "a39" + "rdf:XMLLiteral rdfs:subClassOf rdfs:Literal ." + +rdfsa40 :: RDFFormula +rdfsa40 = makeFormula scopeRDFS "a40" + "rdfs:Datatype rdfs:subClassOf rdfs:Class ." + +axiomsRDFS :: [RDFFormula] +axiomsRDFS = + [ rdfsa01, rdfsa02, rdfsa03, rdfsa04 + , rdfsa05, rdfsa06, rdfsa07, rdfsa08, rdfsa09 + , rdfsa10, rdfsa11, rdfsa12, rdfsa13, rdfsa14 + , rdfsa15, rdfsa16, rdfsa17, rdfsa18, rdfsa19 + , rdfsa20, rdfsa21, rdfsa22, rdfsa23, rdfsa24 + , rdfsa25, rdfsa26, rdfsa27, rdfsa28, rdfsa29 + , rdfsa30, rdfsa31, rdfsa32, rdfsa33, rdfsa34 + , rdfsa35, rdfsa36, rdfsa37, rdfsa38, rdfsa39 + , rdfsa40 + ] + +------------------------------------------------------------ +-- Define RDFS rules +------------------------------------------------------------ + +{- +rdfr2 = makeN3ClosureRule scopeRDF "r2" + "?x ?a ?b . ?b rdf:_allocatedTo ?l . " + "?b rdf:type rdf:XMLLiteral ." + (makeVarFilterModify $ isXMLLit "?l") +-} + +-- RDFS entailment rules (from RDF semantics document section 7.2) +-- +-- (Note, statements with property rdf:_allocatedTo are introduced to +-- track bnodes introduced according to rule rdflf [presumably this +-- is actually rdflg?]) +-- +rdfsr1 :: RDFRule +rdfsr1 = makeN3ClosureRule scopeRDFS "r1" + "?x ?a ?b . ?b rdf:_allocatedTo ?l . " + "?b rdf:type rdfs:Literal ." + (makeVarFilterModify $ isUntypedLitV "l" ) + +rdfsr2 :: RDFRule +rdfsr2 = makeN3ClosureSimpleRule scopeRDFS "r2" + "?x ?a ?y . ?a rdfs:domain ?z ." + "?x rdf:type ?z ." + +rdfsr3 :: RDFRule +rdfsr3 = makeN3ClosureRule scopeRDFS "r3" + "?u ?a ?v . ?a rdfs:range ?z ." + "?v rdf:type ?z ." + (makeVarFilterModify $ requireAny [isUriRefV "v",isBlankV "v"]) + +rdfsr4a :: RDFRule +rdfsr4a = makeN3ClosureSimpleRule scopeRDFS "r4a" + "?x ?a ?y ." + "?x rdf:type rdfs:Resource ." + +rdfsr4b :: RDFRule +rdfsr4b = makeN3ClosureRule scopeRDFS "r4b" + "?x ?a ?u ." + "?u rdf:type rdfs:Resource ." + (makeVarFilterModify $ requireAny [isUriRefV "u",isBlankV "u"]) + +rdfsr5 :: RDFRule +rdfsr5 = makeN3ClosureSimpleRule scopeRDFS "r5" + "?a rdfs:subPropertyOf ?b . ?b rdfs:subPropertyOf ?c ." + "?a rdfs:subPropertyOf ?c ." + +rdfsr6 :: RDFRule +rdfsr6 = makeN3ClosureSimpleRule scopeRDFS "r6" + "?x rdf:type rdf:Property ." + "?x rdfs:subPropertyOf ?x ." + +rdfsr7 :: RDFRule +rdfsr7 = makeN3ClosureSimpleRule scopeRDFS "r7" + "?x ?a ?y . ?a rdfs:subPropertyOf ?b ." + "?x ?b ?y ." + +rdfsr8 :: RDFRule +rdfsr8 = makeN3ClosureSimpleRule scopeRDFS "r8" + "?x rdf:type rdfs:Class ." + "?x rdfs:subClassOf rdfs:Resource ." + +rdfsr9 :: RDFRule +rdfsr9 = makeN3ClosureSimpleRule scopeRDFS "r9" + "?x rdfs:subClassOf ?y . ?a rdf:type ?x ." + "?a rdf:type ?y ." + +rdfsr10 :: RDFRule +rdfsr10 = makeN3ClosureSimpleRule scopeRDFS "r10" + "?x rdf:type rdfs:Class ." + "?x rdfs:subClassOf ?x ." + +rdfsr11 :: RDFRule +rdfsr11 = makeN3ClosureSimpleRule scopeRDFS "r11" + "?x rdfs:subClassOf ?y . ?y rdfs:subClassOf ?z ." + "?x rdfs:subClassOf ?z ." + +rdfsr12 :: RDFRule +rdfsr12 = makeN3ClosureSimpleRule scopeRDFS "r12" + "?x rdf:type rdfs:ContainerMembershipProperty ." + "?x rdfs:subPropertyOf rdfs:member ." + +rdfsr13 :: RDFRule +rdfsr13 = makeN3ClosureSimpleRule scopeRDFS "r13" + "?x rdf:type rdfs:Datatype ." + "?x rdfs:subClassOf rdfs:Literal ." + +-- These are valid only under an extensional strengthening of RDFS, +-- discussed in section 7.3.1 of the RDF semantics specification: + +{- +rdfsrext1 :: RDFRule +rdfsrext1 = makeN3ClosureSimpleRule scopeRDFS "ext1" + "?x rdfs:domain ?y . ?y rdfs:subClassOf ?z ." + "?x rdfs:domain ?z ." + +rdfsrext2 :: RDFRule +rdfsrext2 = makeN3ClosureSimpleRule scopeRDFS "ext2" + "?x rdfs:range ?y . ?y rdfs:subClassOf ?z ." + "?x rdfs:range ?z ." + +rdfsrext3 :: RDFRule +rdfsrext3 = makeN3ClosureSimpleRule scopeRDFS "ext3" + "?x rdfs:domain ?y . ?z rdfs:subPropertyOf ?x ." + "?z rdfs:domain ?y ." + +rdfsrext4 :: RDFRule +rdfsrext4 = makeN3ClosureSimpleRule scopeRDFS "ext4" + "?x rdfs:range ?y . ?z rdfs:subPropertyOf ?x ." + "?z rdfs:range ?y ." + +rdfsrext5 :: RDFRule +rdfsrext5 = makeN3ClosureSimpleRule scopeRDFS "ext5" + "rdf:type rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." + "rdfs:Resource rdfs:subClassOf ?y ." + +rdfsrext6 :: RDFRule +rdfsrext6 = makeN3ClosureSimpleRule scopeRDFS "rext6" + "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." + "rdfs:Class rdfs:subClassOf ?y ." + +rdfsrext7 :: RDFRule +rdfsrext7 = makeN3ClosureSimpleRule scopeRDFS "rext7" + "rdfs:subPropertyOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." + "rdfs:Property rdfs:subClassOf ?y ." + +rdfsrext8 :: RDFRule +rdfsrext8 = makeN3ClosureSimpleRule scopeRDFS "rext8" + "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:range ?y ." + "rdfs:Class rdfs:subClassOf ?y ." + +rdfsrext9 :: RDFRule +rdfsrext9 = makeN3ClosureSimpleRule scopeRDFS "rext9" + "rdfs:subPropertyOf rdfs:subPropertyOf ?z . ?z rdfs:range ?y ." + "rdfs:Property rdfs:subClassOf ?y ." + +-} + +-- Container property axioms (from RDF semantics document section 4.1) +-- +-- (Using here an inference rule with a filter in place of an axiom schema) +-- +-- This is a restricted form of the given axioms, in that the axioms +-- are asserted only for container membership terms that appear in +-- the graph. +-- +-- (This may be very inefficient for forward chaining when dealing with +-- large graphs: may need to look at query logic to see if the search for +-- container membership properties can be optimized. This may call for a +-- custom inference rule.) +-- +rdfscp11 :: RDFRule +rdfscp11 = makeN3ClosureRule scopeRDFS "cp11" + "?x ?c ?y . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp12 :: RDFRule +rdfscp12 = makeN3ClosureRule scopeRDFS "cp12" + "?c ?p ?y . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp13 :: RDFRule +rdfscp13 = makeN3ClosureRule scopeRDFS "cp13" + "?x ?p ?c . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp21 :: RDFRule +rdfscp21 = makeN3ClosureRule scopeRDFS "cp21" + "?x ?c ?y . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp22 :: RDFRule +rdfscp22 = makeN3ClosureRule scopeRDFS "cp22" + "?c ?p ?y . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp23 :: RDFRule +rdfscp23 = makeN3ClosureRule scopeRDFS "cp23" + "?x ?p ?c . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp31 :: RDFRule +rdfscp31 = makeN3ClosureRule scopeRDFS "cp31" + "?x ?c ?y . " + "?c rdfs:range rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp32 :: RDFRule +rdfscp32 = makeN3ClosureRule scopeRDFS "cp32" + "?c ?p ?y . " + "?c rdfs:range rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp33 :: RDFRule +rdfscp33 = makeN3ClosureRule scopeRDFS "cp33" + "?x ?p ?c . " + "?c rdfs:range rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +-- Collect RDFS rules +-- +rulesRDFS :: [RDFRule] +rulesRDFS = + [ rdfsr1, rdfsr2, rdfsr3, rdfsr4a, rdfsr4b + , rdfsr5, rdfsr6, rdfsr7, rdfsr8, rdfsr9 + , rdfsr10, rdfsr11, rdfsr12, rdfsr13 + , rdfscp11, rdfscp12, rdfscp13 + , rdfscp21, rdfscp22, rdfscp23 + , rdfscp31, rdfscp32, rdfscp33 + ] + +-- | Ruleset for RDFS inference. + +rulesetRDFS :: RDFRuleset +rulesetRDFS = makeRuleset scopeRDFS axiomsRDFS rulesRDFS + +------------------------------------------------------------ +-- Define RDFD (datatyping) axioms +------------------------------------------------------------ + +-- scopeRDFD = Namespace "rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" + +axiomsRDFD :: [RDFFormula] +axiomsRDFD = + [ + ] + +------------------------------------------------------------ +-- Define RDFD (datatyping) axioms +------------------------------------------------------------ + +-- RDFD closure rules from semantics document, section 7.4 + +-- Infer type of datatyped literal +-- +rdfdr1 :: RDFRule +rdfdr1 = makeN3ClosureRule scopeRDFD "r1" + "?d rdf:type rdfs:Datatype . ?a ?p ?l . ?b rdf:_allocatedTo ?l . " + "?b rdf:type ?d ." + (makeVarFilterModify $ isDatatypedV "d" "l") + +-- Equivalent literals with same datatype: +-- (generate canonical form, or operate in proof mode only) +-- +rdfdr2 :: RDFRule +rdfdr2 = makeN3ClosureRule scopeRDFD "r2" + "?d rdf:type rdfs:Datatype . ?a ?p ?s ." + "?a ?p ?t ." + (valueSame "s" "d" "t" "d") + +{- Note that valueSame does datatype check. Otherwise use: +rdfdr2 = makeN3ClosureModifyRule scopeRDFD "r2" + "?d rdf:type rdfs:Datatype . ?a ?p ?s ." + "?a ?p ?t ." + (makeVarFilterModify $ isDatatypedV "d" "s") + (valueSame "s" "d" "t" "d") +-} + +-- Equivalent literals with different datatypes: +-- (generate canonical form, or operate in proof mode only) +-- +rdfdr3 :: RDFRule +rdfdr3 = makeN3ClosureModifyRule scopeRDFD "r3" + ( "?d rdf:type rdfs:Datatype . ?e rdf:type rdfs:Datatype . " `mappend` + "?a ?p ?s ." ) + "?a ?p ?t ." + (makeVarFilterModify $ isDatatypedV "s" "d") + (valueSame "s" "d" "t" "e") + +-- Collect RDFD rules +-- +rulesRDFD :: [RDFRule] +rulesRDFD = + [ rdfdr1, rdfdr2, rdfdr3 + ] + +-- | Ruleset for RDFD (datatyping) inference. +-- +rulesetRDFD :: RDFRuleset +rulesetRDFD = makeRuleset scopeRDFD axiomsRDFD rulesRDFD + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Query.hs b/src/Swish/RDF/Query.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Query.hs @@ -0,0 +1,651 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Query +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines functions for querying an RDF graph to obtain +-- a set of variable substitutions, and to apply a set of variable +-- substitutions to a query pattern to obtain a new graph. +-- +-- It also defines a few primitive graph access functions. +-- +-- A minimal example is shown below, where we query a very simple +-- graph: +-- +-- >>> :m + Swish.RDF Swish.RDF.Parser.N3 Swish.RDF.Query +-- >>> :set -XOverloadedStrings +-- >>> let qparse = either error id . parseN3fromText +-- >>> let igr = qparse "@prefix a: . a:a a a:A ; a:foo a:bar. a:b a a:B ; a:foo a:bar." +-- >>> let qgr = qparse "?node a ?type." +-- >>> rdfQueryFind qgr igr +-- [[(?type,a:B),(?node,a:b)],[(?type,a:A),(?node,a:a)]] +-- >>> let bn = (toRDFLabel . Data.Maybe.fromJust . Network.URI.parseURI) "http://example.com/B" +-- >>> rdfFindArcs (rdfObjEq bn) igr +-- [(a:b,rdf:type,a:B)] +-- >>> Data.Maybe.mapMaybe (flip Swish.RDF.VarBinding.vbMap (Var "type")) $ rdfQueryFind qgr igr +-- [a:B,a:A] +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Query + ( rdfQueryFind, rdfQueryFilter + , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify + , rdfQueryInstance + , rdfQuerySubs, rdfQueryBackSubs + , rdfQuerySubsAll + , rdfQuerySubsBlank, rdfQueryBackSubsBlank + , rdfFindArcs, rdfSubjEq, rdfPredEq, rdfObjEq + , rdfFindPredVal, rdfFindPredInt, rdfFindValSubj + , rdfFindList + -- * Utility routines + , allp + , anyp + -- * Exported for testing + , rdfQuerySubs2 ) +where + +import Swish.Datatype (DatatypeMap(..)) +import Swish.VarBinding (VarBinding(..), VarBindingModify(..), VarBindingFilter(..)) +import Swish.VarBinding (makeVarBinding, applyVarBinding, joinVarBindings) + +import Swish.RDF.Graph + ( Arc(..), LDGraph(..) + , arcSubj, arcPred, arcObj + , RDFLabel(..) + , isDatatyped, isBlank, isQueryVar + , getLiteralText, makeBlank + , RDFTriple + , RDFGraph + , allLabels, remapLabels + , resRdfFirst + , resRdfRest + , resRdfNil + ) + +import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingFilter) +import Swish.RDF.VarBinding (nullRDFVarBinding) + +import Swish.RDF.Datatype.XSD.MapInteger (mapXsdInteger) + +import Swish.RDF.Vocabulary (xsdInteger, xsdNonNegInteger) + +import Swish.Utils.ListHelpers (flist) + +import Control.Monad (when) +import Control.Monad.State (State, runState, modify) + +import Data.Maybe (mapMaybe, isJust, fromJust) +import Data.Monoid (Monoid(..)) + +import qualified Data.Set as S +import qualified Data.Traversable as Traversable + +------------------------------------------------------------ +-- Primitive RDF graph queries +------------------------------------------------------------ + +-- | Basic graph-query function. +-- +-- The triples of the query graph are matched sequentially +-- against the target graph, each taking account of any +-- variable bindings that have already been determined, +-- and adding new variable bindings as triples containing +-- query variables are matched against the graph. +-- +rdfQueryFind :: + RDFGraph -- ^ The query graph. + -> RDFGraph -- ^ The target graph. + -> [RDFVarBinding] + -- ^ Each element represents a set of variable bindings that make the query graph a + -- subgraph of the target graph. The list can be empty. +rdfQueryFind = + rdfQueryPrim1 matchQueryVariable nullRDFVarBinding . getArcs + +-- Helper function to match query against a graph. +-- A node-query function is supplied to determine how query nodes +-- are matched against target graph nodes. Also supplied is +-- an initial variable binding. +-- +rdfQueryPrim1 :: + NodeQuery RDFLabel -> RDFVarBinding -> [Arc RDFLabel] + -> RDFGraph + -> [RDFVarBinding] +rdfQueryPrim1 _ initv [] _ = [initv] +rdfQueryPrim1 nodeq initv (qa:qas) tg = + let + qam = fmap (applyVarBinding initv) qa -- subst vars already bound + newv = rdfQueryPrim2 nodeq qam tg -- new bindings, or null + in + concat + [ rdfQueryPrim1 nodeq v2 qas tg + | v1 <- newv + , let v2 = joinVarBindings initv v1 + ] + +-- Match single query term against graph, and return any new sets +-- of variable bindings thus defined, or [] if the query term +-- cannot be matched. Each of the RDFVarBinding values returned +-- represents an alternative possible match for the query arc. +-- +rdfQueryPrim2 :: + NodeQuery RDFLabel -> Arc RDFLabel + -> RDFGraph + -> [RDFVarBinding] +rdfQueryPrim2 nodeq qa tg = + mapMaybe (getBinding nodeq qa) (getArcs tg) + +-- |RDF query filter. +-- +-- This function applies a supplied query binding +-- filter to the result from a call of 'rdfQueryFind'. +-- +-- If none of the query bindings found satisfy the filter, a null +-- list is returned (which is what 'rdfQueryFind' returns if the +-- query cannot be satisfied). +-- +-- (Because of lazy evaluation, this should be as efficient as +-- applying the filter as the search proceeds. I started to build +-- the filter logic into the query function itself, with consequent +-- increase in complexity, until I remembered lazy evaluation lets +-- me keep things separate.) +-- +rdfQueryFilter :: + RDFVarBindingFilter -> [RDFVarBinding] -> [RDFVarBinding] +rdfQueryFilter qbf = filter (vbfTest qbf) + +------------------------------------------------------------ +-- Backward-chaining RDF graph queries +------------------------------------------------------------ + +-- |Reverse graph-query function. +-- +-- Similar to 'rdfQueryFind', but with different success criteria. +-- The query graph is matched against the supplied graph, +-- but not every triple of the query is required to be matched. +-- Rather, every triple of the target graph must be matched, +-- and substitutions for just the variables thus bound are +-- returned. In effect, these are subsitutions in the query +-- that entail the target graph (where @rdfQueryFind@ returns +-- substitutions that are entailed by the target graph). +-- +-- Multiple substitutions may be used together, so the result +-- returned is a list of lists of query bindings. Each inner +-- list contains several variable bindings that must all be applied +-- separately to the closure antecendents to obtain a collection of +-- expressions that together are antecedent to the supplied +-- conclusion. A null list of bindings returned means the +-- conclusion can be inferred without any antecedents. +-- +-- Note: in back-chaining, the conditions required to prove each +-- target triple are derived independently, using the inference rule +-- for each such triple, so there are no requirements to check +-- consistency with previously determined variable bindings, as +-- there are when doing forward chaining. A result of this is that +-- there may be redundant triples generated by the back-chaining +-- process. Any process using back-chaining should deal with the +-- results returned accordingly. +-- +-- An empty outer list is returned if no combination of +-- substitutions can infer the supplied target. +-- +rdfQueryBack :: RDFGraph -> RDFGraph -> [[RDFVarBinding]] +rdfQueryBack qg tg = + rdfQueryBack1 matchQueryVariable [] (getArcs qg) (getArcs tg) + +rdfQueryBack1 :: + NodeQuery RDFLabel -> [RDFVarBinding] -> [Arc RDFLabel] -> [Arc RDFLabel] + -> [[RDFVarBinding]] +rdfQueryBack1 _ initv _ [] = [initv] +rdfQueryBack1 nodeq initv qas (ta:tas) = concat + [ rdfQueryBack1 nodeq (nv:initv) qas tas + | nv <- rdfQueryBack2 nodeq qas ta ] + +-- Match a query against a single graph term, and return any new sets of +-- variable bindings thus defined. Each member of the result is an +-- alternative possible set of variable bindings. An empty list returned +-- means no match. +-- +rdfQueryBack2 :: + NodeQuery RDFLabel -> [Arc RDFLabel] -> Arc RDFLabel + -> [RDFVarBinding] +rdfQueryBack2 nodeq qas ta = + [ fromJust b | qa <- qas, let b = getBinding nodeq qa ta, isJust b ] + +-- |RDF back-chaining query filter. This function applies a supplied +-- query binding filter to the result from a call of 'rdfQueryBack'. +-- +-- Each inner list contains bindings that must all be used to satisfy +-- the backchain query, so if any query binding does not satisfy the +-- filter, the entire corresponding row is removed +rdfQueryBackFilter :: + RDFVarBindingFilter -> [[RDFVarBinding]] -> [[RDFVarBinding]] +rdfQueryBackFilter qbf = filter (all (vbfTest qbf)) + +-- |RDF back-chaining query modifier. This function applies a supplied +-- query binding modifier to the result from a call of 'rdfQueryBack'. +-- +-- Each inner list contains bindings that must all be used to satisfy +-- a backchaining query, so if any query binding does not satisfy the +-- filter, the entire corresponding row is removed +-- +rdfQueryBackModify :: + VarBindingModify a b -> [[VarBinding a b]] -> [[VarBinding a b]] +rdfQueryBackModify qbm = concatMap (rdfQueryBackModify1 qbm) + +-- Auxiliary back-chaining query variable binding modifier function: +-- for a supplied list of variable bindings, all of which must be used +-- together when backchaining: +-- (a) make each list member into a singleton list +-- (b) apply the binding modifier to each such list, which may result +-- in a list with zero, one or more elements. +-- (c) return the sequence of these, each member of which is +-- an alternative list of variable bindings, where the members of +-- each alternative must be used together. +-- +rdfQueryBackModify1 :: + VarBindingModify a b -> [VarBinding a b] -> [[VarBinding a b]] +rdfQueryBackModify1 qbm = mapM (vbmApply qbm . (:[])) + +------------------------------------------------------------ +-- Simple entailment graph query +------------------------------------------------------------ + +-- |Simple entailment (instance) graph query. +-- +-- This function queries a graph to find instances of the +-- query graph in the target graph. It is very similar +-- to the normal forward chaining query 'rdfQueryFind', +-- except that blank nodes rather than query variable nodes +-- in the query graph are matched against nodes in the target +-- graph. Neither graph should contain query variables. +-- +-- An instance is defined by the RDF semantics specification, +-- per , and is obtained by replacing +-- blank nodes with URIs, literals or other blank nodes. RDF +-- simple entailment can be determined in terms of instances. +-- This function looks for a subgraph of the target graph that +-- is an instance of the query graph, which is a necessary and +-- sufficient condition for RDF entailment (see the Interpolation +-- Lemma in RDF Semantics, section 1.2). +-- +-- It is anticipated that this query function can be used in +-- conjunction with backward chaining to determine when the +-- search for sufficient antecendents to determine some goal +-- has been concluded. +rdfQueryInstance :: RDFGraph -> RDFGraph -> [RDFVarBinding] +rdfQueryInstance = + rdfQueryPrim1 matchQueryBnode nullRDFVarBinding . getArcs + +------------------------------------------------------------ +-- Primitive RDF graph query support functions +------------------------------------------------------------ + +-- |Type of query node testing function. Return value is: +-- +-- * @Nothing@ if no match +-- +-- * @Just True@ if match with new variable binding +-- +-- * @Just False@ if match with new variable binding +-- +type NodeQuery a = a -> a -> Maybe Bool + +-- Extract query binding from matching a single query triple with a +-- target triple, returning: +-- - Nothing if the query is not matched +-- - Just nullVarBinding if there are no new variable bindings +-- - Just binding is a new query binding for this match +getBinding :: + NodeQuery RDFLabel -> Arc RDFLabel -> Arc RDFLabel + -> Maybe RDFVarBinding +getBinding nodeq (Arc s1 p1 o1) (Arc s2 p2 o2) = + makeBinding [(s1,s2),(p1,p2),(o1,o2)] [] + where + makeBinding [] bs = Just $ makeVarBinding bs + makeBinding (vr@(v,r):bvrs) bs = + case nodeq v r of + Nothing -> Nothing + Just False -> makeBinding bvrs bs + Just True -> makeBinding bvrs (vr:bs) + +-- Match variable node against target node, returning +-- Nothing if they do not match, Just True if a variable +-- node is matched (thereby creating a new variable binding) +-- or Just False if a non-blank node is matched. +matchQueryVariable :: NodeQuery RDFLabel +matchQueryVariable (Var _) _ = Just True +matchQueryVariable q t + | q == t = Just False + | otherwise = Nothing + +-- Match blank query node against target node, returning +-- Nothing if they do not match, Just True if a blank node +-- is matched (thereby creating a new equivalence) or +-- Just False if a non-blank node is matched. +matchQueryBnode :: NodeQuery RDFLabel +matchQueryBnode (Blank _) _ = Just True +matchQueryBnode q t + | q == t = Just False + | otherwise = Nothing + +------------------------------------------------------------ +-- Substitute results from RDF query back into a graph +------------------------------------------------------------ + +-- |Graph substitution function. +-- +-- Uses the supplied variable bindings to substitute variables in +-- a supplied graph, returning a list of result graphs corresponding +-- to each set of variable bindings applied to the input graph. +-- This function is used for formward chaining substitutions, and +-- returns only those result graphs for which all query variables +-- are bound. +rdfQuerySubs :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] +rdfQuerySubs vars gr = + map fst $ filter (null . snd) $ rdfQuerySubsAll vars gr + +-- |Graph back-substitution function. +-- +-- Uses the supplied variable bindings from 'rdfQueryBack' to perform +-- a series of variable substitutions in a supplied graph, returning +-- a list of lists of result graphs corresponding to each set of variable +-- bindings applied to the input graphs. +-- +-- The outer list of the result contains alternative antecedent lists +-- that satisfy the query goal. Each inner list contains graphs that +-- must all be inferred to satisfy the query goal. +rdfQueryBackSubs :: + [[RDFVarBinding]] -> RDFGraph -> [[(RDFGraph,[RDFLabel])]] +rdfQueryBackSubs varss gr = [ rdfQuerySubsAll v gr | v <- varss ] + +-- |Graph substitution function. +-- +-- This function performs the substitutions and returns a list of +-- result graphs each paired with a list unbound variables in each. +rdfQuerySubsAll :: [RDFVarBinding] -> RDFGraph -> [(RDFGraph,[RDFLabel])] +rdfQuerySubsAll vars gr = [ rdfQuerySubs2 v gr | v <- vars ] + +-- |Graph substitution function. +-- +-- This function performs each of the substitutions in 'vars', and +-- replaces any nodes corresponding to unbound query variables +-- with new blank nodes. +rdfQuerySubsBlank :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] +rdfQuerySubsBlank vars gr = + [ remapLabels vs bs makeBlank g + | v <- vars + , let (g,vs) = rdfQuerySubs2 v gr + , let bs = allLabels isBlank g + ] + +-- |Graph back-substitution function, replacing variables with bnodes. +-- +-- Uses the supplied variable bindings from 'rdfQueryBack' to perform +-- a series of variable substitutions in a supplied graph, returning +-- a list of lists of result graphs corresponding to each set of variable +-- bindings applied to the input graphs. +-- +-- The outer list of the result contains alternative antecedent lists +-- that satisfy the query goal. Each inner list contains graphs that +-- must all be inferred to satisfy the query goal. +rdfQueryBackSubsBlank :: [[RDFVarBinding]] -> RDFGraph -> [[RDFGraph]] +rdfQueryBackSubsBlank varss gr = [ rdfQuerySubsBlank v gr | v <- varss ] + +-- |This function applies a substitution for a single set of variable +-- bindings, returning the result and a list of unbound variables. +-- It uses a state transformer monad to collect the list of +-- unbound variables. +-- +-- Adding an empty graph forces elimination of duplicate arcs. +rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph,[RDFLabel]) +rdfQuerySubs2 varb gr = (addGraphs mempty g, S.toList vs) + where + (g,vs) = runState ( Traversable.traverse (mapNode varb) gr ) S.empty + +-- Auxiliary monad function for rdfQuerySubs2. +-- This returns a state transformer Monad which in turn returns the +-- substituted node value based on the supplied query variable bindings. +-- The monad state is a set of labels which accumulates all those +-- variables seen for which no substitution was available. +mapNode :: RDFVarBinding -> RDFLabel -> State (S.Set RDFLabel) RDFLabel +mapNode varb lab = + case vbMap varb lab of + Just v -> return v + Nothing -> when (isQueryVar lab) (modify (S.insert lab)) >> return lab + +------------------------------------------------------------ +-- Simple lightweight query primitives +------------------------------------------------------------ +-- +-- [[[TODO: modify above code to use these for all graph queries]]] + +-- |Test if a value satisfies all predicates in a list +-- +allp :: [a->Bool] -> a -> Bool +allp ps a = and (flist ps a) + +{- +allptest0 = allp [(>=1),(>=2),(>=3)] 0 -- False +allptest1 = allp [(>=1),(>=2),(>=3)] 1 -- False +allptest2 = allp [(>=1),(>=2),(>=3)] 2 -- False +allptest3 = allp [(>=1),(>=2),(>=3)] 3 -- True +allptest = and [not allptest0,not allptest1,not allptest2,allptest3] +-} + +-- |Test if a value satisfies any predicate in a list +-- +anyp :: [a->Bool] -> a -> Bool +anyp ps a = or (flist ps a) + +{- +anyptest0 = anyp [(>=1),(>=2),(>=3)] 0 -- False +anyptest1 = anyp [(>=1),(>=2),(>=3)] 1 -- True +anyptest2 = anyp [(>=1),(>=2),(>=3)] 2 -- True +anyptest3 = anyp [(>=1),(>=2),(>=3)] 3 -- True +anyptest = and [not anyptest0,anyptest1,anyptest2,anyptest3] +-} + + +-- |Take a predicate on an +-- RDF statement and a graph, and returns all statements in the graph +-- satisfying that predicate. +-- +-- Use combinations of these as follows: +-- +-- * find all statements with given subject: +-- @rdfFindArcs (rdfSubjEq s)@ +-- +-- * find all statements with given property: +-- @rdfFindArcs (rdfPredEq p)@ +-- +-- * find all statements with given object: +-- @rdfFindArcs (rdfObjEq o)@ +-- +-- * find all statements matching conjunction of these conditions: +-- @rdfFindArcs ('allp' [...])@ +-- +-- * find all statements matching disjunction of these conditions: +-- @rdfFindArcs ('anyp' [...])@ +-- +-- Custom predicates can also be used. +-- +rdfFindArcs :: (RDFTriple -> Bool) -> RDFGraph -> [RDFTriple] +rdfFindArcs p = filter p . getArcs + +-- |Test if statement has given subject +rdfSubjEq :: RDFLabel -> RDFTriple -> Bool +rdfSubjEq s = (s==) . arcSubj + +-- |Test if statement has given predicate +rdfPredEq :: RDFLabel -> RDFTriple -> Bool +rdfPredEq p = (p==) . arcPred + +-- |Test if statement has given object +rdfObjEq :: RDFLabel -> RDFTriple -> Bool +rdfObjEq o = (o==) . arcObj + +{- +-- |Find statements with given subject +rdfFindSubj :: RDFLabel -> RDFGraph -> [RDFTriple] +rdfFindSubj s = rdfFindArcs (rdfSubjEq s) + +-- |Find statements with given predicate +rdfFindPred :: RDFLabel -> RDFGraph -> [RDFTriple] +rdfFindPred p = rdfFindArcs (rdfPredEq p) +-} + +-- |Find values of given predicate for a given subject +rdfFindPredVal :: + RDFLabel -- ^ subject + -> RDFLabel -- ^ predicate + -> RDFGraph + -> [RDFLabel] +rdfFindPredVal s p = map arcObj . rdfFindArcs (allp [rdfSubjEq s,rdfPredEq p]) + +-- |Find integer values of a given predicate for a given subject +rdfFindPredInt :: + RDFLabel -- ^ subject + -> RDFLabel -- ^ predicate + -> RDFGraph -> [Integer] +rdfFindPredInt s p = mapMaybe getint . filter isint . pvs + where + pvs = rdfFindPredVal s p + isint = anyp + [ isDatatyped xsdInteger + , isDatatyped xsdNonNegInteger + ] + getint = mapL2V mapXsdInteger . getLiteralText + +-- |Find all subjects that match (subject, predicate, object) in the graph. +rdfFindValSubj :: + RDFLabel -- ^ predicate + -> RDFLabel -- ^ object + -> RDFGraph + -> [RDFLabel] +rdfFindValSubj p o = map arcSubj . rdfFindArcs (allp [rdfPredEq p,rdfObjEq o]) + +------------------------------------------------------------ +-- List query +------------------------------------------------------------ + +-- |Return a list of nodes that comprise an rdf:collection value, +-- given the head element of the collection. If the list is +-- ill-formed then an arbitrary value is returned. +-- +rdfFindList :: RDFGraph -> RDFLabel -> [RDFLabel] +rdfFindList gr hd = findhead $ rdfFindList gr findrest + where + findhead = headOr (const []) $ + map (:) (rdfFindPredVal hd resRdfFirst gr) + findrest = headOr resRdfNil (rdfFindPredVal hd resRdfRest gr) + {- + findhead = headOr (const []) + [ (ob:) | Arc _ sb ob <- subgr, sb == resRdfFirst ] + findrest = headOr resRdfNil + [ ob | Arc _ sb ob <- subgr, sb == resRdfRest ] + subgr = filter ((==) hd . arcSubj) $ getArcs gr + -} + headOr = foldr const + -- headOr _ (x:_) = x + -- headOr x [] = x + +------------------------------------------------------------ +-- Interactive tests +------------------------------------------------------------ + +{- +s1 = Blank "s1" +p1 = Blank "p1" +o1 = Blank "o1" +s2 = Blank "s2" +p2 = Blank "p2" +o2 = Blank "o2" +qs1 = Var "s1" +qp1 = Var "p1" +qo1 = Var "o1" +qs2 = Var "s2" +qp2 = Var "p2" +qo2 = Var "o2" + +qa1 = Arc qs1 qp1 qo1 +qa2 = Arc qs2 qp2 qo2 +qa3 = Arc qs2 p2 qo2 +ta1 = Arc s1 p1 o1 +ta2 = Arc s2 p2 o2 + +g1 = toRDFGraph [ta1,ta2] +g2 = toRDFGraph [qa3] + +gb1 = getBinding matchQueryVariable qa1 ta1 -- ?s1=_:s1, ?p1=_:p1, ?o1=_:o1 +gvs1 = qbMap (fromJust gb1) qs1 -- _:s1 +gvp1 = qbMap (fromJust gb1) qp1 -- _:p1 +gvo1 = qbMap (fromJust gb1) qo1 -- _:o1 +gvs2 = qbMap (fromJust gb1) qs2 -- Nothing + +gb3 = getBinding matchQueryVariable qa3 ta1 -- Nothing +gb4 = getBinding matchQueryVariable qa3 ta2 -- ?s2=_:s1, ?o2=_:o1 + +mqvs1 = matchQueryVariable qs2 s1 +mqvp1 = matchQueryVariable p2 p1 + +-- rdfQueryFind + +qfa = rdfQueryFind g2 g1 + +qp2a = rdfQueryPrim2 matchQueryVariable qa3 g1 +-} + +{- more tests + +qb1a = rdfQueryBack1 [] [qa1] [ta1,ta2] +qb1 = rdfQueryBack1 [] [qa1,qa2] [ta1,ta2] +ql1 = length qb1 +qv1 = map (qb1!!0!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv2 = map (qb1!!0!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv3 = map (qb1!!1!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv4 = map (qb1!!1!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv5 = map (qb1!!2!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv6 = map (qb1!!2!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv7 = map (qb1!!3!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv8 = map (qb1!!3!!1) [qs1,qp1,qo1,qs2,qp2,qo2] + +qb2 = rdfQueryBack2 matchQueryVariable [qa1,qa2] ta1 +ql2 = length qb2 +qv1 = map (qbMap $ head qb2) [qs1,qp1,qo1,qs2,qp2,qo2] +qv2 = map (qbMap $ head $ tail qb2) [qs1,qp1,qo1,qs2,qp2,qo2] +qb3 = rdfQueryBack2 matchQueryVariable [qa1,qa3] ta1 + +-} + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFDatatype.hs b/src/Swish/RDF/RDFDatatype.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFDatatype.hs +++ /dev/null @@ -1,202 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatype --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module defines the structures used by Swish to represent and --- manipulate RDF datatypes. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , RDFModifierFn, RDFApplyModifier - , makeRdfDtOpenVarBindingModify, makeRdfDtOpenVarBindingModifiers - , applyRDFDatatypeMod - , RDFDatatypeSub - , fromRDFLabel, toRDFLabel, makeDatatypedLiteral - ) -where - -import Swish.RDF.RDFGraph - ( RDFLabel(..) - , isDatatyped - , getLiteralText - , RDFGraph - ) - -import Swish.RDF.RDFVarBinding - ( RDFVarBinding, RDFOpenVarBindingModify ) - -import Swish.RDF.Datatype - ( Datatype -- , typeName, typeRules - , DatatypeVal(..) - , DatatypeMap(..) - , DatatypeMod(..), ModifierFn - , ApplyModifier - , DatatypeSub(..) - ) - -import Swish.RDF.VarBinding (VarBindingModify(..)) -import Swish.Utils.Namespace (ScopedName) - -import Control.Monad (liftM) -import Data.Maybe (fromMaybe, isJust, fromJust) - -import qualified Data.Text as T - ------------------------------------------------------------- --- Specialize datatype framework types for use with RDF ------------------------------------------------------------- - --- |RDF datatype wrapper used with RDF graph values --- -type RDFDatatype = Datatype RDFGraph RDFLabel RDFLabel - --- |RDF datatype value used with RDF graph values --- -type RDFDatatypeVal vt = DatatypeVal RDFGraph vt RDFLabel RDFLabel - --- |RDF datatype modifier used with RDF graph values --- -type RDFDatatypeMod vt = DatatypeMod vt RDFLabel RDFLabel - --- |Describe a subtype/supertype relationship between a pair --- of RDF datatypes. --- -type RDFDatatypeSub supvt subvt = DatatypeSub RDFGraph RDFLabel RDFLabel supvt subvt - --- |RDF value modifier function type --- --- This indicates a modifier function that operates on 'RDFLabel' values. --- -type RDFModifierFn = ModifierFn RDFLabel - --- |RDF value modifier application function type --- --- This indicates a function that applies RDFModifierFn functions. --- -type RDFApplyModifier = ApplyModifier RDFLabel RDFLabel - --------------------------------------------------------------- --- Functions for creating datatype variable binding modifiers --------------------------------------------------------------- - --- |Create an 'RDFOpenVarBindingModify' value. --- --- The key purpose of this function is to lift the supplied --- variable constraint functions from operating on data values directly --- to a corresponding list of functions that operate on values contained --- in RDF graph labels (i.e. RDF literal nodes). It also applies --- node type checking, such that if the actual RDF nodes supplied do --- not contain appropriate values then the variable binding is not --- accepted. --- -makeRdfDtOpenVarBindingModify :: - RDFDatatypeVal vt - -- ^ is an 'RDFDatatype' value containing details of the datatype - -- for which a variable binding modifier is created. - -> RDFDatatypeMod vt - -- ^ is the data value modifier value that defines the calculations - -- that are used to implement a variable binding modifier. - -> RDFOpenVarBindingModify -makeRdfDtOpenVarBindingModify dtval dtmod = - dmAppf dtmod (dmName dtmod) $ map (makeRDFModifierFn dtval) (dmModf dtmod) - --- |Create all RDFOpenVarBindingModify values for a given datatype value. --- See 'makeRdfDtOpenVarBindingModify'. --- -makeRdfDtOpenVarBindingModifiers :: - RDFDatatypeVal vt - -- ^ is an 'RDFDatatype' value containing details of the datatype - -- for which variable binding modifiers are created. - -> [RDFOpenVarBindingModify] -makeRdfDtOpenVarBindingModifiers dtval = - map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) - --- |Apply a datatype modifier using supplied RDF labels to a supplied --- RDF variable binding. --- -applyRDFDatatypeMod :: - RDFDatatypeVal vt -> RDFDatatypeMod vt -> [RDFLabel] -> [RDFVarBinding] - -> [RDFVarBinding] -applyRDFDatatypeMod dtval dtmod lbs = - vbmApply (makeRdfDtOpenVarBindingModify dtval dtmod lbs) - --- |Given details of a datatype and a single value constraint function, --- return a new constraint function that operates on 'RDFLabel' values. --- --- The returned constraint function incorporates checks for appropriately --- typed literal nodes, and returns similarly typed literal nodes. --- -makeRDFModifierFn :: - RDFDatatypeVal vt -> ModifierFn vt -> RDFModifierFn -makeRDFModifierFn dtval fn ivs = - let - ivals = mapM (fromRDFLabel dtval) ivs - ovals | isJust ivals = fn (fromJust ivals) - | otherwise = [] - in - fromMaybe [] $ mapM (toRDFLabel dtval) ovals - ------------------------------------------------------------- --- Helpers to map between datatype values and RDFLabels ------------------------------------------------------------- - --- | Convert from a typed literal to a Haskell value, --- with the possibility of failure. -fromRDFLabel :: - RDFDatatypeVal vt -> RDFLabel -> Maybe vt -fromRDFLabel dtv lab - | isDatatyped dtnam lab = mapL2V dtmap $ getLiteralText lab - | otherwise = Nothing - where - dtnam = tvalName dtv - dtmap = tvalMap dtv - --- | Convert a Haskell value to a typed literal (label), --- with the possibility of failure. -toRDFLabel :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel -toRDFLabel dtv = - liftM (makeDatatypedLiteral dtnam) . mapV2L dtmap - where - dtnam = tvalName dtv - dtmap = tvalMap dtv - --- | Create a typed literal from the given value. -makeDatatypedLiteral :: ScopedName -> T.Text -> RDFLabel -makeDatatypedLiteral dtnam txtval = - Lit txtval (Just dtnam) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFDatatypeXsdDecimal.hs b/src/Swish/RDF/RDFDatatypeXsdDecimal.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFDatatypeXsdDecimal.hs +++ /dev/null @@ -1,487 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdDecimal --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, --- 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines the structures used by Swish to represent and --- manipulate RDF @xsd:double@ datatyped literals. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFDatatypeXsdDecimal - ( rdfDatatypeXsdDecimal - , rdfDatatypeValXsdDecimal - , typeNameXsdDecimal, namespaceXsdDecimal - , axiomsXsdDecimal, rulesXsdDecimal - , prefixXsdDecimal - ) -where - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset - , makeRDFGraphFromN3Builder - , makeRDFFormula - ) - -import Swish.RDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , makeRdfDtOpenVarBindingModifiers - ) - -import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) -import Swish.RDF.MapXsdDecimal (mapXsdDecimal) - -import Swish.RDF.Datatype - ( Datatype(..) - , DatatypeVal(..) - , DatatypeRel(..), DatatypeRelPr - , altArgs - , UnaryFnTable, unaryFnApp - , BinaryFnTable, binaryFnApp - , DatatypeMod(..) - , makeVmod11inv, makeVmod11 - , makeVmod21inv, makeVmod21 - , makeVmod20 - ) - -import Swish.RDF.Ruleset (makeRuleset) - -import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder, makeNSScopedName) - -import Swish.RDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceXsdType - ) - -import Data.Monoid(Monoid(..)) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - --- Local name for Double datatype -nameXsdDecimal :: T.Text -nameXsdDecimal = "decimal" - --- |Type name for xsd:double datatype -typeNameXsdDecimal :: ScopedName -typeNameXsdDecimal = makeNSScopedName namespaceXSD nameXsdDecimal - --- |Namespace for xsd:double datatype functions -namespaceXsdDecimal :: Namespace -namespaceXsdDecimal = namespaceXsdType nameXsdDecimal - ------------------------------------------------------------- --- Declare exported RDFDatatype value for xsd:double ------------------------------------------------------------- - -rdfDatatypeXsdDecimal :: RDFDatatype -rdfDatatypeXsdDecimal = Datatype rdfDatatypeValXsdDecimal - ------------------------------------------------------------- --- Implmentation of RDFDatatypeVal for xsd:double ------------------------------------------------------------- - --- |Define Datatype value for @xsd:double@. --- --- Members of this datatype decimal values. --- --- The lexical form consists of an optional @+@ or @-@ --- followed by a sequence of decimal digits. --- --- The canonical lexical form has leading zeros and @+@ sign removed. --- -rdfDatatypeValXsdDecimal :: RDFDatatypeVal Double -rdfDatatypeValXsdDecimal = DatatypeVal - { tvalName = typeNameXsdDecimal - , tvalRules = rdfRulesetXsdDecimal -- Ruleset RDFGraph - , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdDecimal - -- RDFGraph -> [RDFRules] - , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdDecimal - , tvalMap = mapXsdDecimal -- DatatypeMap Double - , tvalRel = relXsdDecimal -- [DatatypeRel Double] - , tvalMod = modXsdDecimal -- [DatatypeMod Double] - } - --- |relXsdDecimal contains arithmetic and other relations for xsd:double values. --- --- The functions are inspired by those defined by CWM as math: properties --- (). --- -relXsdDecimal :: [DatatypeRel Double] -relXsdDecimal = - [ relXsdDecimalAbs - , relXsdDecimalNeg - , relXsdDecimalSum - , relXsdDecimalDiff - , relXsdDecimalProd - , relXsdDecimalPower - , relXsdDecimalEq - , relXsdDecimalNe - , relXsdDecimalLt - , relXsdDecimalLe - , relXsdDecimalGt - , relXsdDecimalGe - ] - -mkDecRel2 :: - T.Text -> DatatypeRelPr Double -> UnaryFnTable Double - -> DatatypeRel Double -mkDecRel2 nam pr fns = DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdDecimal nam - , dtRelFunc = altArgs pr fns unaryFnApp - } - -mkDecRel3 :: - T.Text -> DatatypeRelPr Double -> BinaryFnTable Double - -> DatatypeRel Double -mkDecRel3 nam pr fns = DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdDecimal nam - , dtRelFunc = altArgs pr fns binaryFnApp - } - -relXsdDecimalAbs :: DatatypeRel Double -relXsdDecimalAbs = mkDecRel2 "abs" (const True) - [ ( (>=0), [ (abs,1) ] ) - , ( const True, [ (id,0), (negate,0) ] ) - ] - -relXsdDecimalNeg :: DatatypeRel Double -relXsdDecimalNeg = mkDecRel2 "neg" (const True) - [ ( const True, [ (negate,1) ] ) - , ( const True, [ (negate,0) ] ) - ] - -relXsdDecimalSum :: DatatypeRel Double -relXsdDecimalSum = mkDecRel3 "sum" (const True) - [ ( const True, [ ((+),1,2) ] ) - , ( const True, [ ((-),0,2) ] ) - , ( const True, [ ((-),0,1) ] ) - ] - -relXsdDecimalDiff :: DatatypeRel Double -relXsdDecimalDiff = mkDecRel3 "diff" (const True) - [ ( const True, [ ((-),1,2) ] ) - , ( const True, [ ((+),0,2) ] ) - , ( const True, [ ((-),1,0) ] ) - ] - -relXsdDecimalProd :: DatatypeRel Double -relXsdDecimalProd = mkDecRel3 "prod" (const True) - [ ( const True, [ ((*),1,2) ] ) - , ( const True, [ ((/),0,2) ] ) - , ( const True, [ ((/),0,1) ] ) - ] - -relXsdDecimalPower :: DatatypeRel Double -relXsdDecimalPower = mkDecRel3 "power" (const True) - [ ( const True, [ ((**),1,2) ] ) - , ( const True, [ ] ) - , ( (>=0), [ ] ) - ] - -liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool -liftL2 p i1 i2 as = p (i1 as) (i2 as) - -lcomp :: (a->a->Bool) -> [a] -> Bool -lcomp p = liftL2 p head (head . tail) - --- eq - -relXsdDecimalEq :: DatatypeRel Double -relXsdDecimalEq = mkDecRel2 "eq" (lcomp (==)) - ( repeat (const True, []) ) - --- ne - -relXsdDecimalNe :: DatatypeRel Double -relXsdDecimalNe = mkDecRel2 "ne" (lcomp (/=)) - ( repeat (const True, []) ) - --- lt - -relXsdDecimalLt :: DatatypeRel Double -relXsdDecimalLt = mkDecRel2 "lt" (lcomp (<)) - ( repeat (const True, []) ) - --- le - -relXsdDecimalLe :: DatatypeRel Double -relXsdDecimalLe = mkDecRel2 "le" (lcomp (<=)) - ( repeat (const True, []) ) - --- gt - -relXsdDecimalGt :: DatatypeRel Double -relXsdDecimalGt = mkDecRel2 "gt" (lcomp (>)) - ( repeat (const True, []) ) - --- ge - -relXsdDecimalGe :: DatatypeRel Double -relXsdDecimalGe = mkDecRel2 "ge" (lcomp (>=)) - ( repeat (const True, []) ) - --- |modXsdDecimal contains variable binding modifiers for xsd:double values. --- --- The functions are selected from those defined by CWM as math: --- properties --- (). --- -modXsdDecimal :: [RDFDatatypeMod Double] -modXsdDecimal = - [ modXsdDecimalAbs - , modXsdDecimalNeg - , modXsdDecimalSum - , modXsdDecimalDiff - , modXsdDecimalProd - , modXsdDecimalPower - , modXsdDecimalEq - , modXsdDecimalNe - , modXsdDecimalLt - , modXsdDecimalLe - , modXsdDecimalGt - , modXsdDecimalGe - ] - -modXsdDecimalAbs :: RDFDatatypeMod Double -modXsdDecimalAbs = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "abs" - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod11 - } - where - f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] - f0 _ = [] - f1 [v2] = [abs v2] - f1 _ = [] - -modXsdDecimalNeg :: RDFDatatypeMod Double -modXsdDecimalNeg = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "neg" - , dmModf = [ f0, f1, f1 ] - , dmAppf = makeVmod11inv - } - where - f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] - f0 _ = [] - f1 [vi] = [-vi] - f1 _ = [] - -modXsdDecimalSum :: RDFDatatypeMod Double -modXsdDecimalSum = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "sum" - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2+v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2+v3] - f1 _ = [] - f2 [v1,vi] = [v1-vi] - f2 _ = [] - -modXsdDecimalDiff :: RDFDatatypeMod Double -modXsdDecimalDiff = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "diff" - , dmModf = [ f0, f1, f2, f3 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2-v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2-v3] - f1 _ = [] - f2 [v1,v3] = [v1+v3] - f2 _ = [] - f3 [v1,v2] = [v2-v1] - f3 _ = [] - -modXsdDecimalProd :: RDFDatatypeMod Double -modXsdDecimalProd = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "prod" - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2*v3] - f1 _ = [] - f2 [v1,vi] = [v1/vi] - f2 _ = [] - -modXsdDecimalPower :: RDFDatatypeMod Double -modXsdDecimalPower = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal "power" - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod21 - } - where - f0 vs@[v1,v2,v3] = if v1 == (v2**v3 :: Double) then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2**v3 :: Double] - f1 _ = [] - -modXsdDecimalEq, modXsdDecimalNe, modXsdDecimalLt, modXsdDecimalLe, modXsdDecimalGt, modXsdDecimalGe :: RDFDatatypeMod Double -modXsdDecimalEq = modXsdDecimalCompare "eq" (==) -modXsdDecimalNe = modXsdDecimalCompare "ne" (/=) -modXsdDecimalLt = modXsdDecimalCompare "lt" (<) -modXsdDecimalLe = modXsdDecimalCompare "le" (<=) -modXsdDecimalGt = modXsdDecimalCompare "gt" (>) -modXsdDecimalGe = modXsdDecimalCompare "ge" (>=) - -modXsdDecimalCompare :: - T.Text -> (Double->Double->Bool) -> RDFDatatypeMod Double -modXsdDecimalCompare nam rel = DatatypeMod - { dmName = makeNSScopedName namespaceXsdDecimal nam - , dmModf = [ f0 ] - , dmAppf = makeVmod20 - } - where - f0 vs@[v1,v2] = if rel v1 v2 then vs else [] - f0 _ = [] - --- |rulesetXsdDecimal contains rules and axioms that allow additional --- deductions when xsd:double values appear in a graph. --- --- The rules defined here are concerned with basic decimal arithmetic --- operations: +, -, *, /, ** --- --- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex --- -rdfRulesetXsdDecimal :: RDFRuleset -rdfRulesetXsdDecimal = - makeRuleset namespaceXsdDecimal axiomsXsdDecimal rulesXsdDecimal - -mkPrefix :: Namespace -> B.Builder -mkPrefix = namespaceToBuilder - -prefixXsdDecimal :: B.Builder -prefixXsdDecimal = - mconcat - [ mkPrefix namespaceRDF - , mkPrefix namespaceRDFS - , mkPrefix namespaceRDFD - , mkPrefix namespaceXSD - , mkPrefix namespaceXsdDecimal - ] - -mkAxiom :: T.Text -> B.Builder -> RDFFormula -mkAxiom local gr = - makeRDFFormula namespaceXsdDecimal local (prefixXsdDecimal `mappend` gr) - -axiomsXsdDecimal :: [RDFFormula] -axiomsXsdDecimal = - [ mkAxiom "dt" "xsd:double rdf:type rdfs:Datatype ." - ] - -rulesXsdDecimal :: [RDFRule] -rulesXsdDecimal = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdDecimal gr - where - gr = makeRDFGraphFromN3Builder rulesXsdDecimalBuilder - ---- I have removed the newline which was added between each line ---- to improve the clarity of parser errors. ---- -rulesXsdDecimalBuilder :: B.Builder -rulesXsdDecimalBuilder = - mconcat - [ prefixXsdDecimal - , "xsd_decimal:Abs a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:abs ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Neg a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:neg ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Sum a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_decimal:sum ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Diff a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_decimal:diff ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Prod a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_decimal:prod ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:DivMod a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; " - , " rdfd:constraint xsd_decimal:divmod ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Power a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_decimal:power ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Eq a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:eq ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Ne a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:ne ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Lt a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:lt ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Le a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:le ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Gt a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:gt ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_decimal:Ge a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_decimal:ge ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - ] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, --- 2011 Douglas Burke, 2011 William Waites --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFDatatypeXsdInteger.hs b/src/Swish/RDF/RDFDatatypeXsdInteger.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFDatatypeXsdInteger.hs +++ /dev/null @@ -1,539 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdInteger --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines the structures used by Swish to represent and --- manipulate RDF @xsd:integer@ datatyped literals. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFDatatypeXsdInteger - ( rdfDatatypeXsdInteger - , rdfDatatypeValXsdInteger - , typeNameXsdInteger, namespaceXsdInteger - , axiomsXsdInteger, rulesXsdInteger - , prefixXsdInteger - ) -where - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset - , makeRDFGraphFromN3Builder - , makeRDFFormula - ) - -import Swish.RDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , makeRdfDtOpenVarBindingModifiers - ) - -import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) -import Swish.RDF.MapXsdInteger (mapXsdInteger) - -import Swish.RDF.Datatype - ( Datatype(..) - , DatatypeVal(..) - , DatatypeRel(..), DatatypeRelPr - , altArgs - , UnaryFnTable, unaryFnApp - , BinaryFnTable, binaryFnApp - , BinMaybeFnTable, binMaybeFnApp - , DatatypeMod(..) - , makeVmod11inv, makeVmod11 - , makeVmod21inv, makeVmod21 - , makeVmod20 - , makeVmod22 - ) - -import Swish.RDF.Ruleset (makeRuleset) - -import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder, makeNSScopedName) - -import Swish.RDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceXsdType - ) - -import Data.Monoid(Monoid(..)) -import Control.Monad (liftM) -import Data.Maybe (maybeToList) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - --- Local name for Integer datatype -nameXsdInteger :: T.Text -nameXsdInteger = "integer" - --- |Type name for xsd:integer datatype -typeNameXsdInteger :: ScopedName -typeNameXsdInteger = makeNSScopedName namespaceXSD nameXsdInteger - --- |Namespace for xsd:integer datatype functions -namespaceXsdInteger :: Namespace -namespaceXsdInteger = namespaceXsdType nameXsdInteger - --- Compose with function of two arguments -c2 :: (b -> c) -> (a -> d -> b) -> a -> d -> c -c2 = (.) . (.) - --- Integer power (exponentiation) function --- returns Nothing if exponent is negative. --- -intPower :: Integer -> Integer -> Maybe Integer -intPower a b = if b < 0 then Nothing else Just (intPower1 a b) - where - intPower1 x y - | q == 1 = atopsq*x - | p == 0 = 1 - | otherwise = atopsq - where - (p,q) = y `divMod` 2 - atop = intPower1 x p - atopsq = atop*atop - ------------------------------------------------------------- --- Declare exported RDFDatatype value for xsd:integer ------------------------------------------------------------- - -rdfDatatypeXsdInteger :: RDFDatatype -rdfDatatypeXsdInteger = Datatype rdfDatatypeValXsdInteger - ------------------------------------------------------------- --- Implmentation of RDFDatatypeVal for xsd:integer ------------------------------------------------------------- - --- |Define Datatype value for @xsd:integer@. --- --- Members of this datatype are positive or negative integer values. --- --- The lexical form consists of an optional @+@ or @-@ --- followed by a sequence of decimal digits. --- --- The canonical lexical form has leading zeros and @+@ sign removed. --- -rdfDatatypeValXsdInteger :: RDFDatatypeVal Integer -rdfDatatypeValXsdInteger = DatatypeVal - { tvalName = typeNameXsdInteger - , tvalRules = rdfRulesetXsdInteger -- Ruleset RDFGraph - , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger - -- RDFGraph -> [RDFRules] - , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdInteger - , tvalMap = mapXsdInteger -- DatatypeMap Integer - , tvalRel = relXsdInteger -- [DatatypeRel Integer] - , tvalMod = modXsdInteger -- [DatatypeMod Integer] - } - --- |relXsdInteger contains arithmetic and other relations for xsd:Integer values. --- --- The functions are inspired by those defined by CWM as math: properties --- (). --- -relXsdInteger :: [DatatypeRel Integer] -relXsdInteger = - [ relXsdIntegerAbs - , relXsdIntegerNeg - , relXsdIntegerSum - , relXsdIntegerDiff - , relXsdIntegerProd - , relXsdIntegerDivMod - , relXsdIntegerPower - , relXsdIntegerEq - , relXsdIntegerNe - , relXsdIntegerLt - , relXsdIntegerLe - , relXsdIntegerGt - , relXsdIntegerGe - ] - -mkIntRel2 :: - T.Text -> DatatypeRelPr Integer -> UnaryFnTable Integer - -> DatatypeRel Integer -mkIntRel2 nam pr fns = DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns unaryFnApp - } - -mkIntRel3 :: - T.Text -> DatatypeRelPr Integer -> BinaryFnTable Integer - -> DatatypeRel Integer -mkIntRel3 nam pr fns = DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns binaryFnApp - } - -mkIntRel3maybe :: - T.Text -> DatatypeRelPr Integer -> BinMaybeFnTable Integer - -> DatatypeRel Integer -mkIntRel3maybe nam pr fns = DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns binMaybeFnApp - } - -relXsdIntegerAbs :: DatatypeRel Integer -relXsdIntegerAbs = mkIntRel2 "abs" (const True) - [ ( (>=0), [ (abs,1) ] ) - , ( const True, [ (id,0), (negate,0) ] ) - ] - -relXsdIntegerNeg :: DatatypeRel Integer -relXsdIntegerNeg = mkIntRel2 "neg" (const True) - [ ( const True, [ (negate,1) ] ) - , ( const True, [ (negate,0) ] ) - ] - -relXsdIntegerSum :: DatatypeRel Integer -relXsdIntegerSum = mkIntRel3 "sum" (const True) - [ ( const True, [ ((+),1,2) ] ) - , ( const True, [ ((-),0,2) ] ) - , ( const True, [ ((-),0,1) ] ) - ] - -relXsdIntegerDiff :: DatatypeRel Integer -relXsdIntegerDiff = mkIntRel3 "diff" (const True) - [ ( const True, [ ((-),1,2) ] ) - , ( const True, [ ((+),0,2) ] ) - , ( const True, [ ((-),1,0) ] ) - ] - -relXsdIntegerProd :: DatatypeRel Integer -relXsdIntegerProd = mkIntRel3 "prod" (const True) - [ ( const True, [ ((*),1,2) ] ) - , ( const True, [ (div,0,2) ] ) - , ( const True, [ (div,0,1) ] ) - ] - -relXsdIntegerDivMod :: DatatypeRel Integer -relXsdIntegerDivMod = mkIntRel3 "divmod" (const True) - [ ( const True, [ (div,2,3) ] ) - , ( const True, [ (mod,2,3) ] ) - , ( const True, [ ] ) - , ( const True, [ ] ) - ] - -relXsdIntegerPower :: DatatypeRel Integer -relXsdIntegerPower = mkIntRel3maybe "power" (const True) - [ ( const True, [ (liftM (:[]) `c2` intPower,1,2) ] ) - , ( const True, [ ] ) - , ( (>=0), [ ] ) - ] - -liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool -liftL2 p i1 i2 as = p (i1 as) (i2 as) - -lcomp :: (a->a->Bool) -> [a] -> Bool -lcomp p = liftL2 p head (head . tail) - --- eq - -relXsdIntegerEq :: DatatypeRel Integer -relXsdIntegerEq = mkIntRel2 "eq" (lcomp (==)) - ( repeat (const True, []) ) - --- ne - -relXsdIntegerNe :: DatatypeRel Integer -relXsdIntegerNe = mkIntRel2 "ne" (lcomp (/=)) - ( repeat (const True, []) ) - --- lt - -relXsdIntegerLt :: DatatypeRel Integer -relXsdIntegerLt = mkIntRel2 "lt" (lcomp (<)) - ( repeat (const True, []) ) - --- le - -relXsdIntegerLe :: DatatypeRel Integer -relXsdIntegerLe = mkIntRel2 "le" (lcomp (<=)) - ( repeat (const True, []) ) - --- gt - -relXsdIntegerGt :: DatatypeRel Integer -relXsdIntegerGt = mkIntRel2 "gt" (lcomp (>)) - ( repeat (const True, []) ) - --- ge - -relXsdIntegerGe :: DatatypeRel Integer -relXsdIntegerGe = mkIntRel2 "ge" (lcomp (>=)) - ( repeat (const True, []) ) - --- |modXsdInteger contains variable binding modifiers for xsd:Integer values. --- --- The functions are selected from those defined by CWM as math: --- properties --- (). --- -modXsdInteger :: [RDFDatatypeMod Integer] -modXsdInteger = - [ modXsdIntegerAbs - , modXsdIntegerNeg - , modXsdIntegerSum - , modXsdIntegerDiff - , modXsdIntegerProd - , modXsdIntegerDivMod - , modXsdIntegerPower - , modXsdIntegerEq - , modXsdIntegerNe - , modXsdIntegerLt - , modXsdIntegerLe - , modXsdIntegerGt - , modXsdIntegerGe - ] - -modXsdIntegerAbs :: RDFDatatypeMod Integer -modXsdIntegerAbs = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "abs" - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod11 - } - where - f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] - f0 _ = [] - f1 [v2] = [abs v2] - f1 _ = [] - -modXsdIntegerNeg :: RDFDatatypeMod Integer -modXsdIntegerNeg = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "neg" - , dmModf = [ f0, f1, f1 ] - , dmAppf = makeVmod11inv - } - where - f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] - f0 _ = [] - f1 [vi] = [-vi] - f1 _ = [] - -modXsdIntegerSum :: RDFDatatypeMod Integer -modXsdIntegerSum = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "sum" - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2+v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2+v3] - f1 _ = [] - f2 [v1,vi] = [v1-vi] - f2 _ = [] - -modXsdIntegerDiff :: RDFDatatypeMod Integer -modXsdIntegerDiff = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "diff" - , dmModf = [ f0, f1, f2, f3 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2-v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2-v3] - f1 _ = [] - f2 [v1,v3] = [v1+v3] - f2 _ = [] - f3 [v1,v2] = [v2-v1] - f3 _ = [] - -modXsdIntegerProd :: RDFDatatypeMod Integer -modXsdIntegerProd = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "prod" - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod21inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2*v3] - f1 _ = [] - f2 [v1,vi] = if r == 0 then [q] else [] - where (q,r) = quotRem v1 vi - f2 _ = [] - -modXsdIntegerDivMod :: RDFDatatypeMod Integer -modXsdIntegerDivMod = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "divmod" - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod22 - } - where - f0 vs@[v1,v2,v3,v4] = if (v1,v2) == divMod v3 v4 then vs else [] - f0 _ = [] - f1 [v3,v4] = [v1,v2] where (v1,v2) = divMod v3 v4 - f1 _ = [] - -modXsdIntegerPower :: RDFDatatypeMod Integer -modXsdIntegerPower = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger "power" - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod21 - } - where - f0 vs@[v1,v2,v3] = if Just v1 == intPower v2 v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = maybeToList (intPower v2 v3) - f1 _ = [] - -modXsdIntegerEq, modXsdIntegerNe, modXsdIntegerLt, modXsdIntegerLe, modXsdIntegerGt, modXsdIntegerGe :: RDFDatatypeMod Integer -modXsdIntegerEq = modXsdIntegerCompare "eq" (==) -modXsdIntegerNe = modXsdIntegerCompare "ne" (/=) -modXsdIntegerLt = modXsdIntegerCompare "lt" (<) -modXsdIntegerLe = modXsdIntegerCompare "le" (<=) -modXsdIntegerGt = modXsdIntegerCompare "gt" (>) -modXsdIntegerGe = modXsdIntegerCompare "ge" (>=) - -modXsdIntegerCompare :: - T.Text -> (Integer->Integer->Bool) -> RDFDatatypeMod Integer -modXsdIntegerCompare nam rel = DatatypeMod - { dmName = makeNSScopedName namespaceXsdInteger nam - , dmModf = [ f0 ] - , dmAppf = makeVmod20 - } - where - f0 vs@[v1,v2] = if rel v1 v2 then vs else [] - f0 _ = [] - --- |rulesetXsdInteger contains rules and axioms that allow additional --- deductions when xsd:integer values appear in a graph. --- --- The rules defined here are concerned with basic integer arithmetic --- operations: +, -, *, div, rem --- --- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex --- -rdfRulesetXsdInteger :: RDFRuleset -rdfRulesetXsdInteger = - makeRuleset namespaceXsdInteger axiomsXsdInteger rulesXsdInteger - -mkPrefix :: Namespace -> B.Builder -mkPrefix = namespaceToBuilder - -prefixXsdInteger :: B.Builder -prefixXsdInteger = - mconcat - [ mkPrefix namespaceRDF - , mkPrefix namespaceRDFS - , mkPrefix namespaceRDFD - , mkPrefix namespaceXSD - , mkPrefix namespaceXsdInteger - ] - -mkAxiom :: T.Text -> B.Builder -> RDFFormula -mkAxiom local gr = - makeRDFFormula namespaceXsdInteger local (prefixXsdInteger `mappend` gr) - -axiomsXsdInteger :: [RDFFormula] -axiomsXsdInteger = - [ mkAxiom "dt" "xsd:integer rdf:type rdfs:Datatype ." - ] - -rulesXsdInteger :: [RDFRule] -rulesXsdInteger = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr - where - gr = makeRDFGraphFromN3Builder rulesXsdIntegerBuilder - ---- I have removed the newline which was added between each line ---- to improve the clarity of parser errors. ---- -rulesXsdIntegerBuilder :: B.Builder -rulesXsdIntegerBuilder = - mconcat - [ prefixXsdInteger - , "xsd_integer:Abs a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:abs ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Neg a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:neg ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Sum a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_integer:sum ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Diff a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_integer:diff ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Prod a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_integer:prod ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:DivMod a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; " - , " rdfd:constraint xsd_integer:divmod ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Power a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " - , " rdfd:constraint xsd_integer:power ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Eq a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:eq ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Ne a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:ne ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Lt a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:lt ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Le a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:le ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Gt a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:gt ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_integer:Ge a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_integer:ge ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - ] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFDatatypeXsdString.hs b/src/Swish/RDF/RDFDatatypeXsdString.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFDatatypeXsdString.hs +++ /dev/null @@ -1,333 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdString --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines the structures used by Swish to represent and --- manipulate RDF @xsd:string@ datatyped literals. --- --------------------------------------------------------------------------------- - --- TODO: this should convert to/from T.Text rather than String - -module Swish.RDF.RDFDatatypeXsdString - ( rdfDatatypeXsdString - , rdfDatatypeValXsdString - , typeNameXsdString, namespaceXsdString - , axiomsXsdString, rulesXsdString - , prefixXsdString - ) - where - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset - , makeRDFGraphFromN3Builder - , makeRDFFormula - , makeN3ClosureRule - ) - -import Swish.RDF.RDFVarBinding (RDFVarBindingModify) - -import Swish.RDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , makeRdfDtOpenVarBindingModifiers - ) - -import Swish.RDF.RDFGraph (RDFLabel(..)) -import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules) - -import Swish.RDF.Datatype - ( Datatype(..) - , DatatypeVal(..) - , DatatypeMap(..) - , DatatypeRel(..), DatatypeRelPr - , altArgs - , UnaryFnTable, unaryFnApp - , DatatypeMod(..) - , makeVmod20 - ) - -import Swish.RDF.Ruleset (makeRuleset) -import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder, makeNSScopedName) - -import Swish.RDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceXsdType - ) - -import Swish.RDF.VarBinding (VarBinding(..), addVarBinding, VarBindingModify(..)) - -import Data.Monoid(Monoid(..)) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - --- Local name for Integer datatype -nameXsdString :: T.Text -nameXsdString = "string" - --- | Type name for @xsd:string@ datatype -typeNameXsdString :: ScopedName -typeNameXsdString = makeNSScopedName namespaceXSD nameXsdString - --- |Namespace for @xsd:string@ datatype functions -namespaceXsdString :: Namespace -namespaceXsdString = namespaceXsdType nameXsdString - ------------------------------------------------------------- --- Declare exported RDFDatatype value for xsd:integer ------------------------------------------------------------- - -rdfDatatypeXsdString :: RDFDatatype -rdfDatatypeXsdString = Datatype rdfDatatypeValXsdString - ------------------------------------------------------------- --- Implmentation of RDFDatatypeVal for xsd:integer ------------------------------------------------------------- - --- |Define Datatype value for @xsd:string@. --- -rdfDatatypeValXsdString :: RDFDatatypeVal T.Text -rdfDatatypeValXsdString = DatatypeVal - { tvalName = typeNameXsdString - , tvalRules = rdfRulesetXsdString - , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString - , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdString - , tvalMap = mapXsdString - , tvalRel = relXsdString - , tvalMod = modXsdString - } - --- |mapXsdString contains functions that perform lexical-to-value --- and value-to-canonical-lexical mappings for @xsd:string@ values --- --- These are identity mappings. --- -mapXsdString :: DatatypeMap T.Text -mapXsdString = DatatypeMap - { mapL2V = Just - , mapV2L = Just - } - --- |relXsdString contains useful relations for @xsd:string@ values. --- -relXsdString :: [DatatypeRel T.Text] -relXsdString = - [ relXsdStringEq - , relXsdStringNe - ] - -mkStrRel2 :: - T.Text -> DatatypeRelPr T.Text -> UnaryFnTable T.Text - -> DatatypeRel T.Text -mkStrRel2 nam pr fns = - DatatypeRel - { dtRelName = makeNSScopedName namespaceXsdString nam - , dtRelFunc = altArgs pr fns unaryFnApp - } - -{- -mkStrRel3 :: - String -> DatatypeRelPr String -> BinaryFnTable String - -> DatatypeRel String -mkStrRel3 nam pr fns = DatatypeRel - { dtRelName = ScopedName namespaceXsdString nam - , dtRelFunc = altArgs pr fns binaryFnApp - } - -mkStrRel3maybe :: - String -> DatatypeRelPr String -> BinMaybeFnTable String - -> DatatypeRel String -mkStrRel3maybe nam pr fns = DatatypeRel - { dtRelName = ScopedName namespaceXsdString nam - , dtRelFunc = altArgs pr fns binMaybeFnApp - } --} - -liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool -liftL2 p i1 i2 as = p (i1 as) (i2 as) - -lcomp :: (a->a->Bool) -> [a] -> Bool -lcomp p = liftL2 p head (head . tail) - --- eq - -relXsdStringEq :: DatatypeRel T.Text -relXsdStringEq = mkStrRel2 "eq" (lcomp (==)) - ( repeat (const True, []) ) - --- ne - -relXsdStringNe :: DatatypeRel T.Text -relXsdStringNe = mkStrRel2 "ne" (lcomp (/=)) - ( repeat (const True, []) ) - --- |modXsdString contains variable binding modifiers for @xsd:string@ values. --- -modXsdString :: [RDFDatatypeMod T.Text] -modXsdString = - [ modXsdStringEq - , modXsdStringNe - ] - -modXsdStringEq, modXsdStringNe :: RDFDatatypeMod T.Text -modXsdStringEq = modXsdStringCompare "eq" (==) -modXsdStringNe = modXsdStringCompare "ne" (/=) - -modXsdStringCompare :: - T.Text -> (T.Text->T.Text->Bool) -> RDFDatatypeMod T.Text -modXsdStringCompare nam rel = DatatypeMod - { dmName = makeNSScopedName namespaceXsdString nam - , dmModf = [ f0 ] - , dmAppf = makeVmod20 - } - where - f0 vs@[v1,v2] = if rel v1 v2 then vs else [] - f0 _ = [] - --- |rulesetXsdString contains rules and axioms that allow additional --- deductions when xsd:string values appear in a graph. --- --- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex --- -rdfRulesetXsdString :: RDFRuleset -rdfRulesetXsdString = - makeRuleset namespaceXsdString axiomsXsdString rulesXsdString - -mkPrefix :: Namespace -> B.Builder -mkPrefix = namespaceToBuilder - -prefixXsdString :: B.Builder -prefixXsdString = - mconcat - [ mkPrefix namespaceRDF - , mkPrefix namespaceRDFS - , mkPrefix namespaceRDFD - , mkPrefix namespaceXSD - , mkPrefix namespaceXsdString - ] - -mkAxiom :: T.Text -> B.Builder -> RDFFormula -mkAxiom local gr = - makeRDFFormula namespaceXsdString local (prefixXsdString `mappend` gr) - -axiomsXsdString :: [RDFFormula] -axiomsXsdString = - [ mkAxiom "dt" "xsd:string rdf:type rdfs:Datatype ." - ] - -rulesXsdString :: [RDFRule] -rulesXsdString = rulesXsdStringClosure ++ rulesXsdStringRestriction - -rulesXsdStringRestriction :: [RDFRule] -rulesXsdStringRestriction = - makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString gr - where - gr = makeRDFGraphFromN3Builder rulesXsdStringBuilder - -rulesXsdStringBuilder :: B.Builder -rulesXsdStringBuilder = - mconcat - [ prefixXsdString - , "xsd_string:Eq a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_string:eq ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - , "xsd_string:Ne a rdfd:GeneralRestriction ; " - , " rdfd:onProperties (rdf:_1 rdf:_2) ; " - , " rdfd:constraint xsd_string:ne ; " - , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " - ] - -rulesXsdStringClosure :: [RDFRule] -rulesXsdStringClosure = - [ xsdstrls - , xsdstrsl - ] - --- Infer string from plain literal -xsdstrls :: RDFRule -xsdstrls = makeN3ClosureRule namespaceXsdString "ls" - "?a ?p ?l ." - "?a ?p ?s ." - (stringPlain "s" "l") - --- Infer plain literal from string -xsdstrsl :: RDFRule -xsdstrsl = makeN3ClosureRule namespaceXsdString "sl" - "?a ?p ?s ." - "?a ?p ?l ." - (stringPlain "s" "l") - --- Map between string and plain literal values -stringPlain :: String -> String -> RDFVarBindingModify -stringPlain svar lvar = stringPlainValue (Var svar) (Var lvar) - --- Variable binding modifier to create new binding to a canonical --- form of a datatyped literal. -stringPlainValue :: - RDFLabel -> RDFLabel -> RDFVarBindingModify -stringPlainValue svar lvar = VarBindingModify - { vbmName = makeNSScopedName namespaceRDFD "stringPlain" - , vbmApply = concatMap app1 - , vbmVocab = [svar,lvar] - , vbmUsage = [[svar],[lvar],[]] - } - where - app1 vbind = app2 (vbMap vbind svar) (vbMap vbind lvar) vbind - app2 (Just (Lit s (Just _))) - (Just (Lit l Nothing)) - vbind - | s == l - = [vbind] - app2 (Just (Lit s (Just _))) - Nothing - vbind - = [addVarBinding lvar (Lit s Nothing) vbind] - app2 Nothing - (Just (Lit l Nothing)) - vbind - = [addVarBinding svar (Lit l (Just typeNameXsdString)) vbind] - app2 _ _ _ = [] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFGraph.hs b/src/Swish/RDF/RDFGraph.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFGraph.hs +++ /dev/null @@ -1,1396 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFGraph --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, OverloadedStrings --- --- This module defines a memory-based RDF graph instance. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Simple labelled directed graph value ------------------------------------------------------------- - -module Swish.RDF.RDFGraph - ( - -- * Labels - RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..) - , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral - , isDatatyped, isMemberProp, isUri, isBlank, isQueryVar - , getLiteralText, getScopedName, makeBlank - , quote - , quoteT - - -- * RDF Graphs - , RDFTriple - , toRDFTriple, fromRDFTriple - , NSGraph(..) - , RDFGraph - , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} - , NamespaceMap, RevNamespaceMap, RevNamespace - , emptyNamespaceMap - , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap - , addArc, merge - , allLabels, allNodes, remapLabels, remapLabelList - , newNode, newNodes - , setNamespaces, getNamespaces - , setFormulae, getFormulae, setFormula, getFormula - - -- * Re-export from GraphClass - , LDGraph(..), Label (..), Arc(..) - , arc, arcSubj, arcPred, arcObj, Selector - - -- * Selected RDFLabel values - -- - -- | The 'ToRDFLabel' instance of 'ScopedName' can also be used - -- to easily construct 'RDFLabel' versions of the terms defined - -- in `Swish.RDF.Vocabulary`. - - -- ** RDF terms - -- - -- | These terms are described in ; - -- the version used is \"W3C Recommendation 10 February 2004\", . - -- - -- Some terms are listed within the RDF Schema terms below since their definition - -- is given within the RDF Schema document. - -- - , resRdfRDF - , resRdfDescription - , resRdfID - , resRdfAbout - , resRdfParseType - , resRdfResource - , resRdfLi - , resRdfNodeID - , resRdfDatatype - , resRdf1, resRdf2, resRdfn - -- ** RDF Schema terms - -- - -- | These are defined by ; the version - -- used is \"W3C Recommendation 10 February 2004\", . - - -- *** Classes - -- - -- | See the \"Classes\" section at for more information. - , resRdfsResource - , resRdfsClass - , resRdfsLiteral - , resRdfsDatatype - , resRdfXMLLiteral - , resRdfProperty - -- *** Properties - -- - -- | See the \"Properties\" section at for more information. - , resRdfsRange - , resRdfsDomain - , resRdfType - , resRdfsSubClassOf - , resRdfsSubPropertyOf - , resRdfsLabel - , resRdfsComment - -- *** Containers - -- - -- | See the \"Container Classes and Properties\" section at . - , resRdfsContainer - , resRdfBag - , resRdfSeq - , resRdfAlt - , resRdfsContainerMembershipProperty - , resRdfsMember - -- *** Collections - -- - -- | See the \"Collections\" section at . - , resRdfList - , resRdfFirst - , resRdfRest - , resRdfNil - -- *** Reification Vocabulary - -- - -- | See the \"Reification Vocabulary\" section at . - , resRdfStatement - , resRdfSubject - , resRdfPredicate - , resRdfObject - -- *** Utility Properties - -- - -- | See the \"Utility Properties\" section at . - , resRdfsSeeAlso - , resRdfsIsDefinedBy - , resRdfValue - - -- ** OWL - , resOwlSameAs - - -- ** Miscellaneous - , resRdfdGeneralRestriction - , resRdfdOnProperties, resRdfdConstraint, resRdfdMaxCardinality - , resLogImplies - - -- * Exported for testing - , grMatchMap, grEq - , mapnode, maplist - ) - where - -import Swish.Utils.Namespace - ( Namespace, makeNamespace, getNamespaceTuple - , getScopedNameURI - , ScopedName - , getScopeLocal, getScopeNamespace - , getQName - , makeQNameScopedName - , makeURIScopedName - , nullScopedName - ) - -import Swish.RDF.Vocabulary -{- - ( namespaceRDF - , langTag, isLang - , rdfType - , rdfFirst, rdfRest, rdfNil, rdfXMLLiteral - , rdfsMember - , rdfdGeneralRestriction - , rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality - , owlSameAs, logImplies - , xsdBoolean, xsdDecimal, xsdFloat, xsdDouble, xsdInteger - , xsdDateTime, xsdDate - ) --} - -import Swish.RDF.GraphClass - ( LDGraph(..), Label (..) - , Arc(..), arc, arcSubj, arcPred, arcObj, arcLabels - , Selector ) - -import Swish.RDF.GraphMatch (graphMatch, LabelMap, ScopedLabel(..)) - -import Swish.Utils.QName (QName) -import Swish.Utils.MiscHelpers (hash) -import Swish.Utils.ListHelpers (addSetElem) - -import Swish.Utils.LookupMap - ( LookupMap(..), LookupEntryClass(..) - , listLookupMap - , mapFind, mapFindMaybe, mapReplaceOrAdd, mapAddIfNew - , mapVals, mapKeys ) - -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as Traversable - -import qualified Data.Text as T -import qualified Data.Text.Read as T --- import qualified Data.Text.Lazy as L --- import Data.Text.Format (format) --- import Data.Text.Buildable --- import Data.Text.Format.Types (Only(..)) - -import Control.Applicative (Applicative, liftA, (<$>), (<*>)) - -import Network.URI (URI) - -import Data.Monoid (Monoid(..)) -import Data.Maybe (mapMaybe) -import Data.Char (ord, isDigit) -import Data.List (intersect, union, findIndices, foldl') -import Data.Ord (comparing) --- import Data.Tuple (swap) not in 6.12.3 -import Data.String (IsString(..)) -import Data.Time (UTCTime, Day, ParseTime, parseTime, formatTime) -import System.Locale (defaultTimeLocale) -import Text.Printf - -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) - --- | RDF graph node values --- --- cf. --- --- This is extended from the RDF abstract graph syntax in the --- following ways: --- --- (a) a graph can be part of a resource node or blank node --- (cf. Notation3 formulae) --- --- (b) a \"variable\" node option is distinguished from a --- blank node. --- I have found this useful for encoding and handling --- queries, even though query variables can be expressed --- as blank nodes. --- --- (c) a \"NoNode\" option is defined. --- This might otherwise be handled by @Maybe (RDFLabel g)@. --- -data RDFLabel = - Res ScopedName -- ^ resource - | Lit T.Text (Maybe ScopedName) -- ^ literal [type/language] - | Blank String -- ^ blank node - | Var String -- ^ variable (not used in ordinary graphs) - | NoNode -- ^ no node (not used in ordinary graphs) - --- TODO: should Lit be split up so that can easily differentiate between --- a type and a language tag? - --- | Define equality of nodes possibly based on different graph types. --- --- The equality of literals is taken from section 6.5.1 ("Literal --- Equality") of the RDF Concepts and Abstract Document, --- . --- -instance Eq RDFLabel where - Res q1 == Res q2 = q1 == q2 - Blank b1 == Blank b2 = b1 == b2 - Var v1 == Var v2 = v1 == v2 - - Lit s1 Nothing == Lit s2 Nothing = s1 == s2 - Lit s1 (Just t1) == Lit s2 (Just t2) = s1 == s2 && (t1 == t2 || - (isLang t1 && isLang t2 && - (T.toLower . langTag) t1 == (T.toLower . langTag) t2)) - - _ == _ = False - -instance Show RDFLabel where - show (Res sn) = show sn - show (Lit st Nothing) = quote1Str st - show (Lit st (Just nam)) - | isLang nam = quote1Str st ++ "@" ++ T.unpack (langTag nam) - | nam `elem` [xsdBoolean, xsdDouble, xsdDecimal, xsdInteger] = T.unpack st - | otherwise = quote1Str st ++ "^^" ++ show nam - show (Blank ln) = "_:"++ln - show (Var ln) = '?' : ln - show NoNode = "" - -instance Ord RDFLabel where - -- Optimize some common cases.. - compare (Res sn1) (Res sn2) = compare sn1 sn2 - compare (Blank ln1) (Blank ln2) = compare ln1 ln2 - compare (Res _) (Blank _) = LT - compare (Blank _) (Res _) = GT - -- .. else use show string comparison - compare l1 l2 = comparing show l1 l2 - - {- <= is not used if compare is provided - -- Similarly for <= - (Res qn1) <= (Res qn2) = qn1 <= qn2 - (Blank ln1) <= (Blank ln2) = ln1 <= ln2 - (Res _) <= (Blank _) = True - (Blank _) <= (Res _) = False - l1 <= l2 = show l1 <= show l2 - -} - -instance Label RDFLabel where - labelIsVar (Blank _) = True - labelIsVar (Var _) = True - labelIsVar _ = False - getLocal (Blank loc) = loc - getLocal (Var loc) = '?':loc - getLocal (Res sn) = "Res_" ++ T.unpack (getScopeLocal sn) - getLocal (NoNode) = "None" - getLocal _ = "Lit_" - makeLabel ('?':loc) = Var loc - makeLabel loc = Blank loc - labelHash seed lb = hash seed (showCanon lb) - -instance IsString RDFLabel where - fromString = flip Lit Nothing . T.pack - -{-| -A type that can be converted to a RDF Label. - -The String instance converts to an untyped literal -(so no language tag is assumed). - -The `UTCTime` and `Day` instances assume values are in UTC. - -The conversion for XSD types attempts to use the -canonical form described in section 2.3.1 of -. - -Note that this is very similar to -'Swish.RDF.RDFDatatype.toRDFLabel' and should be moved into -a @Swish.RDF.Datatype@ module. --} - -class ToRDFLabel a where - toRDFLabel :: a -> RDFLabel - -{-| -A type that can be converted from a RDF Label, -with the possibility of failure. - -The String instance converts from an untyped literal -(so it can not be used with a string with a language tag). - -The following conversions are supported for common XSD -types (out-of-band values result in @Nothing@): - - - @xsd:boolean@ to @Bool@ - - - @xsd:integer@ to @Int@ and @Integer@ - - - @xsd:float@ to @Float@ - - - @xsd:double@ to @Double@ - - - @xsd:dateTime@ to @UTCTime@ - - - @xsd:date@ to @Day@ - -Note that this is very similar to -'Swish.RDF.RDFDatatype.fromRDFLabel' and should be moved into -a @Swish.RDF.Datatype@ module. --} - -class FromRDFLabel a where - fromRDFLabel :: RDFLabel -> Maybe a - --- instances for type conversion to/from RDFLabel - --- | This is just @id@. -instance ToRDFLabel RDFLabel where - toRDFLabel = id - --- | This is just @Just . id@. -instance FromRDFLabel RDFLabel where - fromRDFLabel = Just . id - --- TODO: remove this hack when finished conversion to Text -maybeReadStr :: (Read a) => T.Text -> Maybe a -maybeReadStr txt = case reads (T.unpack txt) of - [(val, "")] -> Just val - _ -> Nothing - -maybeRead :: T.Reader a -> T.Text -> Maybe a -maybeRead rdr inTxt = - case rdr inTxt of - Right (val, "") -> Just val - _ -> Nothing - -fLabel :: (T.Text -> Maybe a) -> ScopedName -> RDFLabel -> Maybe a -fLabel conv dtype (Lit xs (Just dt)) | dt == dtype = conv xs - | otherwise = Nothing -fLabel _ _ _ = Nothing - -tLabel :: (Show a) => ScopedName -> (String -> T.Text) -> a -> RDFLabel -tLabel dtype conv = flip Lit (Just dtype) . conv . show - --- | The character is converted to an untyped literal of length one. -instance ToRDFLabel Char where - toRDFLabel = flip Lit Nothing . T.singleton - --- | The label must be an untyped literal containing a single character. -instance FromRDFLabel Char where - fromRDFLabel (Lit cs Nothing) | T.compareLength cs 1 == EQ = Just (T.head cs) - | otherwise = Nothing - fromRDFLabel _ = Nothing - --- | Strings are converted to untyped literals. -instance ToRDFLabel String where - toRDFLabel = flip Lit Nothing . T.pack - --- | Only untyped literals are converted to strings. -instance FromRDFLabel String where - fromRDFLabel (Lit xs Nothing) = Just (T.unpack xs) - fromRDFLabel _ = Nothing - -textToBool :: T.Text -> Maybe Bool -textToBool s | s `elem` ["1", "true"] = Just True - | s `elem` ["0", "false"] = Just False - | otherwise = Nothing - --- | Converts to a literal with a @xsd:boolean@ datatype. -instance ToRDFLabel Bool where - toRDFLabel b = Lit (if b then "true" else "false") (Just xsdBoolean) - --- | Converts from a literal with a @xsd:boolean@ datatype. The --- literal can be any of the supported XSD forms - e.g. \"0\" or --- \"true\". -instance FromRDFLabel Bool where - fromRDFLabel = fLabel textToBool xsdBoolean - --- fromRealFloat :: (RealFloat a, Buildable a) => ScopedName -> a -> RDFLabel -fromRealFloat :: (RealFloat a, PrintfArg a) => ScopedName -> a -> RDFLabel -fromRealFloat dtype f | isNaN f = toL "NaN" - | isInfinite f = toL $ if f > 0.0 then "INF" else "-INF" - -- - -- Would like to use Data.Text.Format.format but there are - -- issues with this module; 0.3.0.2 doesn't build under - -- 6.12.3 due to a missing RelaxedPolyRec language extension - -- and it relies on double-conversion which has issues - -- when used in ghci due to a dlopen issue with libstdc++. - -- - -- -- | otherwise = toL $ L.toStrict $ format "{}" (Only f) - -- - | otherwise = toL $ T.pack $ printf "%E" f - - where - toL = flip Lit (Just dtype) - --- textToRealFloat :: (RealFloat a) => (a -> Maybe a) -> T.Text -> Maybe a -textToRealFloat :: (RealFloat a, Read a) => (a -> Maybe a) -> T.Text -> Maybe a -textToRealFloat conv = rconv - where - rconv "NaN" = Just (0.0/0.0) -- how best to create a NaN? - rconv "INF" = Just (1.0/0.0) -- ditto for Infinity - rconv "-INF" = Just ((-1.0)/0.0) - rconv ival - -- xsd semantics allows "2." but Haskell syntax does not. - | T.null ival = Nothing - - | otherwise = case maybeReadStr ival of - Just val -> conv val - _ -> if T.last ival == '.' -- could drop the check - then maybeReadStr (T.snoc ival '0') >>= conv - else Nothing - - {- - - Unfortunately T.rational does not handle "3.01e4" the same - as read; see https://bitbucket.org/bos/text/issue/7/ - - | otherwise = case maybeRead T.rational ival of - Just val -> conv val - _ -> if T.last ival == '.' -- could drop the check - then maybeRead T.rational (T.snoc ival '0') >>= conv - else Nothing - -} - - -- not sure the above is any improvement on the following - -- -- | T.last ival == '.' = maybeRead T.rational (T.snoc ival '0') >>= conv - -- -- | otherwise = maybeRead T.rational ival >>= conv - -textToFloat :: T.Text -> Maybe Float -textToFloat = - let -- assume that an invalid value (NaN/Inf) from maybeRead means - -- that the value is out of bounds for Float so we do not - -- convert - conv f | isNaN f || isInfinite f = Nothing - | otherwise = Just f - in textToRealFloat conv - -textToDouble :: T.Text -> Maybe Double -textToDouble = textToRealFloat Just - --- | Converts to a literal with a @xsd:float@ datatype. -instance ToRDFLabel Float where - toRDFLabel = fromRealFloat xsdFloat - --- | Converts from a literal with a @xsd:float@ datatype. --- The conversion will fail if the value is outside the valid range of --- a Haskell `Float`. -instance FromRDFLabel Float where - fromRDFLabel = fLabel textToFloat xsdFloat - --- | Converts to a literal with a @xsd:double@ datatype. -instance ToRDFLabel Double where - toRDFLabel = fromRealFloat xsdDouble - --- | Converts from a literal with a @xsd:double@ datatype. -instance FromRDFLabel Double where - fromRDFLabel = fLabel textToDouble xsdDouble - --- TODO: are there subtypes of xsd::integer that are --- useful here? --- --- TODO: add in support for Int8/..., Word8/... --- - --- | Converts to a literal with a @xsd:integer@ datatype. -instance ToRDFLabel Int where - toRDFLabel = tLabel xsdInteger T.pack - -{- -Since decimal will just over/under-flow when converting to Int -we go via Integer and explicitlu check for overflow. --} - -textToInt :: T.Text -> Maybe Int -textToInt s = - let conv :: Integer -> Maybe Int - conv i = - let lb = fromIntegral (minBound :: Int) - ub = fromIntegral (maxBound :: Int) - in if (i >= lb) && (i <= ub) then Just (fromIntegral i) else Nothing - - in maybeRead (T.signed T.decimal) s >>= conv - --- | Converts from a literal with a @xsd:integer@ datatype. --- The conversion will fail if the value is outside the valid range of --- a Haskell `Int`. -instance FromRDFLabel Int where - fromRDFLabel = fLabel textToInt xsdInteger - --- | Converts to a literal with a @xsd:integer@ datatype. -instance ToRDFLabel Integer where - toRDFLabel = tLabel xsdInteger T.pack - --- | Converts from a literal with a @xsd:integer@ datatype. -instance FromRDFLabel Integer where - fromRDFLabel = fLabel (maybeRead (T.signed T.decimal)) xsdInteger - -{- -Support an ISO-8601 style format supporting - - 2005-02-28T00:00:00Z - 2004-12-31T19:01:00-05:00 - 2005-07-14T03:18:56.234+01:00 - -fromUTCFormat is used to convert UTCTime to a string -for storage within a Lit. - -toUTCFormat is used to convert a string into UTCTime; -we have to support - no time zone - Z - +/-HH:MM - -which means a somewhat messy convertor, which is written -for clarity rather than speed. --} - -fromUTCFormat :: UTCTime -> String -fromUTCFormat = formatTime defaultTimeLocale "%FT%T%QZ" - -fromDayFormat :: Day -> String -fromDayFormat = formatTime defaultTimeLocale "%FZ" - -toTimeFormat :: (ParseTime a) => String -> String -> Maybe a -toTimeFormat fmt inVal = - let fmtHHMM = fmt ++ "%z" - fmtZ = fmt ++ "Z" - pt f = parseTime defaultTimeLocale f inVal - in case pt fmtHHMM of - o@(Just _) -> o - _ -> case pt fmtZ of - o@(Just _) -> o - _ -> pt fmt - -toUTCFormat :: T.Text -> Maybe UTCTime -toUTCFormat = toTimeFormat "%FT%T%Q" . T.unpack - -toDayFormat :: T.Text -> Maybe Day -toDayFormat = toTimeFormat "%F" . T.unpack - --- | Converts to a literal with a @xsd:datetime@ datatype. -instance ToRDFLabel UTCTime where - toRDFLabel = flip Lit (Just xsdDateTime) . T.pack . fromUTCFormat - --- | Converts from a literal with a @xsd:datetime@ datatype. -instance FromRDFLabel UTCTime where - fromRDFLabel = fLabel toUTCFormat xsdDateTime - --- | Converts to a literal with a @xsd:date@ datatype. -instance ToRDFLabel Day where - toRDFLabel = flip Lit (Just xsdDate) . T.pack . fromDayFormat - --- | Converts from a literal with a @xsd:date@ datatype. -instance FromRDFLabel Day where - fromRDFLabel = fLabel toDayFormat xsdDate - --- | Converts to a Resource. -instance ToRDFLabel ScopedName where - toRDFLabel = Res - --- | Converts from a Resource. -instance FromRDFLabel ScopedName where - fromRDFLabel (Res sn) = Just sn - fromRDFLabel _ = Nothing - --- | Converts to a Resource. -instance ToRDFLabel QName where - toRDFLabel = Res . makeQNameScopedName Nothing - --- | Converts from a Resource. -instance FromRDFLabel QName where - fromRDFLabel (Res sn) = Just $ getQName sn - fromRDFLabel _ = Nothing - --- | Converts to a Resource. -instance ToRDFLabel URI where - toRDFLabel = Res . makeURIScopedName - --- | Converts from a Resource. -instance FromRDFLabel URI where - fromRDFLabel (Res sn) = Just $ getScopedNameURI sn - fromRDFLabel _ = Nothing - --- | Get the canonical string for RDF label. --- --- This is used for hashing, so that equivalent labels always return --- the same hash value. --- -showCanon :: RDFLabel -> String -showCanon (Res sn) = "<"++show (getScopedNameURI sn)++">" -showCanon (Lit st (Just nam)) - | isLang nam = quote1Str st ++ "@" ++ T.unpack (langTag nam) - | otherwise = quote1Str st ++ "^^" ++ show (getScopedNameURI nam) -showCanon s = show s - --- | See `quote`. -quoteT :: Bool -> T.Text -> T.Text -quoteT f = T.pack . quote f . T.unpack - -{-| N3-style quoting rules for a string. - -TODO: when flag is `False` need to worry about multiple quotes (> 2) -in a row. --} - -quote :: - Bool -- ^ @True@ if the string is to be displayed using one rather than three quotes. - -> String -- ^ String to quote. - -> String -quote _ [] = "" -quote False s@(c:'"':[]) | c == '\\' = s -- handle triple-quoted strings ending in " - | otherwise = [c, '\\', '"'] - -quote True ('"': st) = '\\':'"': quote True st -quote True ('\n':st) = '\\':'n': quote True st - -quote True ('\t':st) = '\\':'t': quote True st -quote False ('"': st) = '"': quote False st -quote False ('\n':st) = '\n': quote False st -quote False ('\t':st) = '\t': quote False st -quote f ('\r':st) = '\\':'r': quote f st -quote f ('\\':st) = '\\':'\\': quote f st -- not sure about this -quote f (c:st) = - let nc = ord c - rst = quote f st - - -- lazy way to convert to a string - hstr = printf "%08X" nc - ustr = hstr ++ rst - - in if nc > 0xffff - then '\\':'U': ustr - else if nc > 0x7e || nc < 0x20 - then '\\':'u': drop 4 ustr - else c : rst - --- surround a string with quotes ("...") - -quote1Str :: T.Text -> String -quote1Str t = '"' : quote False (T.unpack t) ++ ['"'] - ---------------------------------------------------------- --- Selected RDFLabel values ---------------------------------------------------------- - --- | @rdf:type@ from . -resRdfType :: RDFLabel -resRdfType = Res rdfType - --- | @rdf:List@ from . -resRdfList :: RDFLabel -resRdfList = Res rdfList - --- | @rdf:first@ from . -resRdfFirst :: RDFLabel -resRdfFirst = Res rdfFirst - --- | @rdf:rest@ from . -resRdfRest :: RDFLabel -resRdfRest = Res rdfRest - --- | @rdf:nil@ from . -resRdfNil :: RDFLabel -resRdfNil = Res rdfNil - --- | @rdfs:member@ from . -resRdfsMember :: RDFLabel -resRdfsMember = Res rdfsMember - --- | @rdfd:GeneralRestriction@. -resRdfdGeneralRestriction :: RDFLabel -resRdfdGeneralRestriction = Res rdfdGeneralRestriction - --- | @rdfd:onProperties@. -resRdfdOnProperties :: RDFLabel -resRdfdOnProperties = Res rdfdOnProperties - --- | @rdfd:constraint@. -resRdfdConstraint :: RDFLabel -resRdfdConstraint = Res rdfdConstraint - --- | @rdfd:maxCardinality@. -resRdfdMaxCardinality :: RDFLabel -resRdfdMaxCardinality = Res rdfdMaxCardinality - --- | @rdfs:seeAlso@ from . -resRdfsSeeAlso :: RDFLabel -resRdfsSeeAlso = Res rdfsSeeAlso - --- | @rdf:value@ from . -resRdfValue :: RDFLabel -resRdfValue = Res rdfValue - --- | @owl:sameAs@. -resOwlSameAs :: RDFLabel -resOwlSameAs = Res owlSameAs - --- | @log:implies@. -resLogImplies :: RDFLabel -resLogImplies = Res logImplies - --- | @rdfs:label@ from . -resRdfsLabel :: RDFLabel -resRdfsLabel = Res rdfsLabel - --- | @rdfs:comment@ from . -resRdfsComment :: RDFLabel -resRdfsComment = Res rdfsComment - --- | @rdf:Property@ from . -resRdfProperty :: RDFLabel -resRdfProperty = Res rdfProperty - --- | @rdfs:subPropertyOf@ from . -resRdfsSubPropertyOf :: RDFLabel -resRdfsSubPropertyOf = Res rdfsSubPropertyOf - --- | @rdfs:subClassOf@ from . -resRdfsSubClassOf :: RDFLabel -resRdfsSubClassOf = Res rdfsSubClassOf - --- | @rdfs:Class@ from . -resRdfsClass :: RDFLabel -resRdfsClass = Res rdfsClass - --- | @rdfs:Literal@ from . -resRdfsLiteral :: RDFLabel -resRdfsLiteral = Res rdfsLiteral - --- | @rdfs:Datatype@ from . -resRdfsDatatype :: RDFLabel -resRdfsDatatype = Res rdfsDatatype - --- | @rdf:XMLLiteral@ from . -resRdfXMLLiteral :: RDFLabel -resRdfXMLLiteral = Res rdfXMLLiteral - --- | @rdfs:range@ from . -resRdfsRange :: RDFLabel -resRdfsRange = Res rdfsRange - --- | @rdfs:domain@ from . -resRdfsDomain :: RDFLabel -resRdfsDomain = Res rdfsDomain - --- | @rdfs:Container@ from . -resRdfsContainer :: RDFLabel -resRdfsContainer = Res rdfsContainer - --- | @rdf:Bag@ from . -resRdfBag :: RDFLabel -resRdfBag = Res rdfBag - --- | @rdf:Seq@ from . -resRdfSeq :: RDFLabel -resRdfSeq = Res rdfSeq - --- | @rdf:Alt@ from . -resRdfAlt :: RDFLabel -resRdfAlt = Res rdfAlt - --- | @rdfs:ContainerMembershipProperty@ from . -resRdfsContainerMembershipProperty :: RDFLabel -resRdfsContainerMembershipProperty = Res rdfsContainerMembershipProperty - --- | @rdfs:isDefinedBy@ from . -resRdfsIsDefinedBy :: RDFLabel -resRdfsIsDefinedBy = Res rdfsIsDefinedBy - --- | @rdfs:Resource@ from . -resRdfsResource :: RDFLabel -resRdfsResource = Res rdfsResource - --- | @rdf:Statement@ from . -resRdfStatement :: RDFLabel -resRdfStatement = Res rdfStatement - --- | @rdf:subject@ from . -resRdfSubject :: RDFLabel -resRdfSubject = Res rdfSubject - --- | @rdf:predicate@ from . -resRdfPredicate :: RDFLabel -resRdfPredicate = Res rdfPredicate - --- | @rdf:object@ from . -resRdfObject :: RDFLabel -resRdfObject = Res rdfObject - --- | @rdf:RDF@. -resRdfRDF :: RDFLabel -resRdfRDF = Res rdfRDF - --- | @rdf:Description@. -resRdfDescription :: RDFLabel -resRdfDescription = Res rdfDescription - --- | @rdf:ID@. -resRdfID :: RDFLabel -resRdfID = Res rdfID - --- | @rdf:about@. -resRdfAbout :: RDFLabel -resRdfAbout = Res rdfAbout - --- | @rdf:parseType@. -resRdfParseType :: RDFLabel -resRdfParseType = Res rdfParseType - --- | @rdf:resource@. -resRdfResource :: RDFLabel -resRdfResource = Res rdfResource - --- | @rdf:li@. -resRdfLi :: RDFLabel -resRdfLi = Res rdfLi - --- | @rdf:nodeID@. -resRdfNodeID :: RDFLabel -resRdfNodeID = Res rdfNodeID - --- | @rdf:datatype@. -resRdfDatatype :: RDFLabel -resRdfDatatype = Res rdfDatatype - --- | @rdf:_1@. -resRdf1 :: RDFLabel -resRdf1 = Res rdf1 - --- | @rdf:_2@. -resRdf2 :: RDFLabel -resRdf2 = Res rdf2 - --- | Create a @rdf:_n@ entity. -resRdfn :: Int -> RDFLabel -resRdfn = Res . rdfn - ---------------------------------------------------------- --- Additional functions on RDFLabel values ---------------------------------------------------------- - --- |Test if supplied labal is a URI resource node -isUri :: RDFLabel -> Bool -isUri (Res _) = True -isUri _ = False - --- |Test if supplied labal is a literal node -isLiteral :: RDFLabel -> Bool -isLiteral (Lit _ _) = True -isLiteral _ = False - --- |Test if supplied labal is an untyped literal node -isUntypedLiteral :: RDFLabel -> Bool -isUntypedLiteral (Lit _ Nothing ) = True -isUntypedLiteral (Lit _ (Just tn)) = isLang tn -isUntypedLiteral _ = False - --- |Test if supplied labal is an untyped literal node -isTypedLiteral :: RDFLabel -> Bool -isTypedLiteral (Lit _ (Just tn)) = not (isLang tn) -isTypedLiteral _ = False - --- |Test if supplied labal is an XML literal node -isXMLLiteral :: RDFLabel -> Bool -isXMLLiteral = isDatatyped rdfXMLLiteral - --- |Test if supplied label is an typed literal node of a given datatype -isDatatyped :: ScopedName -> RDFLabel -> Bool -isDatatyped d (Lit _ (Just n)) = n == d -isDatatyped _ _ = False - --- |Test if supplied label is a container membership property --- --- Check for namespace is RDF namespace and --- first character of local name is '_' and --- remaining characters of local name are all digits -isMemberProp :: RDFLabel -> Bool -isMemberProp (Res sn) = - getScopeNamespace sn == namespaceRDF && - case T.uncons (getScopeLocal sn) of - Just ('_', t) -> T.all isDigit t - _ -> False -isMemberProp _ = False - --- |Test if supplied labal is a blank node -isBlank :: RDFLabel -> Bool -isBlank (Blank _) = True -isBlank _ = False - --- |Test if supplied labal is a query variable -isQueryVar :: RDFLabel -> Bool -isQueryVar (Var _) = True -isQueryVar _ = False - --- |Extract text value from a literal node -getLiteralText :: RDFLabel -> T.Text -getLiteralText (Lit s _) = s -getLiteralText _ = "" - --- |Extract ScopedName value from a resource node -getScopedName :: RDFLabel -> ScopedName -getScopedName (Res sn) = sn -getScopedName _ = nullScopedName - --- |Make a blank node from a supplied query variable, --- or return the supplied label unchanged. --- (Use this in when substituting an existential for an --- unsubstituted query variable.) -makeBlank :: RDFLabel -> RDFLabel -makeBlank (Var loc) = Blank loc -makeBlank lb = lb - --- | RDF Triple (statement) --- --- At present there is no check or type-level --- constraint that stops the subject or --- predicate of the triple from being a literal. --- -type RDFTriple = Arc RDFLabel - --- | Convert 3 RDF labels to a RDF triple. --- --- See also @Swish.RDF.GraphClass.arcFromTriple@. -toRDFTriple :: - (ToRDFLabel s, ToRDFLabel p, ToRDFLabel o) - => s -- ^ Subject - -> p -- ^ Predicate - -> o -- ^ Object - -> RDFTriple -toRDFTriple s p o = - Arc (toRDFLabel s) (toRDFLabel p) (toRDFLabel o) - --- | Extract the contents of a RDF triple. --- --- See also @Swish.RDF.GraphClass.arcToTriple@. -fromRDFTriple :: - (FromRDFLabel s, FromRDFLabel p, FromRDFLabel o) - => RDFTriple - -> Maybe (s, p, o) -- ^ The conversion only succeeds if all three - -- components can be converted to the correct - -- Haskell types. -fromRDFTriple (Arc s p o) = - (,,) <$> fromRDFLabel s <*> fromRDFLabel p <*> fromRDFLabel o - --- | Namespace prefix list entry - -type NamespaceMap = LookupMap Namespace - -data RevNamespace = RevNamespace Namespace - -instance LookupEntryClass RevNamespace URI (Maybe T.Text) where - keyVal (RevNamespace ns) = swap $ getNamespaceTuple ns - newEntry (uri,pre) = RevNamespace (makeNamespace pre uri) - -type RevNamespaceMap = LookupMap RevNamespace - --- | Create an empty namespace map. -emptyNamespaceMap :: NamespaceMap -emptyNamespaceMap = LookupMap [] - --- | Graph formula entry - -data LookupFormula lb gr = Formula - { formLabel :: lb -- ^ The label for the formula - , formGraph :: gr -- ^ The contents of the formula - } - -instance (Eq lb, Eq gr) => Eq (LookupFormula lb gr) where - f1 == f2 = formLabel f1 == formLabel f2 && - formGraph f1 == formGraph f2 - -instance (Label lb) - => LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb) - where - keyVal fe = (formLabel fe, formGraph fe) - newEntry (k,v) = Formula { formLabel=k, formGraph=v } - -instance (Label lb) => Show (LookupFormula lb (NSGraph lb)) - where - show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" - -type Formula lb = LookupFormula lb (NSGraph lb) - -type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb)) - --- | Create an empty formula map. -emptyFormulaMap :: FormulaMap RDFLabel -emptyFormulaMap = LookupMap [] - -{- given up on trying to do Functor for formulae... -instance Functor (LookupFormula (NSGraph lb)) where - fmap f fm = mapTranslateEntries (mapFormulaEntry f) fm --} - -formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2 -formulaeMap f = fmap (formulaEntryMap f) - -formulaEntryMap :: - (lb -> l2) - -> Formula lb - -> Formula l2 -formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr) - -formulaeMapA :: Applicative f => (lb -> f l2) -> - FormulaMap lb -> f (FormulaMap l2) -formulaeMapA f = Traversable.traverse (formulaEntryMapA f) - -formulaEntryMapA :: - (Applicative f) => - (lb -> f l2) - -> Formula lb - -> f (Formula l2) -formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> Traversable.traverse f gr - -{- -formulaeMapM :: - (Monad m) => (lb -> m l2) -> FormulaMap lb -> m (FormulaMap l2) -formulaeMapM f = T.mapM (formulaEntryMapM f) - -formulaEntryMapM :: - (Monad m) - => (lb -> m l2) - -> Formula lb - -> m (Formula l2) -formulaEntryMapM f (Formula k gr) = - Formula `liftM` f k `ap` T.mapM f gr - --} - -{-| - -Memory-based graph with namespaces and subgraphs. - -The primary means for adding arcs to an existing graph -are: - - - `setArcs` from the `LDGraph` instance, which replaces the - existing set of arcs and does not change the namespace - map. - - - `addArc` which checks that the arc is unknown before - adding it but does not change the namespace map or - re-label any blank nodes in the arc. - --} -data NSGraph lb = NSGraph - { namespaces :: NamespaceMap -- ^ the namespaces to use - , formulae :: FormulaMap lb -- ^ any associated formulae (a.k.a. sub- or named- graps) - , statements :: [Arc lb] -- ^ the statements in the graph - } - --- | Retrieve the namespace map in the graph. -getNamespaces :: NSGraph lb -> NamespaceMap -getNamespaces = namespaces - --- | Replace the namespace information in the graph. -setNamespaces :: NamespaceMap -> NSGraph lb -> NSGraph lb -setNamespaces ns g = g { namespaces=ns } - --- | Retrieve the formulae in the graph. -getFormulae :: NSGraph lb -> FormulaMap lb -getFormulae = formulae - --- | Replace the formulae in the graph. -setFormulae :: FormulaMap lb -> NSGraph lb -> NSGraph lb -setFormulae fs g = g { formulae=fs } - --- | Find a formula in the graph, if it exists. -getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb) -getFormula g l = mapFindMaybe l (formulae g) - --- | Add (or replace) a formula. -setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb -setFormula f g = g { formulae=mapReplaceOrAdd f (formulae g) } - -instance (Label lb) => Monoid (NSGraph lb) where - mempty = NSGraph emptyNamespaceMap (LookupMap []) [] - mappend = merge - -instance (Label lb) => LDGraph NSGraph lb where - getArcs = statements - setArcs as g = g { statements=as } - containedIn = error "containedIn for LDGraph NSGraph lb is undefined!" -- TODO: should there be one defined? - -{-| -Add an arc to the graph. It does not relabel any blank nodes in the input arc, -nor does it change the namespace map, -but it does ensure that the arc is unknown before adding it. --} -addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb -addArc ar gr = gr { statements=addSetElem ar (statements gr) } - -instance Functor NSGraph where - fmap f (NSGraph ns fml stmts) = - NSGraph ns (formulaeMap f fml) ((map $ fmap f) stmts) - -instance Foldable.Foldable NSGraph where - foldMap = Traversable.foldMapDefault - -instance Traversable.Traversable NSGraph where - traverse f (NSGraph ns fml stmts) = - NSGraph ns <$> formulaeMapA f fml <*> (Traversable.traverse $ Traversable.traverse f) stmts - -instance (Label lb) => Eq (NSGraph lb) where - (==) = grEq - -instance (Label lb) => Show (NSGraph lb) where - show = grShow "" - showList = grShowList "" - -grShowList :: (Label lb) => String -> [NSGraph lb] -> String -> String -grShowList _ [] = showString "[no graphs]" -grShowList p (g:gs) = showChar '[' . showString (grShow pp g) . showl gs - where - showl [] = showChar ']' -- showString $ "\n" ++ p ++ "]" - showl (h:hs) = showString (",\n "++p++grShow pp h) . showl hs - pp = ' ':p - -grShow :: (Label lb) => String -> NSGraph lb -> String -grShow p g = - "Graph, formulae: " ++ showForm ++ "\n" ++ - p ++ "arcs: " ++ showArcs p g - where - showForm = foldr ((++) . (pp ++) . show) "" fml - fml = listLookupMap (getFormulae g) - pp = "\n " ++ p - -showArcs :: (Label lb) => String -> NSGraph lb -> String -showArcs p g = foldr ((++) . (pp ++) . show) "" (getArcs g) - where - pp = "\n " ++ p - -grEq :: (Label lb) => NSGraph lb -> NSGraph lb -> Bool -grEq g1 = fst . grMatchMap g1 - -grMatchMap :: (Label lb) => - NSGraph lb -> NSGraph lb -> (Bool, LabelMap (ScopedLabel lb)) -grMatchMap g1 g2 = - graphMatch matchable (getArcs g1) (getArcs g2) - where - matchable l1 l2 = mapFormula g1 l1 == mapFormula g2 l2 - mapFormula g l = mapFindMaybe l (getFormulae g) - --- |Merge RDF graphs, renaming blank and query variable nodes as --- needed to neep variable nodes from the two graphs distinct in --- the resulting graph. --- --- Currently formulae are not guaranteed to be preserved across a --- merge. --- -merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb -merge gr1 gr2 = - let - bn1 = allLabels labelIsVar gr1 - bn2 = allLabels labelIsVar gr2 - dupbn = intersect bn1 bn2 - allbn = union bn1 bn2 - in - add gr1 (remapLabels dupbn allbn id gr2) - --- |Return list of all labels (including properties) in the graph --- satisfying a supplied filter predicate. This routine --- includes the labels in any formulae. -allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) ) - -{- TODO: is the leading 'filter p' needed in allLabels? --} - --- |Return list of all subjects and objects in the graph --- satisfying a supplied filter predicate. -allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allNodes p = unionNodes p [] . nodes - --- | List all nodes in graph formulae satisfying a supplied predicate -formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -formulaNodes p gr = foldl' (unionNodes p) fkeys (map (allLabels p) fvals) - where - -- fm :: (Label lb) => FormulaMap lb - -- LookupMap LookupFormula (NSGraph lb) lb - fm = formulae gr - -- fvals :: (Label lb) => [NSGraph lb] - fvals = mapVals fm - -- fkeys :: (Label lb) => [lb] - fkeys = filter p $ mapKeys fm - --- | Helper to filter variable nodes and merge with those found so far -unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb] -unionNodes p ls1 ls2 = ls1 `union` filter p ls2 - --- |Remap selected nodes in graph. --- --- This is the node renaming operation that prevents graph-scoped --- variable nodes from being merged when two graphs are merged. -remapLabels :: - (Label lb) - => [lb] -- ^ variable nodes to be renamed (@dupbn@) - -> [lb] -- ^ variable nodes used that must be avoided (@allbn@) - -> (lb -> lb) -- ^ node conversion function that is applied to nodes - -- from @dupbn@ in the graph that are to be replaced by - -- new blank nodes. If no such conversion is required, - -- supply @id@. The function 'makeBlank' can be used to convert - -- RDF query nodes into RDF blank nodes. - -> NSGraph lb -- ^ graph in which nodes are to be renamed - -> NSGraph lb -remapLabels dupbn allbn cnvbn = fmap (mapnode dupbn allbn cnvbn) - --- |Externally callable function to construct a list of (old,new) --- values to be used for graph label remapping. --- -remapLabelList :: - (Label lb) - => [lb] -- ^ labels to be remaped - -> [lb] -- ^ labels to be avoided by the remapping - -> [(lb,lb)] -remapLabelList remap avoid = maplist remap avoid id [] - --- | Remap a single graph node. --- --- If the node is not one of those to be remapped, --- the supplied value is returned unchanged. -mapnode :: - (Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb -mapnode dupbn allbn cnvbn nv = - mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn [])) - --- | Construct a list of (oldnode,newnode) values to be used for --- graph label remapping. The function operates recursively, adding --- new nodes generated to the accumulator and also to the --- list of nodes to be avoided. -maplist :: - (Label lb) - => [lb] -- ^ oldnode values - -> [lb] -- ^ nodes to be avoided - -> (lb -> lb) - -> [(lb,lb)] -- ^ accumulator - -> [(lb,lb)] -maplist [] _ _ mapbn = mapbn -maplist (dn:dupbn) allbn cnvbn mapbn = maplist dupbn allbn' cnvbn mapbn' - where - dnmap = newNode (cnvbn dn) allbn - mapbn' = (dn,dnmap):mapbn - allbn' = dnmap:allbn - --- |Given a node and a list of existing nodes, find a new node for --- the supplied node that does not clash with any existing node. --- (Generates an non-terminating list of possible replacements, and --- picks the first one that isn't already in use.) --- --- TODO: optimize this for common case @nnn@ and @_nnn@: --- always generate @_nnn@ and keep track of last allocated --- -newNode :: (Label lb) => lb -> [lb] -> lb -newNode dn existnodes = - head $ newNodes dn existnodes - --- |Given a node and a list of existing nodes, generate a list of new --- nodes for the supplied node that do not clash with any existing node. -newNodes :: (Label lb) => lb -> [lb] -> [lb] -newNodes dn existnodes = - filter (not . (`elem` existnodes)) $ trynodes (noderootindex dn) - -noderootindex :: (Label lb) => lb -> (String,Int) -noderootindex dn = (nh,nx) where - (nh,nt) = splitnodeid $ getLocal dn - nx = if null nt then 0 else read nt - -splitnodeid :: String -> (String,String) -splitnodeid dn = splitAt (tx+1) dn where - tx = last $ (-1):findIndices (not . isDigit) dn - -trynodes :: (Label lb) => (String,Int) -> [lb] -trynodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] - -{- -trybnodes :: (Label lb) => (String,Int) -> [lb] -trybnodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] --} - --- | Memory-based RDF graph type - -type RDFGraph = NSGraph RDFLabel - --- |Create a new RDF graph from a supplied list of arcs --- --- This version will attempt to fill up the namespace map --- of the graph based on the input labels (including datatypes --- on literals). For faster --- creation of a graph you can use: --- --- > emptyRDFGraph { statements = arcs } --- --- which is how this routine was defined in version @0.3.1.1@ --- and earlier. --- -toRDFGraph :: [RDFTriple] -> RDFGraph --- toRDFGraph arcs = emptyRDFGraph { statements = arcs } -toRDFGraph arcs = - let lbls = concatMap arcLabels arcs - - getNS (Res s) = Just s - getNS (Lit _ (Just tn)) | not (isLang tn) = Just tn - | otherwise = Nothing - getNS _ = Nothing - - ns = mapMaybe (fmap getScopeNamespace . getNS) lbls - nsmap = foldl' mapAddIfNew emptyNamespaceMap ns - - in mempty { namespaces = nsmap, statements = arcs } - --- |Create a new, empty RDF graph. --- --- This uses `mempty` from the `Monoid` instance --- of `NSGraph`. --- -emptyRDFGraph :: RDFGraph -emptyRDFGraph = mempty - -{- --- |Update an RDF graph using a supplied list of arcs, keeping --- prefix definitions and formula definitions from the original. --- --- [[[TODO: I think this may be redundant - the default graph --- class has an update method which accepts a function to update --- the arcs, not touching other parts of the graph value.]]] -updateRDFGraph :: RDFGraph -> [RDFTriple] -> RDFGraph -updateRDFGraph gr as = gr { statements=as } --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFGraphShowM.hs b/src/Swish/RDF/RDFGraphShowM.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFGraphShowM.hs +++ /dev/null @@ -1,57 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE FlexibleInstances #-} -- needed for ghc 7.2 - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFGraphShowM --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : TypeSynonymInstances, FlexibleInstances --- --- This module defines a `ShowM` class instance for `RDFGraph`, to be --- used when displaying RDF Graph values as part of a proof sequence, --- etc. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFGraphShowM() where - -import Swish.RDF.RDFGraph (RDFGraph) -import Swish.RDF.N3Formatter (formatGraphIndent) -import Swish.Utils.ShowM (ShowM(..)) - --- import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B - -instance ShowM RDFGraph where - -- showms linebreak = shows . L.unpack . B.toLazyText . formatGraphIndent linebreak False - showms linebreak = shows . formatGraphIndent (B.fromString linebreak) False - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFParser.hs b/src/Swish/RDF/RDFParser.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFParser.hs +++ /dev/null @@ -1,353 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFParser --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- Support for the RDF Parsing modules. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFParser - ( SpecialMap - -- , mapPrefix - - -- tables - , prefixTable, specialTable - - -- parser - , runParserWithError - , ParseResult - , ignore - , char - , ichar - , string - , stringT - , symbol - , isymbol - , lexeme - , notFollowedBy - , whiteSpace - , skipMany - , skipMany1 - , endBy - , sepEndBy - , sepEndBy1 - , manyTill - , noneOf - , eoln - , fullStop - , mkTypedLit - , hex4 - , hex8 - , appendURIs - ) - where - -import Swish.RDF.RDFGraph (RDFGraph, RDFLabel(..)) -import Swish.RDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceOWL - , namespaceLOG - , rdfType - , rdfFirst, rdfRest, rdfNil - , owlSameAs, logImplies - , defaultBase - ) - -import Swish.Utils.LookupMap (LookupMap(..)) -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName) - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.Text.Read as R - -import Text.ParserCombinators.Poly.StateText - -import Network.URI (URI(..), relativeTo, parseURIReference) - -import Data.Char (isSpace, isHexDigit, chr) -import Data.Maybe (fromMaybe, fromJust) - --- Code - --- | Append the two URIs. Should probably be moved --- out of RDFParser. It is also just a thin wrapper around --- `Network.URI.relativeTo`. - -appendURIs :: - URI -- ^ The base URI - -> URI -- ^ The URI to append (it can be an absolute URI). - -> Either String URI -appendURIs base uri = - case uriScheme uri of - "" -> case uri `relativeTo` base of - Just out -> Right out - _ -> Left $ "Unable to append <" ++ show uri ++ "> to base=<" ++ show base ++ ">" - _ -> Right uri - --- | Type for special name lookup table -type SpecialMap = LookupMap (String,ScopedName) - -{- --- | Lookup prefix in table and return the matching URI. --- --- If the prefix is unknown then we currently error --- out (used to return 'prefix:' or ':' but now using --- URIs I am changing this behavior). This may well be --- backed out. -mapPrefix :: NamespaceMap -> Maybe String -> URI -mapPrefix pmap pfix = - case mapFindMaybe pfix pmap of - Just uri -> uri - Nothing -> error $ "Unable to find prefix: " ++ show pfix -- fromMaybe "" pfix ++ ":" --} - -{- -mapPrefix ps p@(Just pre) = mapFind (pre++":") p ps -mapPrefix ps _ = mapFind ":" Nothing ps --} - --- | Define default table of namespaces -prefixTable :: [Namespace] -prefixTable = [ namespaceRDF - , namespaceRDFS - , namespaceRDFD -- datatypes - , namespaceOWL - , namespaceLOG - , makeNamespace Nothing $ fromJust (parseURIReference "#") -- is this correct? - ] - -{-| -Define default special-URI table. -The optional argument defines the initial base URI. --} -specialTable :: Maybe ScopedName -> [(String,ScopedName)] -specialTable mbase = - [ ("a", rdfType ), - ("equals", owlSameAs ), - ("implies", logImplies ), - ("listfirst", rdfFirst ), - ("listrest", rdfRest ), - ("listnull", rdfNil ), - ("base", fromMaybe defaultBase mbase ) - ] - --- Parser routines, heavily based on Parsec combinators - --- | Run the parser and return the successful parse or an error --- message which consists of the standard Polyparse error plus --- a fragment of the unparsed input to provide context. --- -runParserWithError :: - Parser a b -- ^ parser (carrying state) to apply - -> a -- ^ starting state for the parser - -> L.Text -- ^ input to be parsed - -> Either String b -runParserWithError parser state0 input = - let (result, _, unparsed) = runParser parser state0 input - - -- TODO: work out how best to report error context; for now just take the - -- next 40 characters and assume there is enough context. - econtext = if L.null unparsed - then "\n(at end of the text)\n" - else "\nRemaining input:\n" ++ - case L.compareLength unparsed 40 of - GT -> L.unpack (L.take 40 unparsed) ++ "..." - _ -> L.unpack unparsed - - in case result of - Left emsg -> Left $ emsg ++ econtext - _ -> result - -type ParseResult = Either String RDFGraph - -ignore :: (Applicative f) => f a -> f () -ignore f = f *> pure () - -char :: Char -> Parser s Char -char c = satisfy (==c) - -ichar :: Char -> Parser s () -ichar = ignore . char - --- TODO: is there a better way to do this? -string :: String -> Parser s String -string = mapM char - -stringT :: T.Text -> Parser s T.Text -stringT s = string (T.unpack s) >> return s - -skipMany :: Parser s a -> Parser s () -skipMany = ignore . many - -skipMany1 :: Parser s a -> Parser s () -skipMany1 = ignore . many1 - -endBy :: Parser s a -> Parser s b -> Parser s [a] -endBy p sep = many (p <* sep) - -sepEndBy :: Parser s a -> Parser s b -> Parser s [a] -sepEndBy p sep = sepEndBy1 p sep <|> pure [] - --- is the separator optional? -sepEndBy1 :: Parser s a -> Parser s b -> Parser s [a] -sepEndBy1 p sep = do - x <- p - (sep *> ((x:) <$> sepEndBy p sep)) <|> return [x] - -manyTill :: Parser s a -> Parser s b -> Parser s [a] -manyTill p end = go - where - go = (end *> return []) - <|> - ((:) <$> p <*> go) - - -noneOf :: String -> Parser s Char -noneOf istr = satisfy (`notElem` istr) - -fullStop :: Parser s () -fullStop = ichar '.' - -eoln :: Parser s () --- eoln = ignore (newline <|> (lineFeed *> optional newline)) --- eoln = ignore (try (string "\r\n") <|> string "\r" <|> string "\n") -eoln = ignore (oneOf [string "\r\n", string "\r", string "\n"]) - -notFollowedBy :: (Char -> Bool) -> Parser s () -notFollowedBy p = do - c <- next - if p c - then fail $ "Unexpected character: " ++ show [c] - else reparse $ L.singleton c - -symbol :: String -> Parser s String -symbol = lexeme . string - -isymbol :: String -> Parser s () -isymbol = ignore . symbol - -lexeme :: Parser s a -> Parser s a -lexeme p = p <* whiteSpace - -whiteSpace :: Parser s () -whiteSpace = skipMany (simpleSpace <|> oneLineComment) - -simpleSpace :: Parser s () -simpleSpace = ignore $ many1Satisfy isSpace - -oneLineComment :: Parser s () -oneLineComment = ichar '#' *> manySatisfy (/= '\n') *> pure () - -{- - -Not sure we can get this with polyparse - --- | Annotate a Parsec error with the local context - i.e. the actual text --- that caused the error and preceeding/succeeding lines (if available) --- -annotateParsecError :: - Int -- ^ the number of extra lines to include in the context (<=0 is ignored) - -> [String] -- ^ text being parsed - -> ParseError -- ^ the parse error - -> String -- ^ Parsec error with additional context -annotateParsecError extraLines ls err = - -- the following is based on the show instance of ParseError - let ePos = errorPos err - lNum = sourceLine ePos - cNum = sourceColumn ePos - -- it is possible to be at the end of the input so need - -- to check; should produce better output than this in this - -- case - nLines = length ls - ln1 = lNum - 1 - eln = max 0 extraLines - lNums = [max 0 (ln1 - eln) .. min (nLines-1) (ln1 + eln)] - - beforeLines = map (ls !!) $ filter (< ln1) lNums - afterLines = map (ls !!) $ filter (> ln1) lNums - - -- in testing was able to get a line number after the text so catch this - -- case; is it still necessary? - errorLine = if ln1 >= nLines then "" else ls !! ln1 - arrowLine = replicate (cNum-1) ' ' ++ "^" - finalLine = "(line " ++ show lNum ++ ", column " ++ show cNum ++ " indicated by the '^' sign above):" - - eHdr = "" : beforeLines ++ errorLine : arrowLine : afterLines ++ [finalLine] - eMsg = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" - (errorMessages err) - - in unlines eHdr ++ eMsg - --} - --- | Create a typed literal. -mkTypedLit :: - ScopedName -- ^ the type - -> T.Text -- ^ the value - -> RDFLabel -mkTypedLit u v = Lit v (Just u) - -{- -Handle hex encoding; the spec for N3 and NTriples suggest that -only upper-case A..F are valid but you can find lower-case values -out there so support these too. --} - -hexDigit :: Parser a Char --- hexDigit = satisfy (`elem` ['0'..'9'] ++ ['A'..'F']) -hexDigit = satisfy isHexDigit - -hex4 :: Parser a Char -hex4 = do - digs <- exactly 4 hexDigit - let mhex = R.hexadecimal (T.pack digs) - case mhex of - Left emsg -> failBad $ "Internal error: unable to parse hex4: " ++ emsg - Right (v, "") -> return $ chr v - Right (_, vs) -> failBad $ "Internal error: hex4 remainder = " ++ T.unpack vs - -hex8 :: Parser a Char -hex8 = do - digs <- exactly 8 hexDigit - let mhex = R.hexadecimal (T.pack digs) - case mhex of - Left emsg -> failBad $ "Internal error: unable to parse hex8: " ++ emsg - Right (v, "") -> if v <= 0x10FFFF - then return $ chr v - else failBad "\\UHHHHHHHH format is limited to a maximum of \\U0010FFFF" - Right (_, vs) -> failBad $ "Internal error: hex8 remainder = " ++ T.unpack vs - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFProof.hs b/src/Swish/RDF/RDFProof.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFProof.hs +++ /dev/null @@ -1,380 +0,0 @@ -{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProof --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : FlexibleInstances, UndecidableInstances --- --- This module instantiates the 'Proof' framework for --- constructing proofs over 'RDFGraph' expressions. --- The intent is that this can be used to test some --- correspondences between the RDF Model theory and --- corresponding proof theory based on closure rules --- applied to the graph, per . --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFProof - ( RDFProof, RDFProofStep - , makeRDFProof, makeRDFProofStep - , makeRdfInstanceEntailmentRule - , makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule ) -where - -import Swish.RDF.RDFQuery - ( rdfQueryInstance - , rdfQuerySubs - ) - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset ) - -import Swish.RDF.RDFGraph - ( RDFLabel(..), RDFGraph - --, makeBlank - , merge , allLabels , remapLabelList - {-, newNode, newNodes - , toRDFGraph -}, emptyRDFGraph - ) - -import Swish.RDF.VarBinding (makeVarBinding) - -import Swish.RDF.Proof - ( Proof(..), Step(..) ) - -import Swish.RDF.Rule - ( Expression(..), Rule(..) ) - -import Swish.Utils.Namespace (ScopedName) - -import Swish.RDF.GraphClass - ( Label(..), LDGraph(..), replaceArcs ) - -import Swish.Utils.LookupMap - ( makeLookupMap, mapFind ) - -import Swish.Utils.ListHelpers - ( subset - , powerSet - , powerSequencesLen - , flist - ) - ------------------------------------------------------------- --- Type instantiation of Proof framework for RDFGraph data ------------------------------------------------------------- --- --- This is a partial instantiation of the proof framework. --- Details for applying inference rules are specific to the --- graph instance type. - ------------------------------------------------------------- --- Proof datatypes for graph values ------------------------------------------------------------- - --- The following is an orphan instance - --- |Instances of 'LDGraph' are also instance of the --- @Expression@ class, for which proofs can be constructed. --- The empty RDF graph is always @True@ (other enduring --- truths are asserted as axioms). -instance (Label lb, LDGraph lg lb) => Expression (lg lb) where - isValid = null . getArcs - ------------------------------------------------------------- --- Define RDF-specific types for proof framework ------------------------------------------------------------- - -type RDFProof = Proof RDFGraph - -type RDFProofStep = Step RDFGraph - ------------------------------------------------------------- --- Helper functions for constructing proofs on RDF graphs ------------------------------------------------------------- - --- |Make an RDF graph proof step. --- -makeRDFProofStep :: - RDFRule -- ^ rule to use for this step - -> [RDFFormula] -- ^ antecedent RDF formulae for this step - -> RDFFormula -- ^ RDF formula that is the consequent for this step - -> RDFProofStep -makeRDFProofStep rul ants con = Step - { stepRule = rul - , stepAnt = ants - , stepCon = con - } - --- |Make an RDF proof. --- -makeRDFProof :: - [RDFRuleset] -- ^ RDF rulesets that constitute a proof context for this proof - -> RDFFormula -- ^ initial statement from which the goal is claimed to be proven - -> RDFFormula -- ^ statement that is claimed to be proven - -> [RDFProofStep] - -> RDFProof -makeRDFProof rsets base goal steps = Proof - { proofContext = rsets - , proofInput = base - , proofResult = goal - , proofChain = steps - } - ------------------------------------------------------------- --- RDF instance entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF instance entailment; --- i.e. entailments that are due to replacement of a URI or literal --- node with a blank node. --- --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' and 'bwdApply' functions defined here may return --- rather large results if applied to graphs with many variables or --- a large vocabulary, and are defined for experimentation. --- --- Forward and backward chaining is performed with respect to a --- specified vocabulary. In the case of backward chaining, it would --- otherwise be impossible to bound the options thus generated. --- In the case of forward chaining, it is often not desirable to --- have the properties generalized. If forward or backward backward --- chaining will not be used, supply an empty vocabulary. --- Note: graph method 'allNodes' can be used to obtain a list of all --- the subjects and objuects used ina graph, not counting nested --- formulae; use a call of the form: --- --- > allNodes (not . labelIsVar) graph --- -makeRdfInstanceEntailmentRule :: - ScopedName -- ^ name - -> [RDFLabel] -- ^ vocabulary - -> RDFRule -makeRdfInstanceEntailmentRule name vocab = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = rdfInstanceEntailFwdApply vocab - , bwdApply = rdfInstanceEntailBwdApply vocab - , checkInference = rdfInstanceEntailCheckInference - } - --- Instance entailment forward chaining --- --- Note: unless the initial graph is small, the total result --- here could be very large. The existential generalizations are --- sequenced in increasing number of substitutions applied. --- This sequencing is determined by the powerset function used, --- which generates subsets in increasing order of size --- (see module 'ListHelpers'). --- --- The instances generated are all copies of the merge of the --- supplied graphs, with some or all of the non-variable nodes --- replaced by blank nodes. -rdfInstanceEntailFwdApply :: [RDFLabel] -> [RDFGraph] -> [RDFGraph] -rdfInstanceEntailFwdApply vocab ante = - let - -- Merge antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - mergeGraph = if null ante then emptyRDFGraph - else foldl1 merge ante - -- Obtain lists of variable and non-variable nodes - -- (was: nonvarNodes = allLabels (not . labelIsVar) mergeGraph) - nonvarNodes = vocab - varNodes = allLabels labelIsVar mergeGraph - -- Obtain list of possible remappings for non-variable nodes - mapList = remapLabelList nonvarNodes varNodes - mapSubLists = powerSet mapList - mapGr ls = fmap (\l -> mapFind l l (makeLookupMap ls)) - in - -- Return all remappings of the original merged graph - flist (map mapGr mapSubLists) mergeGraph - --- Instance entailment backward chaining (for specified vocabulary) --- --- [[[TODO: this is an incomplete implementation, there being no --- provision for instantiating some variables and leaving others --- alone. This can be overcome in many cases by combining instance --- and subgraph chaining. --- Also, there is no provision for instantiating some variables in --- a triple and leaving others alone. This may be fixed later if --- this function is really needed to be completely faithful to the --- precise notion of instance entailment.]]] -rdfInstanceEntailBwdApply :: [RDFLabel] -> RDFGraph -> [[RDFGraph]] -rdfInstanceEntailBwdApply vocab cons = - let - -- Obtain list of variable nodes - varNodes = allLabels labelIsVar cons - -- Generate a substitution for each combination of variable - -- and vocabulary node. - varBindings = map (makeVarBinding . zip varNodes) vocSequences - vocSequences = powerSequencesLen (length varNodes) vocab - in - -- Generate a substitution for each combination of variable - -- and vocabulary: - [ rdfQuerySubs [v] cons | v <- varBindings ] - --- Instance entailment inference checker -rdfInstanceEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfInstanceEntailCheckInference ante cons = - let - mante = if null ante then emptyRDFGraph -- merged antecedents - else foldl1 merge ante - qvars = rdfQueryInstance cons mante -- all query matches - bsubs = rdfQuerySubs qvars cons -- all back substitutions - in - -- Return True if any back-substitution matches the original - -- merged antecendent graph. - any (mante ==) bsubs - --- Instance entailment notes. --- --- Relation to simple entailment (s-entails): --- --- (1) back-substitution yields original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o1 by [_:o1/ex:o1] --- --- (2) back-substitution yields original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] --- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/_:o1] --- --- (3) back-substitution does not yield original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] --- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/ex:o1] --- --- (4) consider --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 ex:o1 --- ex:s1 ex:p1 ex:o2 ex:s1 ex:p1 ex:o2 --- ex:s1 ex:p1 ex:o3 ex:s1 ex:p1 _:o1 --- ex:s1 ex:p1 _:o2 --- where [_:o1/ex:o1,_:o2/ex:o2] yields a simple entailment but not --- an instance entailment, but [_:o1/ex:o3,_:o2/ex:o3] is also --- (arguably) an instance entailment. Therefore, it is not sufficient --- to look only at the "largest" substitutions to determine instance --- entailment. --- --- All this means that when checking for instance entailment by --- back substitution, all of the query results must be checked. --- This seems clumsy. If this function is heavily used with --- multiple query matches, a modified query that uses each --- triple of the target graph exactly once may be required. - ------------------------------------------------------------- --- RDF subgraph entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF subgraph entailment. --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' function defined here may return rather large --- results. But in the name of completeness and experimentation --- with the possibilities of lazy evaluation, it has been defined. --- --- Backward chaining is not performed, as there is no reasonable way --- to choose a meaningful supergraph of that supplied. -makeRdfSubgraphEntailmentRule :: ScopedName -> RDFRule -makeRdfSubgraphEntailmentRule name = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = rdfSubgraphEntailFwdApply - , bwdApply = const [] - , checkInference = rdfSubgraphEntailCheckInference - } - --- Subgraph entailment forward chaining --- --- Note: unless the initial graph is small, the total result --- here could be very large. The subgraphs are sequenced in --- increasing size of the sub graph. This sequencing is determined --- by the 'powerSet' function used which generates subsets in --- increasing order of size (see module 'ListHelpers'). -rdfSubgraphEntailFwdApply :: [RDFGraph] -> [RDFGraph] -rdfSubgraphEntailFwdApply ante = - let - -- Merge antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - mergeGraph = if null ante then emptyRDFGraph - else foldl1 merge ante - in - -- Return all subgraphs of the full graph constructed above - map (replaceArcs mergeGraph) (init $ powerSet $ getArcs mergeGraph) - --- Subgraph entailment inference checker --- --- This is of dubious utiltiy, as it doesn't allow for node renaming. --- The simple entailment inference rule is probably more useful here. -rdfSubgraphEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfSubgraphEntailCheckInference ante cons = - let - -- Combine antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - fullGraph = if null ante then emptyRDFGraph - else foldl1 add ante - in - -- Check each consequent graph arc is in the antecedent graph - getArcs cons `subset` getArcs fullGraph - ------------------------------------------------------------- --- RDF simple entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF simple entailment. --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' and 'bwdApply' functions defined return null --- results, indicating that they are not useful for the purposes --- of proof discovery. -makeRdfSimpleEntailmentRule :: ScopedName -> RDFRule -makeRdfSimpleEntailmentRule name = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = const [] - , bwdApply = const [] - , checkInference = rdfSimpleEntailCheckInference - } - --- Simple entailment inference checker --- --- Note: antecedents here are presumed to share bnodes. --- (Use 'merge' instead of 'add' for non-shared bnodes) --- -rdfSimpleEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfSimpleEntailCheckInference ante cons = - let agr = if null ante then emptyRDFGraph else foldl1 add ante - in - not $ null $ rdfQueryInstance cons agr - -{- original.. - not $ null $ rdfQueryInstance cons (foldl1 merge ante) --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFProofContext.hs b/src/Swish/RDF/RDFProofContext.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFProofContext.hs +++ /dev/null @@ -1,848 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProofContext --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module contains proof-context declarations based on --- the RDF, RDFS, and RDF datatyping semantics specifications. --- These definitions consist of namespaces (for identification --- in proofs), axioms and inference rules. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFProofContext ( rulesetRDF - , rulesetRDFS - , rulesetRDFD) where - -import Swish.RDF.BuiltInDatatypes (findRDFDatatype) - -import Swish.RDF.RDFProof - ( makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule ) - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset - , makeRDFFormula - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeN3ClosureModifyRule - , makeN3ClosureAllocatorRule - , makeNodeAllocTo ) - -import Swish.RDF.RDFVarBinding - ( RDFVarBinding - , RDFVarBindingModify - , RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.RDF.RDFGraph - ( RDFLabel(..) - , isUri, isDatatyped - , getLiteralText ) - -import Swish.RDF.VarBinding - ( applyVarBinding - , addVarBinding - , VarBindingModify(..) - , makeVarFilterModify - , varFilterDisjunction - ) - -import Swish.RDF.Ruleset (makeRuleset) -import Swish.RDF.Datatype (typeMkCanonicalForm) -import Swish.Utils.Namespace (Namespace, makeNSScopedName) - -import Swish.RDF.Vocabulary - ( namespaceRDFD - , scopeRDF - , scopeRDFS - , scopeRDFD - ) - -import Control.Monad (liftM) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isJust, fromJust) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Define query binding filter auxiliaries ------------------------------------------------------------- - -makeFormula :: Namespace -> T.Text -> B.Builder -> RDFFormula -makeFormula = makeRDFFormula - -requireAny :: [RDFVarBindingFilter] -> RDFVarBindingFilter -requireAny = varFilterDisjunction - -isLiteralV :: String -> RDFVarBindingFilter -isLiteralV = rdfVarBindingLiteral . Var - -isUntypedLitV :: String -> RDFVarBindingFilter -isUntypedLitV = rdfVarBindingUntypedLiteral . Var - -isXMLLitV :: String -> RDFVarBindingFilter -isXMLLitV = rdfVarBindingXMLLiteral . Var - -isUriRefV :: String -> RDFVarBindingFilter -isUriRefV = rdfVarBindingUriRef . Var - -isBlankV :: String -> RDFVarBindingFilter -isBlankV = rdfVarBindingBlank . Var - -isDatatypedV :: String -> String -> RDFVarBindingFilter -isDatatypedV d l = rdfVarBindingDatatyped (Var d) (Var l) - -isMemberPropV :: String -> RDFVarBindingFilter -isMemberPropV = rdfVarBindingMemberProp . Var - -allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify -allocateTo bv av = makeNodeAllocTo (Var bv) (Var av) - --- Create new binding for datatype -valueSame :: String -> String -> String -> String -> RDFVarBindingModify -valueSame val1 typ1 val2 typ2 = - sameDatatypedValue (Var val1) (Var typ1) (Var val2) (Var typ2) - --- Variable binding modifier to create new binding to a canonical --- form of a datatyped literal. -sameDatatypedValue :: - RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel -> RDFVarBindingModify -sameDatatypedValue val1 typ1 val2 typ2 = VarBindingModify - { vbmName = makeNSScopedName namespaceRDFD "sameValue" - , vbmApply = sameDatatypedValueApplyAll val1 typ1 val2 typ2 - , vbmVocab = [val1,typ1,val2,typ2] - , vbmUsage = [[val2]] - } - -sameDatatypedValueApplyAll :: - RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel - -> [RDFVarBinding] - -> [RDFVarBinding] -sameDatatypedValueApplyAll val1 typ1 val2 typ2 = - concatMap (sameDatatypedValueApply val1 typ1 val2 typ2) - --- Auxiliary function that handles variable binding updates --- for sameDatatypedValue -sameDatatypedValueApply :: - RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel - -> RDFVarBinding - -> [RDFVarBinding] -sameDatatypedValueApply val1 typ1 val2 typ2 vbind = - result - where - v1 = applyVarBinding vbind val1 - t1 = applyVarBinding vbind typ1 - t2 = applyVarBinding vbind typ2 - sametype = getCanonical v1 t1 t2 - result = - if isUri t1 && isUri t2 then - if t1 == t2 then - case sametype of - Just st -> [addVarBinding val2 st vbind] - _ -> [] - else - error "subtype conversions not yet defined" - else - [] - -getCanonical :: RDFLabel -> RDFLabel -> RDFLabel -> Maybe RDFLabel -getCanonical v1 t1 t2 = - if isDatatyped dqn1 v1 && isJust mdt1 then - liftM mkLit $ typeMkCanonicalForm dt1 (getLiteralText v1) - else - Nothing - where - dqn1 = getRes t1 - dqn2 = getRes t2 - mdt1 = findRDFDatatype dqn1 - dt1 = fromJust mdt1 - mkLit = flip Lit (Just dqn2) - - getRes (Res dqnam) = dqnam - getRes x = error $ "Expected a Resource, sent " ++ show x -- for -Wall - -{- -- Test data -qnamint = ScopedName namespaceXSD "integer" -xsdint = Res qnamint -lab010 = Lit "010" (Just qnamint) -can010 = getCanonical lab010 xsdint xsdint -nsex = Namespace "ex" "http://example.org/" -resexp = Res (ScopedName nsex "p") -resexs = Res (ScopedName nsex "s") - -vara = Var "a" -varb = Var "b" -varc = Var "c" -vard = Var "d" -varp = Var "p" -vars = Var "s" -vart = Var "t" - -vb1 = makeVarBinding [(vara,lab010),(varb,xsdint),(vard,xsdint)] -vb2 = sameDatatypedValueApply vara varb varc vard vb1 -vb3 = vbmApply (sameDatatypedValue vara varb varc vard) [vb1] -vb3t = vb3 == vb2 -vb4 = vbmApply (valueSame "a" "b" "c" "d") [vb1] -vb4t = vb4 == vb2 -vb5 = vbmApply (valueSame "a" "b" "c" "b") [vb1] -vb5t = vb5 == vb2 - -vb6 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint)] -vb7 = vbmApply (valueSame "s" "d" "t" "d") [vb6] -vb8 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint) - ,(vart,fromJust can010)] -vb8t = vb7 == [vb8] --- -} - ------------------------------------------------------------- --- Common definitions ------------------------------------------------------------- - ------------------------------------------------------------- --- Define RDF axioms ------------------------------------------------------------- - --- scopeRDF = Namespace "rs-rdf" "http://id.ninebynine.org/2003/Ruleset/rdf#" - --- RDF axioms (from RDF semantics document, section 3.1) --- --- (See also, container property rules below) --- -rdfa1 :: RDFFormula -rdfa1 = makeFormula scopeRDF "a1" "rdf:type rdf:type rdf:Property ." - -rdfa2 :: RDFFormula -rdfa2 = makeFormula scopeRDF "a2" "rdf:subject rdf:type rdf:Property ." - -rdfa3 :: RDFFormula -rdfa3 = makeFormula scopeRDF "a3" "rdf:predicate rdf:type rdf:Property ." - -rdfa4 :: RDFFormula -rdfa4 = makeFormula scopeRDF "a4" "rdf:object rdf:type rdf:Property ." - -rdfa5 :: RDFFormula -rdfa5 = makeFormula scopeRDF "a5" "rdf:first rdf:type rdf:Property ." - -rdfa6 :: RDFFormula -rdfa6 = makeFormula scopeRDF "a6" "rdf:rest rdf:type rdf:Property ." - -rdfa7 :: RDFFormula -rdfa7 = makeFormula scopeRDF "a7" "rdf:value rdf:type rdf:Property ." - -rdfa8 :: RDFFormula -rdfa8 = makeFormula scopeRDF "a8" "rdf:nil rdf:type rdf:List ." - -axiomsRDF :: [RDFFormula] -axiomsRDF = - [ rdfa1, rdfa2, rdfa3, rdfa4, rdfa5 - , rdfa6, rdfa7, rdfa8 - ] - ------------------------------------------------------------- --- Define RDF rules ------------------------------------------------------------- - --- RDF subgraph entailment (from RDF semantics document section 2) --- -rdfsub :: RDFRule -rdfsub = makeRdfSubgraphEntailmentRule (makeNSScopedName scopeRDF "sub") - --- RDF simple entailment (from RDF semantics document section 7.1) --- (Note: rules se1 and se2 are combined here, because the scope of --- the "allocatedTo" modifier is the application of a single rule.) --- -rdfse :: RDFRule -rdfse = makeRdfSimpleEntailmentRule (makeNSScopedName scopeRDF "se") - --- RDF bnode-for-literal assignments (from RDF semantics document section 7.1) --- -rdflg :: RDFRule -rdflg = makeN3ClosureAllocatorRule scopeRDF "lg" - "?x ?a ?l . " - "?x ?a ?b . ?b rdf:_allocatedTo ?l ." - (makeVarFilterModify $ isLiteralV "l") - (allocateTo "b" "l") - --- RDF bnode-for-literal back-tracking (from RDF semantics document section 7.1) --- -rdfgl :: RDFRule -rdfgl = makeN3ClosureSimpleRule scopeRDF "gl" - "?x ?a ?l . ?b rdf:_allocatedTo ?l . " - "?x ?a ?b ." - --- RDF entailment rules (from RDF semantics document section 7.2) --- --- (Note, statements with property rdf:_allocatedTo are introduced to --- track bnodes introduced according to rule rdflf [presumably this --- is actually rdflg?]) --- -rdfr1 :: RDFRule -rdfr1 = makeN3ClosureSimpleRule scopeRDF "r1" - "?x ?a ?y ." - "?a rdf:type rdf:Property ." - -rdfr2 :: RDFRule -rdfr2 = makeN3ClosureRule scopeRDF "r2" - "?x ?a ?b . ?b rdf:_allocatedTo ?l . " - "?b rdf:type rdf:XMLLiteral ." - (makeVarFilterModify $ isXMLLitV "l") - --- Container property axioms (from RDF semantics document section 3.1) --- --- (Using here an inference rule with a filter in place of an axiom schema) --- --- This is a restricted form of the given axioms, in that the axioms --- are asserted only for container membership terms that appear in --- the graph. --- --- (This may be very inefficient for forward chaining when dealing with --- large graphs: may need to look at query logic to see if the search for --- container membership properties can be optimized. This may call for a --- custom inference rule.) --- -rdfcp1 :: RDFRule -rdfcp1 = makeN3ClosureRule scopeRDF "cp1" - "?x ?c ?y . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfcp2 :: RDFRule -rdfcp2 = makeN3ClosureRule scopeRDF "cp2" - "?c ?p ?y . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfcp3 :: RDFRule -rdfcp3 = makeN3ClosureRule scopeRDF "cp3" - "?x ?p ?c . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "c") - --- Collect RDF rules --- -rulesRDF :: [RDFRule] -rulesRDF = - [ rdfsub, rdfse - , rdflg, rdfgl - , rdfr1, rdfr2 - , rdfcp1, rdfcp2, rdfcp3 - ] - --- | Ruleset for RDF inference. - -rulesetRDF :: RDFRuleset -rulesetRDF = makeRuleset scopeRDF axiomsRDF rulesRDF - ------------------------------------------------------------- --- Define RDFS axioms ------------------------------------------------------------- - --- scopeRDFS = Namespace "rdfs" "http://id.ninebynine.org/2003/Ruleset/rdfs#" - --- RDFS axioms (from RDF semantics document, section 4.1) --- --- (See also, container property rules below) --- - -rdfsa01 :: RDFFormula -rdfsa01 = makeFormula scopeRDFS "a01" - "rdf:type rdfs:domain rdfs:Resource ." - -rdfsa02 :: RDFFormula -rdfsa02 = makeFormula scopeRDFS "a02" - "rdf:type rdfs:range rdfs:Class ." - -rdfsa03 :: RDFFormula -rdfsa03 = makeFormula scopeRDFS "a03" - "rdfs:domain rdfs:domain rdf:Property ." - -rdfsa04 :: RDFFormula -rdfsa04 = makeFormula scopeRDFS "a04" - "rdfs:domain rdfs:range rdfs:Class ." - -rdfsa05 :: RDFFormula -rdfsa05 = makeFormula scopeRDFS "a05" - "rdfs:range rdfs:domain rdf:Property ." - -rdfsa06 :: RDFFormula -rdfsa06 = makeFormula scopeRDFS "a06" - "rdfs:range rdfs:range rdfs:Class ." - -rdfsa07 :: RDFFormula -rdfsa07 = makeFormula scopeRDFS "a07" - "rdfs:subPropertyOf rdfs:domain rdf:Property ." - -rdfsa08 :: RDFFormula -rdfsa08 = makeFormula scopeRDFS "a08" - "rdfs:subPropertyOf rdfs:range rdf:Property ." - -rdfsa09 :: RDFFormula -rdfsa09 = makeFormula scopeRDFS "a09" - "rdfs:subClassOf rdfs:domain rdfs:Class ." - -rdfsa10 :: RDFFormula -rdfsa10 = makeFormula scopeRDFS "a10" - "rdfs:subClassOf rdfs:range rdfs:Class ." - -rdfsa11 :: RDFFormula -rdfsa11 = makeFormula scopeRDFS "a11" - "rdf:subject rdfs:domain rdf:Statement ." - -rdfsa12 :: RDFFormula -rdfsa12 = makeFormula scopeRDFS "a12" - "rdf:subject rdfs:range rdfs:Resource ." - -rdfsa13 :: RDFFormula -rdfsa13 = makeFormula scopeRDFS "a13" - "rdf:predicate rdfs:domain rdf:Statement ." - -rdfsa14 :: RDFFormula -rdfsa14 = makeFormula scopeRDFS "a14" - "rdf:predicate rdfs:range rdfs:Resource ." - -rdfsa15 :: RDFFormula -rdfsa15 = makeFormula scopeRDFS "a15" - "rdf:object rdfs:domain rdf:Statement ." - -rdfsa16 :: RDFFormula -rdfsa16 = makeFormula scopeRDFS "a16" - "rdf:object rdfs:range rdfs:Resource ." - -rdfsa17 :: RDFFormula -rdfsa17 = makeFormula scopeRDFS "a17" - "rdfs:member rdfs:domain rdfs:Resource ." - -rdfsa18 :: RDFFormula -rdfsa18 = makeFormula scopeRDFS "a18" - "rdfs:member rdfs:range rdfs:Resource ." - -rdfsa19 :: RDFFormula -rdfsa19 = makeFormula scopeRDFS "a19" - "rdf:first rdfs:domain rdf:List ." - -rdfsa20 :: RDFFormula -rdfsa20 = makeFormula scopeRDFS "a20" - "rdf:first rdfs:range rdfs:Resource ." - -rdfsa21 :: RDFFormula -rdfsa21 = makeFormula scopeRDFS "a21" - "rdf:rest rdfs:domain rdf:List ." - -rdfsa22 :: RDFFormula -rdfsa22 = makeFormula scopeRDFS "a22" - "rdf:rest rdfs:range rdf:List ." - -rdfsa23 :: RDFFormula -rdfsa23 = makeFormula scopeRDFS "a23" - "rdfs:seeAlso rdfs:domain rdfs:Resource ." - -rdfsa24 :: RDFFormula -rdfsa24 = makeFormula scopeRDFS "a24" - "rdfs:seeAlso rdfs:range rdfs:Resource ." - -rdfsa25 :: RDFFormula -rdfsa25 = makeFormula scopeRDFS "a25" - "rdfs:isDefinedBy rdfs:domain rdfs:Resource ." - -rdfsa26 :: RDFFormula -rdfsa26 = makeFormula scopeRDFS "a26" - "rdfs:isDefinedBy rdfs:range rdfs:Resource ." - -rdfsa27 :: RDFFormula -rdfsa27 = makeFormula scopeRDFS "a27" - "rdfs:isDefinedBy rdfs:subPropertyOf rdfs:seeAlso ." - -rdfsa28 :: RDFFormula -rdfsa28 = makeFormula scopeRDFS "a28" - "rdfs:comment rdfs:domain rdfs:Resource ." - -rdfsa29 :: RDFFormula -rdfsa29 = makeFormula scopeRDFS "a29" - "rdfs:comment rdfs:range rdfs:Literal ." - -rdfsa30 :: RDFFormula -rdfsa30 = makeFormula scopeRDFS "a30" - "rdfs:label rdfs:domain rdfs:Resource ." - -rdfsa31 :: RDFFormula -rdfsa31 = makeFormula scopeRDFS "a31" - "rdfs:label rdfs:range rdfs:Literal ." - -rdfsa32 :: RDFFormula -rdfsa32 = makeFormula scopeRDFS "a32" - "rdf:value rdfs:domain rdfs:Resource ." - -rdfsa33 :: RDFFormula -rdfsa33 = makeFormula scopeRDFS "a33" - "rdf:value rdfs:range rdfs:Resource ." - -rdfsa34 :: RDFFormula -rdfsa34 = makeFormula scopeRDFS "a34" - "rdf:Alt rdfs:subClassOf rdfs:Container ." - -rdfsa35 :: RDFFormula -rdfsa35 = makeFormula scopeRDFS "a35" - "rdf:Bag rdfs:subClassOf rdfs:Container ." - -rdfsa36 :: RDFFormula -rdfsa36 = makeFormula scopeRDFS "a36" - "rdf:Seq rdfs:subClassOf rdfs:Container ." - -rdfsa37 :: RDFFormula -rdfsa37 = makeFormula scopeRDFS "a37" - "rdfs:ContainerMembershipProperty rdfs:subClassOf rdf:Property ." - -rdfsa38 :: RDFFormula -rdfsa38 = makeFormula scopeRDFS "a38" - "rdf:XMLLiteral rdf:type rdfs:Datatype ." - -rdfsa39 :: RDFFormula -rdfsa39 = makeFormula scopeRDFS "a39" - "rdf:XMLLiteral rdfs:subClassOf rdfs:Literal ." - -rdfsa40 :: RDFFormula -rdfsa40 = makeFormula scopeRDFS "a40" - "rdfs:Datatype rdfs:subClassOf rdfs:Class ." - -axiomsRDFS :: [RDFFormula] -axiomsRDFS = - [ rdfsa01, rdfsa02, rdfsa03, rdfsa04 - , rdfsa05, rdfsa06, rdfsa07, rdfsa08, rdfsa09 - , rdfsa10, rdfsa11, rdfsa12, rdfsa13, rdfsa14 - , rdfsa15, rdfsa16, rdfsa17, rdfsa18, rdfsa19 - , rdfsa20, rdfsa21, rdfsa22, rdfsa23, rdfsa24 - , rdfsa25, rdfsa26, rdfsa27, rdfsa28, rdfsa29 - , rdfsa30, rdfsa31, rdfsa32, rdfsa33, rdfsa34 - , rdfsa35, rdfsa36, rdfsa37, rdfsa38, rdfsa39 - , rdfsa40 - ] - ------------------------------------------------------------- --- Define RDFS rules ------------------------------------------------------------- - -{- -rdfr2 = makeN3ClosureRule scopeRDF "r2" - "?x ?a ?b . ?b rdf:_allocatedTo ?l . " - "?b rdf:type rdf:XMLLiteral ." - (makeVarFilterModify $ isXMLLit "?l") --} - --- RDFS entailment rules (from RDF semantics document section 7.2) --- --- (Note, statements with property rdf:_allocatedTo are introduced to --- track bnodes introduced according to rule rdflf [presumably this --- is actually rdflg?]) --- -rdfsr1 :: RDFRule -rdfsr1 = makeN3ClosureRule scopeRDFS "r1" - "?x ?a ?b . ?b rdf:_allocatedTo ?l . " - "?b rdf:type rdfs:Literal ." - (makeVarFilterModify $ isUntypedLitV "l" ) - -rdfsr2 :: RDFRule -rdfsr2 = makeN3ClosureSimpleRule scopeRDFS "r2" - "?x ?a ?y . ?a rdfs:domain ?z ." - "?x rdf:type ?z ." - -rdfsr3 :: RDFRule -rdfsr3 = makeN3ClosureRule scopeRDFS "r3" - "?u ?a ?v . ?a rdfs:range ?z ." - "?v rdf:type ?z ." - (makeVarFilterModify $ requireAny [isUriRefV "v",isBlankV "v"]) - -rdfsr4a :: RDFRule -rdfsr4a = makeN3ClosureSimpleRule scopeRDFS "r4a" - "?x ?a ?y ." - "?x rdf:type rdfs:Resource ." - -rdfsr4b :: RDFRule -rdfsr4b = makeN3ClosureRule scopeRDFS "r4b" - "?x ?a ?u ." - "?u rdf:type rdfs:Resource ." - (makeVarFilterModify $ requireAny [isUriRefV "u",isBlankV "u"]) - -rdfsr5 :: RDFRule -rdfsr5 = makeN3ClosureSimpleRule scopeRDFS "r5" - "?a rdfs:subPropertyOf ?b . ?b rdfs:subPropertyOf ?c ." - "?a rdfs:subPropertyOf ?c ." - -rdfsr6 :: RDFRule -rdfsr6 = makeN3ClosureSimpleRule scopeRDFS "r6" - "?x rdf:type rdf:Property ." - "?x rdfs:subPropertyOf ?x ." - -rdfsr7 :: RDFRule -rdfsr7 = makeN3ClosureSimpleRule scopeRDFS "r7" - "?x ?a ?y . ?a rdfs:subPropertyOf ?b ." - "?x ?b ?y ." - -rdfsr8 :: RDFRule -rdfsr8 = makeN3ClosureSimpleRule scopeRDFS "r8" - "?x rdf:type rdfs:Class ." - "?x rdfs:subClassOf rdfs:Resource ." - -rdfsr9 :: RDFRule -rdfsr9 = makeN3ClosureSimpleRule scopeRDFS "r9" - "?x rdfs:subClassOf ?y . ?a rdf:type ?x ." - "?a rdf:type ?y ." - -rdfsr10 :: RDFRule -rdfsr10 = makeN3ClosureSimpleRule scopeRDFS "r10" - "?x rdf:type rdfs:Class ." - "?x rdfs:subClassOf ?x ." - -rdfsr11 :: RDFRule -rdfsr11 = makeN3ClosureSimpleRule scopeRDFS "r11" - "?x rdfs:subClassOf ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:subClassOf ?z ." - -rdfsr12 :: RDFRule -rdfsr12 = makeN3ClosureSimpleRule scopeRDFS "r12" - "?x rdf:type rdfs:ContainerMembershipProperty ." - "?x rdfs:subPropertyOf rdfs:member ." - -rdfsr13 :: RDFRule -rdfsr13 = makeN3ClosureSimpleRule scopeRDFS "r13" - "?x rdf:type rdfs:Datatype ." - "?x rdfs:subClassOf rdfs:Literal ." - --- These are valid only under an extensional strengthening of RDFS, --- discussed in section 7.3.1 of the RDF semantics specification: - -{- -rdfsrext1 :: RDFRule -rdfsrext1 = makeN3ClosureSimpleRule scopeRDFS "ext1" - "?x rdfs:domain ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:domain ?z ." - -rdfsrext2 :: RDFRule -rdfsrext2 = makeN3ClosureSimpleRule scopeRDFS "ext2" - "?x rdfs:range ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:range ?z ." - -rdfsrext3 :: RDFRule -rdfsrext3 = makeN3ClosureSimpleRule scopeRDFS "ext3" - "?x rdfs:domain ?y . ?z rdfs:subPropertyOf ?x ." - "?z rdfs:domain ?y ." - -rdfsrext4 :: RDFRule -rdfsrext4 = makeN3ClosureSimpleRule scopeRDFS "ext4" - "?x rdfs:range ?y . ?z rdfs:subPropertyOf ?x ." - "?z rdfs:range ?y ." - -rdfsrext5 :: RDFRule -rdfsrext5 = makeN3ClosureSimpleRule scopeRDFS "ext5" - "rdf:type rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Resource rdfs:subClassOf ?y ." - -rdfsrext6 :: RDFRule -rdfsrext6 = makeN3ClosureSimpleRule scopeRDFS "rext6" - "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Class rdfs:subClassOf ?y ." - -rdfsrext7 :: RDFRule -rdfsrext7 = makeN3ClosureSimpleRule scopeRDFS "rext7" - "rdfs:subPropertyOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Property rdfs:subClassOf ?y ." - -rdfsrext8 :: RDFRule -rdfsrext8 = makeN3ClosureSimpleRule scopeRDFS "rext8" - "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:range ?y ." - "rdfs:Class rdfs:subClassOf ?y ." - -rdfsrext9 :: RDFRule -rdfsrext9 = makeN3ClosureSimpleRule scopeRDFS "rext9" - "rdfs:subPropertyOf rdfs:subPropertyOf ?z . ?z rdfs:range ?y ." - "rdfs:Property rdfs:subClassOf ?y ." - --} - --- Container property axioms (from RDF semantics document section 4.1) --- --- (Using here an inference rule with a filter in place of an axiom schema) --- --- This is a restricted form of the given axioms, in that the axioms --- are asserted only for container membership terms that appear in --- the graph. --- --- (This may be very inefficient for forward chaining when dealing with --- large graphs: may need to look at query logic to see if the search for --- container membership properties can be optimized. This may call for a --- custom inference rule.) --- -rdfscp11 :: RDFRule -rdfscp11 = makeN3ClosureRule scopeRDFS "cp11" - "?x ?c ?y . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp12 :: RDFRule -rdfscp12 = makeN3ClosureRule scopeRDFS "cp12" - "?c ?p ?y . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp13 :: RDFRule -rdfscp13 = makeN3ClosureRule scopeRDFS "cp13" - "?x ?p ?c . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp21 :: RDFRule -rdfscp21 = makeN3ClosureRule scopeRDFS "cp21" - "?x ?c ?y . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp22 :: RDFRule -rdfscp22 = makeN3ClosureRule scopeRDFS "cp22" - "?c ?p ?y . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp23 :: RDFRule -rdfscp23 = makeN3ClosureRule scopeRDFS "cp23" - "?x ?p ?c . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp31 :: RDFRule -rdfscp31 = makeN3ClosureRule scopeRDFS "cp31" - "?x ?c ?y . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp32 :: RDFRule -rdfscp32 = makeN3ClosureRule scopeRDFS "cp32" - "?c ?p ?y . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - -rdfscp33 :: RDFRule -rdfscp33 = makeN3ClosureRule scopeRDFS "cp33" - "?x ?p ?c . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "c") - --- Collect RDFS rules --- -rulesRDFS :: [RDFRule] -rulesRDFS = - [ rdfsr1, rdfsr2, rdfsr3, rdfsr4a, rdfsr4b - , rdfsr5, rdfsr6, rdfsr7, rdfsr8, rdfsr9 - , rdfsr10, rdfsr11, rdfsr12, rdfsr13 - , rdfscp11, rdfscp12, rdfscp13 - , rdfscp21, rdfscp22, rdfscp23 - , rdfscp31, rdfscp32, rdfscp33 - ] - --- | Ruleset for RDFS inference. - -rulesetRDFS :: RDFRuleset -rulesetRDFS = makeRuleset scopeRDFS axiomsRDFS rulesRDFS - ------------------------------------------------------------- --- Define RDFD (datatyping) axioms ------------------------------------------------------------- - --- scopeRDFD = Namespace "rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" - -axiomsRDFD :: [RDFFormula] -axiomsRDFD = - [ - ] - ------------------------------------------------------------- --- Define RDFD (datatyping) axioms ------------------------------------------------------------- - --- RDFD closure rules from semantics document, section 7.4 - --- Infer type of datatyped literal --- -rdfdr1 :: RDFRule -rdfdr1 = makeN3ClosureRule scopeRDFD "r1" - "?d rdf:type rdfs:Datatype . ?a ?p ?l . ?b rdf:_allocatedTo ?l . " - "?b rdf:type ?d ." - (makeVarFilterModify $ isDatatypedV "d" "l") - --- Equivalent literals with same datatype: --- (generate canonical form, or operate in proof mode only) --- -rdfdr2 :: RDFRule -rdfdr2 = makeN3ClosureRule scopeRDFD "r2" - "?d rdf:type rdfs:Datatype . ?a ?p ?s ." - "?a ?p ?t ." - (valueSame "s" "d" "t" "d") - -{- Note that valueSame does datatype check. Otherwise use: -rdfdr2 = makeN3ClosureModifyRule scopeRDFD "r2" - "?d rdf:type rdfs:Datatype . ?a ?p ?s ." - "?a ?p ?t ." - (makeVarFilterModify $ isDatatypedV "d" "s") - (valueSame "s" "d" "t" "d") --} - --- Equivalent literals with different datatypes: --- (generate canonical form, or operate in proof mode only) --- -rdfdr3 :: RDFRule -rdfdr3 = makeN3ClosureModifyRule scopeRDFD "r3" - ( "?d rdf:type rdfs:Datatype . ?e rdf:type rdfs:Datatype . " `mappend` - "?a ?p ?s ." ) - "?a ?p ?t ." - (makeVarFilterModify $ isDatatypedV "s" "d") - (valueSame "s" "d" "t" "e") - --- Collect RDFD rules --- -rulesRDFD :: [RDFRule] -rulesRDFD = - [ rdfdr1, rdfdr2, rdfdr3 - ] - --- | Ruleset for RDFD (datatyping) inference. --- -rulesetRDFD :: RDFRuleset -rulesetRDFD = makeRuleset scopeRDFD axiomsRDFD rulesRDFD - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFQuery.hs b/src/Swish/RDF/RDFQuery.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFQuery.hs +++ /dev/null @@ -1,636 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFQuery --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module defines functions for querying an RDF graph to obtain --- a set of variable substitutions, and to apply a set of variable --- substitutions to a query pattern to obtain a new graph. --- --- It also defines a few primitive graph access functions. --- --- A minimal example is shown below, where we query a very simple --- graph: --- --- >>> :m + Swish.RDF Swish.RDF.N3Parser Swish.RDF.RDFQuery --- >>> :set -XOverloadedStrings --- >>> let qparse = either error id . parseN3fromText --- >>> let igr = qparse "@prefix a: . a:a a a:A ; a:foo a:bar. a:b a a:B ; a:foo a:bar." --- >>> let qgr = qparse "?node a ?type." --- >>> rdfQueryFind qgr igr --- [[(?type,a:B),(?node,a:b)],[(?type,a:A),(?node,a:a)]] --- >>> let bn = (toRDFLabel . Data.Maybe.fromJust . Network.URI.parseURI) "http://example.com/B" --- >>> rdfFindArcs (rdfObjEq bn) igr --- [(a:b,rdf:type,a:B)] --- >>> Data.Maybe.mapMaybe (flip Swish.RDF.VarBinding.vbMap (Var "type")) $ rdfQueryFind qgr igr --- [a:B,a:A] --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFQuery - ( rdfQueryFind, rdfQueryFilter - , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify - , rdfQueryInstance - , rdfQuerySubs, rdfQueryBackSubs - , rdfQuerySubsAll - , rdfQuerySubsBlank, rdfQueryBackSubsBlank - , rdfFindArcs, rdfSubjEq, rdfPredEq, rdfObjEq - , rdfFindPredVal, rdfFindPredInt, rdfFindValSubj - , rdfFindList - -- debug - , rdfQuerySubs2 ) -where - -import Swish.RDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingFilter - ) - -import Swish.RDF.RDFGraph - ( Arc(..), LDGraph(..) - , arcSubj, arcPred, arcObj - , RDFLabel(..) - , isDatatyped, isBlank, isQueryVar - , getLiteralText, makeBlank - , RDFTriple - , RDFGraph, emptyRDFGraph - , allLabels, remapLabels - , resRdfFirst - , resRdfRest - , resRdfNil - ) - -import Swish.RDF.MapXsdInteger (mapXsdInteger) -import Swish.RDF.Datatype (DatatypeMap(..)) - -import Swish.RDF.VarBinding - ( VarBinding(..) - , makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , VarBindingFilter(..) - ) - -import Swish.RDF.Vocabulary (xsdInteger, xsdNonNegInteger) - -import Swish.Utils.ListHelpers (listProduct, allp, anyp) - -import qualified Data.Traversable as Traversable - -import Control.Monad.State (State, runState, modify) - -import Data.Maybe (mapMaybe, isJust, fromJust) - --- import qualified Data.Text as T - ------------------------------------------------------------- --- Primitive RDF graph queries ------------------------------------------------------------- - --- | Basic graph-query function. --- --- The triples of the query graph are matched sequentially --- against the target graph, each taking account of any --- variable bindings that have already been determined, --- and adding new variable bindings as triples containing --- query variables are matched against the graph. --- -rdfQueryFind :: - RDFGraph -- ^ The query graph. - -> RDFGraph -- ^ The target graph. - -> [RDFVarBinding] - -- ^ Each element represents a set of variable bindings that make the query graph a - -- subgraph of the target graph. The list can be empty. -rdfQueryFind = - rdfQueryPrim1 matchQueryVariable nullRDFVarBinding . getArcs - --- Helper function to match query against a graph. --- A node-query function is supplied to determine how query nodes --- are matched against target graph nodes. Also supplied is --- an initial variable binding. --- -rdfQueryPrim1 :: - NodeQuery RDFLabel -> RDFVarBinding -> [Arc RDFLabel] - -> RDFGraph - -> [RDFVarBinding] -rdfQueryPrim1 _ initv [] _ = [initv] -rdfQueryPrim1 nodeq initv (qa:qas) tg = - let - qam = fmap (applyVarBinding initv) qa -- subst vars already bound - newv = rdfQueryPrim2 nodeq qam tg -- new bindings, or null - in - concat - [ rdfQueryPrim1 nodeq v2 qas tg - | v1 <- newv - , let v2 = joinVarBindings initv v1 - ] - --- Match single query term against graph, and return any new sets --- of variable bindings thus defined, or [] if the query term --- cannot be matched. Each of the RDFVarBinding values returned --- represents an alternative possible match for the query arc. --- -rdfQueryPrim2 :: - NodeQuery RDFLabel -> Arc RDFLabel - -> RDFGraph - -> [RDFVarBinding] -rdfQueryPrim2 nodeq qa tg = - mapMaybe (getBinding nodeq qa) (getArcs tg) - --- |RDF query filter. --- --- This function applies a supplied query binding --- filter to the result from a call of 'rdfQueryFind'. --- --- If none of the query bindings found satisfy the filter, a null --- list is returned (which is what 'rdfQueryFind' returns if the --- query cannot be satisfied). --- --- (Because of lazy evaluation, this should be as efficient as --- applying the filter as the search proceeds. I started to build --- the filter logic into the query function itself, with consequent --- increase in complexity, until I remembered lazy evaluation lets --- me keep things separate.) --- -rdfQueryFilter :: - RDFVarBindingFilter -> [RDFVarBinding] -> [RDFVarBinding] -rdfQueryFilter qbf = filter (vbfTest qbf) - ------------------------------------------------------------- --- Backward-chaining RDF graph queries ------------------------------------------------------------- - --- |Reverse graph-query function. --- --- Similar to 'rdfQueryFind', but with different success criteria. --- The query graph is matched against the supplied graph, --- but not every triple of the query is required to be matched. --- Rather, every triple of the target graph must be matched, --- and substitutions for just the variables thus bound are --- returned. In effect, these are subsitutions in the query --- that entail the target graph (where @rdfQueryFind@ returns --- substitutions that are entailed by the target graph). --- --- Multiple substitutions may be used together, so the result --- returned is a list of lists of query bindings. Each inner --- list contains several variable bindings that must all be applied --- separately to the closure antecendents to obtain a collection of --- expressions that together are antecedent to the supplied --- conclusion. A null list of bindings returned means the --- conclusion can be inferred without any antecedents. --- --- Note: in back-chaining, the conditions required to prove each --- target triple are derived independently, using the inference rule --- for each such triple, so there are no requirements to check --- consistency with previously determined variable bindings, as --- there are when doing forward chaining. A result of this is that --- there may be redundant triples generated by the back-chaining --- process. Any process using back-chaining should deal with the --- results returned accordingly. --- --- An empty outer list is returned if no combination of --- substitutions can infer the supplied target. --- -rdfQueryBack :: RDFGraph -> RDFGraph -> [[RDFVarBinding]] -rdfQueryBack qg tg = - rdfQueryBack1 matchQueryVariable [] (getArcs qg) (getArcs tg) - -rdfQueryBack1 :: - NodeQuery RDFLabel -> [RDFVarBinding] -> [Arc RDFLabel] -> [Arc RDFLabel] - -> [[RDFVarBinding]] -rdfQueryBack1 _ initv _ [] = [initv] -rdfQueryBack1 nodeq initv qas (ta:tas) = concat - [ rdfQueryBack1 nodeq (nv:initv) qas tas - | nv <- rdfQueryBack2 nodeq qas ta ] - --- Match a query against a single graph term, and return any new sets of --- variable bindings thus defined. Each member of the result is an --- alternative possible set of variable bindings. An empty list returned --- means no match. --- -rdfQueryBack2 :: - NodeQuery RDFLabel -> [Arc RDFLabel] -> Arc RDFLabel - -> [RDFVarBinding] -rdfQueryBack2 nodeq qas ta = - [ fromJust b | qa <- qas, let b = getBinding nodeq qa ta, isJust b ] - --- |RDF back-chaining query filter. This function applies a supplied --- query binding filter to the result from a call of 'rdfQueryBack'. --- --- Each inner list contains bindings that must all be used to satisfy --- the backchain query, so if any query binding does not satisfy the --- filter, the entire corresponding row is removed -rdfQueryBackFilter :: - RDFVarBindingFilter -> [[RDFVarBinding]] -> [[RDFVarBinding]] -rdfQueryBackFilter qbf = filter (all (vbfTest qbf)) - --- |RDF back-chaining query modifier. This function applies a supplied --- query binding modifier to the result from a call of 'rdfQueryBack'. --- --- Each inner list contains bindings that must all be used to satisfy --- a backchaining query, so if any query binding does not satisfy the --- filter, the entire corresponding row is removed --- -rdfQueryBackModify :: - VarBindingModify a b -> [[VarBinding a b]] -> [[VarBinding a b]] -rdfQueryBackModify qbm = concatMap (rdfQueryBackModify1 qbm) - --- Auxiliary back-chaining query variable binding modifier function: --- for a supplied list of variable bindings, all of which must be used --- together when backchaining: --- (a) make each list member into a singleton list --- (b) apply the binding modifier to each such list, which may result --- in a list with zero, one or more elements. --- (c) return the listProduct of these, each member of which is --- an alternative list of variable bindings, where the members of --- each alternative must be used together. --- -rdfQueryBackModify1 :: - VarBindingModify a b -> [VarBinding a b] -> [[VarBinding a b]] -rdfQueryBackModify1 qbm qbs = listProduct $ map (vbmApply qbm . (:[])) qbs - ------------------------------------------------------------- --- Simple entailment graph query ------------------------------------------------------------- - --- |Simple entailment (instance) graph query. --- --- This function queries a graph to find instances of the --- query graph in the target graph. It is very similar --- to the normal forward chaining query 'rdfQueryFind', --- except that blank nodes rather than query variable nodes --- in the query graph are matched against nodes in the target --- graph. Neither graph should contain query variables. --- --- An instance is defined by the RDF semantics specification, --- per , and is obtained by replacing --- blank nodes with URIs, literals or other blank nodes. RDF --- simple entailment can be determined in terms of instances. --- This function looks for a subgraph of the target graph that --- is an instance of the query graph, which is a necessary and --- sufficient condition for RDF entailment (see the Interpolation --- Lemma in RDF Semantics, section 1.2). --- --- It is anticipated that this query function can be used in --- conjunction with backward chaining to determine when the --- search for sufficient antecendents to determine some goal --- has been concluded. -rdfQueryInstance :: RDFGraph -> RDFGraph -> [RDFVarBinding] -rdfQueryInstance = - rdfQueryPrim1 matchQueryBnode nullRDFVarBinding . getArcs - ------------------------------------------------------------- --- Primitive RDF graph query support functions ------------------------------------------------------------- - --- |Type of query node testing function. Return value is: --- --- * @Nothing@ if no match --- --- * @Just True@ if match with new variable binding --- --- * @Just False@ if match with new variable binding --- -type NodeQuery a = a -> a -> Maybe Bool - --- Extract query binding from matching a single query triple with a --- target triple, returning: --- - Nothing if the query is not matched --- - Just nullVarBinding if there are no new variable bindings --- - Just binding is a new query binding for this match -getBinding :: - NodeQuery RDFLabel -> Arc RDFLabel -> Arc RDFLabel - -> Maybe RDFVarBinding -getBinding nodeq (Arc s1 p1 o1) (Arc s2 p2 o2) = - makeBinding [(s1,s2),(p1,p2),(o1,o2)] [] - where - makeBinding [] bs = Just $ makeVarBinding bs - makeBinding (vr@(v,r):bvrs) bs = - case nodeq v r of - Nothing -> Nothing - Just False -> makeBinding bvrs bs - Just True -> makeBinding bvrs (vr:bs) - --- Match variable node against target node, returning --- Nothing if they do not match, Just True if a variable --- node is matched (thereby creating a new variable binding) --- or Just False if a non-blank node is matched. -matchQueryVariable :: NodeQuery RDFLabel -matchQueryVariable (Var _) _ = Just True -matchQueryVariable q t - | q == t = Just False - | otherwise = Nothing - --- Match blank query node against target node, returning --- Nothing if they do not match, Just True if a blank node --- is matched (thereby creating a new equivalence) or --- Just False if a non-blank node is matched. -matchQueryBnode :: NodeQuery RDFLabel -matchQueryBnode (Blank _) _ = Just True -matchQueryBnode q t - | q == t = Just False - | otherwise = Nothing - ------------------------------------------------------------- --- Substitute results from RDF query back into a graph ------------------------------------------------------------- - --- |Graph substitution function. --- --- Uses the supplied variable bindings to substitute variables in --- a supplied graph, returning a list of result graphs corresponding --- to each set of variable bindings applied to the input graph. --- This function is used for formward chaining substitutions, and --- returns only those result graphs for which all query variables --- are bound. -rdfQuerySubs :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] -rdfQuerySubs vars gr = - map fst $ filter (null . snd) $ rdfQuerySubsAll vars gr - --- |Graph back-substitution function. --- --- Uses the supplied variable bindings from 'rdfQueryBack' to perform --- a series of variable substitutions in a supplied graph, returning --- a list of lists of result graphs corresponding to each set of variable --- bindings applied to the input graphs. --- --- The outer list of the result contains alternative antecedent lists --- that satisfy the query goal. Each inner list contains graphs that --- must all be inferred to satisfy the query goal. -rdfQueryBackSubs :: - [[RDFVarBinding]] -> RDFGraph -> [[(RDFGraph,[RDFLabel])]] -rdfQueryBackSubs varss gr = [ rdfQuerySubsAll v gr | v <- varss ] - --- |Graph substitution function. --- --- This function performs the substitutions and returns a list of --- result graphs each paired with a list unbound variables in each. -rdfQuerySubsAll :: [RDFVarBinding] -> RDFGraph -> [(RDFGraph,[RDFLabel])] -rdfQuerySubsAll vars gr = [ rdfQuerySubs2 v gr | v <- vars ] - --- |Graph substitution function. --- --- This function performs each of the substitutions in 'vars', and --- replaces any nodes corresponding to unbound query variables --- with new blank nodes. -rdfQuerySubsBlank :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] -rdfQuerySubsBlank vars gr = - [ remapLabels vs bs makeBlank g - | v <- vars - , let (g,vs) = rdfQuerySubs2 v gr - , let bs = allLabels isBlank g - ] - --- |Graph back-substitution function, replacing variables with bnodes. --- --- Uses the supplied variable bindings from 'rdfQueryBack' to perform --- a series of variable substitutions in a supplied graph, returning --- a list of lists of result graphs corresponding to each set of variable --- bindings applied to the input graphs. --- --- The outer list of the result contains alternative antecedent lists --- that satisfy the query goal. Each inner list contains graphs that --- must all be inferred to satisfy the query goal. -rdfQueryBackSubsBlank :: [[RDFVarBinding]] -> RDFGraph -> [[RDFGraph]] -rdfQueryBackSubsBlank varss gr = [ rdfQuerySubsBlank v gr | v <- varss ] - --- This function applies a substitution for a single set of variable --- bindings, returning the result and a list of unbound variables. --- It uses a state transformer monad to collect the list of --- unbound variables. --- --- Adding an empty graph forces elimination of duplicate arcs. -rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph,[RDFLabel]) -rdfQuerySubs2 varb gr = (add emptyRDFGraph g,vs) - where - (g,vs) = runState ( Traversable.traverse (mapNode varb) gr ) [] - --- Auxiliary monad function for rdfQuerySubs2. --- This returns a state transformer Monad which in turn returns the --- substituted node value based on the supplied query variable bindings. --- The monad state is a list of labels which accumulates all those --- variables seen for which no substitution was available. -mapNode :: RDFVarBinding -> RDFLabel -> State [RDFLabel] RDFLabel -mapNode varb lab = - case vbMap varb lab of - Just v -> return v - Nothing -> - if isQueryVar lab then - do { modify (addVar lab) - ; return lab - } - else - return lab - --- Add variable to list of variables, if not already there -addVar :: RDFLabel -> [RDFLabel] -> [RDFLabel] -addVar var vars = if var `elem` vars then vars else var:vars - ------------------------------------------------------------- --- Simple lightweight query primitives ------------------------------------------------------------- --- --- [[[TODO: modify above code to use these for all graph queries]]] - --- |Take a predicate on an --- RDF statement and a graph, and returns all statements in the graph --- satisfying that predicate. --- --- Use combinations of these as follows: --- --- * find all statements with given subject: --- @rdfFindArcs (rdfSubjEq s)@ --- --- * find all statements with given property: --- @rdfFindArcs (rdfPredEq p)@ --- --- * find all statements with given object: --- @rdfFindArcs (rdfObjEq o)@ --- --- * find all statements matching conjunction of these conditions: --- @rdfFindArcs ('allp' [...])@ --- --- * find all statements matching disjunction of these conditions: --- @rdfFindArcs ('anyp' [...])@ --- --- Custom predicates can also be used. --- -rdfFindArcs :: (RDFTriple -> Bool) -> RDFGraph -> [RDFTriple] -rdfFindArcs p = filter p . getArcs - --- |Test if statement has given subject -rdfSubjEq :: RDFLabel -> RDFTriple -> Bool -rdfSubjEq s = (s==) . arcSubj - --- |Test if statement has given predicate -rdfPredEq :: RDFLabel -> RDFTriple -> Bool -rdfPredEq p = (p==) . arcPred - --- |Test if statement has given object -rdfObjEq :: RDFLabel -> RDFTriple -> Bool -rdfObjEq o = (o==) . arcObj - -{- --- |Find statements with given subject -rdfFindSubj :: RDFLabel -> RDFGraph -> [RDFTriple] -rdfFindSubj s = rdfFindArcs (rdfSubjEq s) - --- |Find statements with given predicate -rdfFindPred :: RDFLabel -> RDFGraph -> [RDFTriple] -rdfFindPred p = rdfFindArcs (rdfPredEq p) --} - --- |Find values of given predicate for a given subject -rdfFindPredVal :: - RDFLabel -- ^ subject - -> RDFLabel -- ^ predicate - -> RDFGraph - -> [RDFLabel] -rdfFindPredVal s p = map arcObj . rdfFindArcs (allp [rdfSubjEq s,rdfPredEq p]) - --- |Find integer values of a given predicate for a given subject -rdfFindPredInt :: - RDFLabel -- ^ subject - -> RDFLabel -- ^ predicate - -> RDFGraph -> [Integer] -rdfFindPredInt s p = mapMaybe getint . filter isint . pvs - where - pvs = rdfFindPredVal s p - isint = anyp - [ isDatatyped xsdInteger - , isDatatyped xsdNonNegInteger - ] - getint = mapL2V mapXsdInteger . getLiteralText - --- |Find all subjects that match (subject, predicate, object) in the graph. -rdfFindValSubj :: - RDFLabel -- ^ predicate - -> RDFLabel -- ^ object - -> RDFGraph - -> [RDFLabel] -rdfFindValSubj p o = map arcSubj . rdfFindArcs (allp [rdfPredEq p,rdfObjEq o]) - ------------------------------------------------------------- --- List query ------------------------------------------------------------- - --- |Return a list of nodes that comprise an rdf:collection value, --- given the head element of the collection. If the list is --- ill-formed then an arbitrary value is returned. --- -rdfFindList :: RDFGraph -> RDFLabel -> [RDFLabel] -rdfFindList gr hd = findhead $ rdfFindList gr findrest - where - findhead = headOr (const []) $ - map (:) (rdfFindPredVal hd resRdfFirst gr) - findrest = headOr resRdfNil (rdfFindPredVal hd resRdfRest gr) - {- - findhead = headOr (const []) - [ (ob:) | Arc _ sb ob <- subgr, sb == resRdfFirst ] - findrest = headOr resRdfNil - [ ob | Arc _ sb ob <- subgr, sb == resRdfRest ] - subgr = filter ((==) hd . arcSubj) $ getArcs gr - -} - headOr = foldr const - -- headOr _ (x:_) = x - -- headOr x [] = x - ------------------------------------------------------------- --- Interactive tests ------------------------------------------------------------- - -{- -s1 = Blank "s1" -p1 = Blank "p1" -o1 = Blank "o1" -s2 = Blank "s2" -p2 = Blank "p2" -o2 = Blank "o2" -qs1 = Var "s1" -qp1 = Var "p1" -qo1 = Var "o1" -qs2 = Var "s2" -qp2 = Var "p2" -qo2 = Var "o2" - -qa1 = Arc qs1 qp1 qo1 -qa2 = Arc qs2 qp2 qo2 -qa3 = Arc qs2 p2 qo2 -ta1 = Arc s1 p1 o1 -ta2 = Arc s2 p2 o2 - -g1 = toRDFGraph [ta1,ta2] -g2 = toRDFGraph [qa3] - -gb1 = getBinding matchQueryVariable qa1 ta1 -- ?s1=_:s1, ?p1=_:p1, ?o1=_:o1 -gvs1 = qbMap (fromJust gb1) qs1 -- _:s1 -gvp1 = qbMap (fromJust gb1) qp1 -- _:p1 -gvo1 = qbMap (fromJust gb1) qo1 -- _:o1 -gvs2 = qbMap (fromJust gb1) qs2 -- Nothing - -gb3 = getBinding matchQueryVariable qa3 ta1 -- Nothing -gb4 = getBinding matchQueryVariable qa3 ta2 -- ?s2=_:s1, ?o2=_:o1 - -mqvs1 = matchQueryVariable qs2 s1 -mqvp1 = matchQueryVariable p2 p1 - --- rdfQueryFind - -qfa = rdfQueryFind g2 g1 - -qp2a = rdfQueryPrim2 matchQueryVariable qa3 g1 --} - -{- more tests - -qb1a = rdfQueryBack1 [] [qa1] [ta1,ta2] -qb1 = rdfQueryBack1 [] [qa1,qa2] [ta1,ta2] -ql1 = length qb1 -qv1 = map (qb1!!0!!0) [qs1,qp1,qo1,qs2,qp2,qo2] -qv2 = map (qb1!!0!!1) [qs1,qp1,qo1,qs2,qp2,qo2] -qv3 = map (qb1!!1!!0) [qs1,qp1,qo1,qs2,qp2,qo2] -qv4 = map (qb1!!1!!1) [qs1,qp1,qo1,qs2,qp2,qo2] -qv5 = map (qb1!!2!!0) [qs1,qp1,qo1,qs2,qp2,qo2] -qv6 = map (qb1!!2!!1) [qs1,qp1,qo1,qs2,qp2,qo2] -qv7 = map (qb1!!3!!0) [qs1,qp1,qo1,qs2,qp2,qo2] -qv8 = map (qb1!!3!!1) [qs1,qp1,qo1,qs2,qp2,qo2] - -qb2 = rdfQueryBack2 matchQueryVariable [qa1,qa2] ta1 -ql2 = length qb2 -qv1 = map (qbMap $ head qb2) [qs1,qp1,qo1,qs2,qp2,qo2] -qv2 = map (qbMap $ head $ tail qb2) [qs1,qp1,qo1,qs2,qp2,qo2] -qb3 = rdfQueryBack2 matchQueryVariable [qa1,qa3] ta1 - --} - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFRuleset.hs b/src/Swish/RDF/RDFRuleset.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFRuleset.hs +++ /dev/null @@ -1,546 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFRuleset --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines some datatypes and functions that are --- used to define rules and rulesets over RDF graphs. --- --- For the routines that accept a graph in N3 format, the following --- namespaces are pre-defined for use by the graph: --- @rdf:@ and @rdfs:@. --- --------------------------------------------------------------------------------- - -module Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleMap - , RDFClosure, RDFRuleset, RDFRulesetMap - , nullRDFFormula - , GraphClosure(..), makeGraphClosureRule - , makeRDFGraphFromN3Builder - , makeRDFFormula - , makeRDFClosureRule - -- * Create rules using Notation3 statements - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeN3ClosureModifyRule - , makeN3ClosureAllocatorRule - , makeNodeAllocTo - -- * Debugging - , graphClosureFwdApply, graphClosureBwdApply - ) -where - -import Swish.RDF.RDFQuery - ( rdfQueryFind - , rdfQueryBack, rdfQueryBackModify - , rdfQuerySubs - , rdfQuerySubsBlank - ) - -import Swish.RDF.RDFGraph - ( RDFLabel(..), RDFGraph - , makeBlank, newNodes - , merge, allLabels - , toRDFGraph, emptyRDFGraph ) - -import Swish.RDF.RDFVarBinding (RDFVarBinding, RDFVarBindingModify) -import Swish.RDF.N3Parser (parseN3) -import Swish.RDF.Ruleset (Ruleset(..), RulesetMap) - -import Swish.RDF.Rule - ( Formula(..), Rule(..), RuleMap - , fwdCheckInference - , nullSN - ) - -import Swish.RDF.VarBinding - ( makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , vbmCompose - , varBindingId - ) - -import Swish.Utils.Namespace (Namespace, ScopedName, makeNSScopedName, namespaceToBuilder) -import Swish.RDF.Vocabulary (swishName, namespaceRDF, namespaceRDFS) - -{- -import Swish.RDF.Proof - ( Proof(..), Step(..) ) --} - -import Swish.RDF.GraphClass (Label(..), Arc(..), LDGraph(..)) -import Swish.Utils.ListHelpers (equiv, flist) - -import Data.List (nub) -import Data.Maybe (fromMaybe) -import Data.Monoid (Monoid(..)) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Datatypes for RDF ruleset ------------------------------------------------------------- - -type RDFFormula = Formula RDFGraph - -type RDFRule = Rule RDFGraph - -type RDFRuleMap = RuleMap RDFGraph - -type RDFClosure = GraphClosure RDFLabel - -type RDFRuleset = Ruleset RDFGraph - -type RDFRulesetMap = RulesetMap RDFGraph - ------------------------------------------------------------- --- Declare null RDF formula ------------------------------------------------------------- - --- | The null RDF formula. -nullRDFFormula :: Formula RDFGraph -nullRDFFormula = Formula - { formName = nullSN "nullRDFGraph" - , formExpr = emptyRDFGraph - } - ------------------------------------------------------------- --- Datatype for graph closure rule ------------------------------------------------------------- - --- |Datatype for constructing a graph closure rule -data GraphClosure lb = GraphClosure - { nameGraphRule :: ScopedName -- ^ Name of rule for proof display - , ruleAnt :: [Arc lb] -- ^ Antecedent triples pattern - -- (may include variable nodes) - , ruleCon :: [Arc lb] -- ^ Consequent triples pattern - -- (may include variable nodes) - , ruleModify :: VarBindingModify lb lb - -- ^ Structure that defines additional - -- constraints and/or variable - -- bindings based on other matched - -- query variables. Matching the - -- antecedents. Use 'varBindingId' if - -- no additional variable constraints - -- or bindings are added beyond those - -- arising from graph queries. - } - -instance (Label lb) => Eq (GraphClosure lb) where - c1 == c2 = nameGraphRule c1 == nameGraphRule c2 && - ruleAnt c1 `equiv` ruleAnt c2 && - ruleCon c1 `equiv` ruleCon c2 - -instance (Label lb) => Show (GraphClosure lb) where - show c = "GraphClosure " ++ show (nameGraphRule c) - ------------------------------------------------------------- --- Define inference rule based on RDF graph closure rule ------------------------------------------------------------- - --- |Define a value of type Rule based on an RDFClosure value. -makeGraphClosureRule :: GraphClosure RDFLabel -> Rule RDFGraph -makeGraphClosureRule grc = newrule - where - newrule = Rule - { ruleName = nameGraphRule grc - , fwdApply = graphClosureFwdApply grc - , bwdApply = graphClosureBwdApply grc - , checkInference = fwdCheckInference newrule - } - --- | Forward chaining function based on RDF graph closure description --- --- Note: antecedents here are presumed to share bnodes. --- -graphClosureFwdApply :: - GraphClosure RDFLabel - -> [RDFGraph] - -> [RDFGraph] -graphClosureFwdApply grc grs = - let gr = if null grs then emptyRDFGraph else foldl1 add grs - vars = queryFind (ruleAnt grc) gr - varm = vbmApply (ruleModify grc) vars - cons = querySubs varm (ruleCon grc) - in - {- - seq cons $ - seq (trace "\ngraphClosureFwdApply") $ - seq (traceShow "\nvars: " vars) $ - seq (traceShow "\nvarm: " varm) $ - seq (traceShow "\ncons: " cons) $ - seq (trace "\n") $ - -} - -- Return null list or single result graph that is the union - -- (not merge) of individual results: - if null cons then [] else [foldl1 add cons] - -- cons {- don't merge results -} - --- | Backward chaining function based on RDF graph closure description -graphClosureBwdApply :: GraphClosure RDFLabel -> RDFGraph -> [[RDFGraph]] -graphClosureBwdApply grc gr = - let vars = rdfQueryBackModify (ruleModify grc) $ - queryBack (ruleCon grc) gr - -- This next function eliminates duplicate variable bindings. - -- It is strictly redundant, but comparing variable - -- bindings is much cheaper than comparing graphs. - -- I don't know if many duplicate graphs will be result - -- of exact duplicate variable bindings, so this may be - -- not very effective. - varn = map nub vars - in - -- The 'nub ante' below eliminates duplicate antecedent graphs, - -- based on graph matching, which tests for equivalence under - -- bnode renaming, with a view to reducing redundant arcs in - -- the merged antecedent graph, hence less to prove in - -- subsequent back-chaining steps. - -- - -- Each antecedent is reduced to a single RDF graph, when - -- bwdApply specifies a list of expressions corresponding to - -- each antecedent. - [ [foldl1 merge (nub ante)] - | vs <- varn - , let ante = querySubsBlank vs (ruleAnt grc) ] - ------------------------------------------------------------- --- RDF graph query and substitution support functions ------------------------------------------------------------- - -queryFind :: [Arc RDFLabel] -> RDFGraph -> [RDFVarBinding] -queryFind qas = rdfQueryFind (toRDFGraph qas) - -queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] -queryBack qas = rdfQueryBack (toRDFGraph qas) - -querySubs :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] -querySubs vars = rdfQuerySubs vars . toRDFGraph - -querySubsBlank :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] -querySubsBlank vars = rdfQuerySubsBlank vars . toRDFGraph - ------------------------------------------------------------- --- Method for creating an RDF formula value from N3 text ------------------------------------------------------------- - -mkPrefix :: Namespace -> B.Builder -mkPrefix = namespaceToBuilder - -prefixRDF :: B.Builder -prefixRDF = - mconcat - [ mkPrefix namespaceRDF - , mkPrefix namespaceRDFS - ] - --- |Helper function to parse a string containing Notation3 --- and return the corresponding RDFGraph value. --- -makeRDFGraphFromN3Builder :: B.Builder -> RDFGraph -makeRDFGraphFromN3Builder b = - let t = B.toLazyText (prefixRDF `mappend` b) - in case parseN3 t Nothing of - Left msg -> error msg - Right gr -> gr - --- |Create an RDF formula. -makeRDFFormula :: - Namespace -- ^ namespace to which the formula is allocated - -> T.Text -- ^ local name for the formula in the namespace - -> B.Builder -- ^ graph in Notation 3 format - -> RDFFormula -makeRDFFormula scope local gr = - Formula - { formName = makeNSScopedName scope local - , formExpr = makeRDFGraphFromN3Builder gr - } - ------------------------------------------------------------- --- Create an RDF closure rule from supplied graphs ------------------------------------------------------------- - --- |Constructs an RDF graph closure rule. That is, a rule that --- given some set of antecedent statements returns new statements --- that may be added to the graph. --- -makeRDFClosureRule :: - ScopedName -- ^ scoped name for the new rule - -> [RDFGraph] -- ^ RDFGraphs that are the entecedent of the rule. - -- - -- (Note: bnodes and variable names are assumed to be shared - -- by all the entecedent graphs supplied. /is this right?/) - -> RDFGraph -- ^ the consequent graph - -> RDFVarBindingModify -- ^ is a variable binding modifier value that may impose - -- additional conditions on the variable bindings that - -- can be used for this inference rule, or which may - -- cause new values to be allocated for unbound variables. - -- These modifiers allow for certain inference patterns - -- that are not captured by simple "closure rules", such - -- as the allocation of bnodes corresponding to literals, - -- and are an extension point for incorporating datatypes - -- into an inference process. - -- - -- If no additional constraints or variable bindings are - -- to be applied, use value 'varBindingId' - -- - -> RDFRule -makeRDFClosureRule sname antgrs congr vmod = makeGraphClosureRule - GraphClosure - { nameGraphRule = sname - , ruleAnt = concatMap getArcs antgrs - , ruleCon = getArcs congr - , ruleModify = vmod - } - ------------------------------------------------------------- --- Methods to create an RDF closure rule from N3 input ------------------------------------------------------------- --- --- These functions are used internally by Swish to construct --- rules from textual descriptions. - --- |Constructs an RDF graph closure rule. That is, a rule that --- given some set of antecedent statements returns new statements --- that may be added to the graph. This is the basis for --- implementation of most of the inference rules given in the --- RDF formal semantics document. --- -makeN3ClosureRule :: - Namespace -- ^ namespace to which the rule is allocated - -> T.Text -- ^ local name for the rule in the namespace - -> B.Builder - -- ^ the Notation3 representation - -- of the antecedent graph. (Note: multiple antecedents - -- can be handled by combining multiple graphs.) - -> B.Builder -- ^ the Notation3 representation of the consequent graph. - -> RDFVarBindingModify - -- ^ a variable binding modifier value that may impose - -- additional conditions on the variable bindings that - -- can be used for this inference rule, or which may - -- cause new values to be allocated for unbound variables. - -- These modifiers allow for certain inference patterns - -- that are not captured by simple closure rules, such - -- as the allocation of bnodes corresponding to literals, - -- and are an extension point for incorporating datatypes - -- into an inference process. - -- - -- If no additional constraints or variable bindings are - -- to be applied, use a value of 'varBindingId', or use - -- 'makeN3ClosureSimpleRule'. - -> RDFRule -makeN3ClosureRule scope local ant con = - makeRDFClosureRule (makeNSScopedName scope local) [antgr] congr - where - antgr = makeRDFGraphFromN3Builder ant - congr = makeRDFGraphFromN3Builder con - --- |Construct a simple RDF graph closure rule without --- additional node allocations or variable binding constraints. --- -makeN3ClosureSimpleRule :: - Namespace -- ^ namespace to which the rule is allocated - -> T.Text -- ^ local name for the rule in the namepace - -> B.Builder - -- ^ the Notation3 representation - -- of the antecedent graph. (Note: multiple antecedents - -- can be handled by combining multiple graphs.) - -> B.Builder -- ^ the Notation3 representation of the consequent graph. - -> RDFRule -makeN3ClosureSimpleRule scope local ant con = - makeN3ClosureRule scope local ant con varBindingId - --- |Constructs an RDF graph closure rule that incorporates --- a variable binding filter and a variable binding modifier. --- -makeN3ClosureModifyRule :: - Namespace -- ^ namespace to which the rule is allocated - -> T.Text -- ^ local name for the rule in the given namespace - -> B.Builder -- ^ the Notation3 representation - -- of the antecedent graph. (Note: multiple antecedents - -- can be handled by combining multiple graphs.) - -> B.Builder -- ^ the Notation3 representation of the consequent graph. - -> RDFVarBindingModify - -- ^ a variable binding modifier value that may impose - -- additional conditions on the variable bindings that - -- can be used for this inference rule (@vflt@). - -- - -- These modifiers allow for certain inference patterns - -- that are not captured by simple closure rules, such - -- as deductions that pertain only to certain kinds of - -- nodes in a graph. - -> RDFVarBindingModify - -- ^ a variable binding modifier that is applied to the - -- variable bindings obtained, typically to create some - -- additional variable bindings. This is applied before - -- the preceeding filter rule (@vflt@). - -> RDFRule -makeN3ClosureModifyRule scope local ant con vflt vmod = - makeN3ClosureRule scope local ant con modc - where - modc = fromMaybe varBindingId $ vbmCompose vmod vflt - -{- - makeRDFClosureRule (ScopedName scope local) [antgr] congr modc - where - antgr = makeRDFGraphFromN3String ant - congr = makeRDFGraphFromN3String con - modc = case vbmCompose vmod vflt of - Just x -> x - Nothing -> varBindingId --} - --- |Construct an RDF graph closure rule with a bnode allocator. --- --- This function is rather like 'makeN3ClosureModifyRule', except that --- the variable binding modifier is a function from the variables in --- the variables and bnodes contained in the antecedent graph. --- -makeN3ClosureAllocatorRule :: - Namespace -- ^ namespace to which the rule is allocated - -> T.Text -- ^ local name for the rule in the given namespace - -> B.Builder -- ^ the Notation3 representation - -- of the antecedent graph. (Note: multiple antecedents - -- can be handled by combining multiple graphs.) - -> B.Builder -- ^ the Notation3 representation of the consequent graph. - -> RDFVarBindingModify - -- ^ variable binding modifier value that may impose - -- additional conditions on the variable bindings that - -- can be used for this inference rule (@vflt@). - -> ( [RDFLabel] -> RDFVarBindingModify ) - -- ^ function applied to a list of nodes to yield a - -- variable binding modifier value. - -- - -- The supplied parameter is applied to a list of all of - -- the variable nodes (including all blank nodes) in the - -- antecedent graph, and then composed with the @vflt@ - -- value. This allows any node allocation - -- function to avoid allocating any blank nodes that - -- are already used in the antecedent graph. - -- (See 'makeNodeAllocTo'). - -> RDFRule -makeN3ClosureAllocatorRule scope local ant con vflt aloc = - makeRDFClosureRule (makeNSScopedName scope local) [antgr] congr modc - where - antgr = makeRDFGraphFromN3Builder ant - congr = makeRDFGraphFromN3Builder con - vmod = aloc (allLabels labelIsVar antgr) - modc = fromMaybe varBindingId $ vbmCompose vmod vflt - ------------------------------------------------------------- --- Query binding modifier for "allocated to" logic ------------------------------------------------------------- - --- |This function defines a variable binding modifier that --- allocates a new blank node for each value bound to --- a query variable, and binds it to another variable --- in each query binding. --- --- This provides a single binding for query variables that would --- otherwise be unbound by a query. For example, consider the --- inference pattern: --- --- > ?a hasUncle ?c => ?a hasFather ?b . ?b hasBrother ?c . --- --- For a given @?a@ and @?c@, there is insufficient information --- here to instantiate a value for variable @?b@. Using this --- function as part of a graph instance closure rule allows --- forward chaining to allocate a single bnode for each --- occurrence of @?a@, so that given: --- --- > Jimmy hasUncle Fred . --- > Jimmy hasUncle Bob . --- --- leads to exactly one bnode inference of: --- --- > Jimmy hasFather _:f . --- --- giving: --- --- > Jimmy hasFather _:f . --- > _:f hasBrother Fred . --- > _:f hasBrother Bob . --- --- rather than: --- --- > Jimmy hasFather _:f1 . --- > _:f1 hasBrother Fred . --- > Jimmy hasFather _:f2 . --- > _:f2 hasBrother Bob . --- --- This form of constrained allocation of bnodes is also required for --- some of the inference patterns described by the RDF formal semantics, --- particularly those where bnodes are substituted for URIs or literals. --- -makeNodeAllocTo :: - RDFLabel -- ^ variable node to which a new blank node is bound - -> RDFLabel -- ^ variable which is bound in each query to a graph - -- node to which new blank nodes are allocated. - -> [RDFLabel] - -> RDFVarBindingModify -makeNodeAllocTo bindvar alocvar exbnode = VarBindingModify - { vbmName = swishName "makeNodeAllocTo" - , vbmApply = applyNodeAllocTo bindvar alocvar exbnode - , vbmVocab = [alocvar,bindvar] - , vbmUsage = [[bindvar]] - } - --- Auxiliary function that performs the node allocation defined --- by makeNodeAllocTo. --- --- bindvar is a variable node to which a new blank node is bound --- alocvar is a variable which is bound in each query to a graph --- node to which new blank nodes are allocated. --- exbnode is a list of existing blank nodes, to be avoided by --- the new blank node allocator. --- vars is a list of variable bindings to which new bnode --- allocations for the indicated bindvar are to be added. --- -applyNodeAllocTo :: - RDFLabel -> RDFLabel -> [RDFLabel] -> [RDFVarBinding] -> [RDFVarBinding] -applyNodeAllocTo bindvar alocvar exbnode vars = - let - app = applyVarBinding - alocnodes = zip (nub $ flist (map app vars) alocvar) - (newNodes (makeBlank bindvar) exbnode) - newvb var = joinVarBindings - ( makeVarBinding $ head - [ [(bindvar,b)] | (v,b) <- alocnodes, app var alocvar == v ] ) - var - in - map newvb vars - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/RDFVarBinding.hs b/src/Swish/RDF/RDFVarBinding.hs deleted file mode 100644 --- a/src/Swish/RDF/RDFVarBinding.hs +++ /dev/null @@ -1,187 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFVarBinding --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module instantiates the `VarBinding` types and methods for use --- with RDF graph labels. --- --------------------------------------------------------------------------------- - --- See module RDFQueryTest for test cases. - -module Swish.RDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingModify, RDFOpenVarBindingModify, RDFOpenVarBindingModifyMap - , RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) -where - -import Swish.RDF.RDFGraph - ( RDFLabel(..) - , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral - , isDatatyped, isMemberProp, isUri, isBlank - ) - -import Swish.RDF.VarBinding - ( VarBinding(..), nullVarBinding - , applyVarBinding - , VarBindingModify(..), OpenVarBindingModify - , VarBindingFilter(..) - , makeVarTestFilter - ) - -import Swish.RDF.Vocabulary - ( swishName ) - -import Swish.Utils.LookupMap - ( LookupMap(..) ) - ------------------------------------------------------------- --- Types for RDF query variable bindings and modifiers ------------------------------------------------------------- - --- |@RDFVarBinding@ is the specific type type of a variable --- binding value used with RDF graph queries. -type RDFVarBinding = VarBinding RDFLabel RDFLabel - --- | maps no query variables. -nullRDFVarBinding :: RDFVarBinding -nullRDFVarBinding = nullVarBinding - --- |Define type of query binding modifier for RDF graph inference -type RDFVarBindingModify = VarBindingModify RDFLabel RDFLabel - --- |Open variable binding modifier that operates on RDFLabel values --- -type RDFOpenVarBindingModify = OpenVarBindingModify RDFLabel RDFLabel - --- |Define type for lookup map of open query binding modifiers -type RDFOpenVarBindingModifyMap = LookupMap RDFOpenVarBindingModify - --- |@RDFVarBindingFilter@ is a function type that tests to see if --- a query binding satisfies some criterion, and is used to --- create a variable binding modifier that simply filers --- given variable bindings. --- --- Queries often want to apply some kind of filter or condition --- to the variable bindings that are processed. In inference rules, --- it sometimes seems desirable to stipulate additional conditions on --- the things that are matched. --- --- This function type is used to perform such tests. --- A number of simple implementations are included. --- -type RDFVarBindingFilter = VarBindingFilter RDFLabel RDFLabel - ------------------------------------------------------------- --- Declare some query binding filters ------------------------------------------------------------- - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to a URI reference. -rdfVarBindingUriRef :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingUriRef = - makeVarTestFilter (swishName "rdfVarBindingUriRef") isUri - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to a blank node. -rdfVarBindingBlank :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingBlank = - makeVarTestFilter (swishName "rdfVarBindingBlank") isBlank - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to a literal value. -rdfVarBindingLiteral :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingLiteral = - makeVarTestFilter (swishName "rdfVarBindingLiteral") isLiteral - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to an untyped literal value. -rdfVarBindingUntypedLiteral :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingUntypedLiteral = - makeVarTestFilter (swishName "rdfVarBindingUntypedLiteral") isUntypedLiteral - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to a typed literal value. -rdfVarBindingTypedLiteral :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingTypedLiteral = - makeVarTestFilter (swishName "rdfVarBindingTypedLiteral") isTypedLiteral - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to an XML literal value. -rdfVarBindingXMLLiteral :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingXMLLiteral = - makeVarTestFilter (swishName "rdfVarBindingXMLLiteral") isXMLLiteral - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to container membership property. -rdfVarBindingMemberProp :: RDFLabel -> RDFVarBindingFilter -rdfVarBindingMemberProp = - makeVarTestFilter (swishName "rdfVarBindingMemberProp") isMemberProp - --- |This function generates a query binding filter that ensures --- an indicated variable is bound to a literal value with a --- datatype whose URI is bound to another node --- -rdfVarBindingDatatyped :: - RDFLabel -- ^ variable bound to the required datatype. - -> RDFLabel -- ^ variable bound to the literal node to be tested. - -> RDFVarBindingFilter -rdfVarBindingDatatyped dvar lvar = VarBindingFilter - { vbfName = swishName "rdfVarBindingDatatyped" - , vbfVocab = [dvar,lvar] - , vbfTest = \vb -> testDatatyped vb dvar lvar - } - -testDatatyped :: RDFVarBinding -> RDFLabel -> RDFLabel -> Bool -testDatatyped vb dvar lvar = and - [ isUri dtype - , isDatatyped dqnam $ applyVarBinding vb lvar - ] - where - dtype = applyVarBinding vb dvar - -- NOTE: dqnam is not evaluated unless (isUri dtype) - -- but add in a _ handler to appease -Wall - -- dqnam = case dtype of { (Res x) -> x } - dqnam = case dtype of - Res x -> x - _ -> error $ "dqnam should not be evaluated with " ++ show dtype - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Rule.hs b/src/Swish/RDF/Rule.hs deleted file mode 100644 --- a/src/Swish/RDF/Rule.hs +++ /dev/null @@ -1,247 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Rule --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : MultiParamTypeClasses, OverloadedStrings --- --- This module defines a framework for defining inference rules --- over some expression form. It is intended to be used with --- RDF graphs, but the structures aim to be quite generic with --- respect to the expression forms allowed. --- --------------------------------------------------------------------------------- - -module Swish.RDF.Rule - ( Expression(..), Formula(..), Rule(..), RuleMap - , nullScope, nullSN, nullFormula, nullRule - , fwdCheckInference, bwdCheckInference - , showsFormula, showsFormulae, showsWidth - ) - where - -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeScopedName, makeNSScopedName) -import Swish.Utils.LookupMap (LookupEntryClass(..), LookupMap(..)) -import Swish.Utils.ShowM (ShowM(..)) - -import Network.URI (URI, parseURI) -import Data.Maybe (fromJust) - -import qualified Data.Text as T - ------------------------------------------------------------- --- Expressions ------------------------------------------------------------- - --- |Expression is a type class for values over which proofs --- may be constructed. -class (Eq ex) => Expression ex where - -- |Is expression true in all interpretations? - -- If so, then its truth is assumed without justification. - isValid :: ex -> Bool - ------------------------------------------------------------- --- Formula: a named expression ------------------------------------------------------------- - --- |A Formula is a named expression. -data Formula ex = Formula - { formName :: ScopedName -- ^ Name used for formula in proof chain - , formExpr :: ex -- ^ Named formula value - } deriving Show - --- |Define equality of formulae as equality of formula names -instance Eq (Formula ex) where - f1 == f2 = formName f1 == formName f2 - --- |Define ordering of formulae based on formula names -instance Ord (Formula ex) where - f1 <= f2 = formName f1 <= formName f2 - -instance LookupEntryClass (Formula ex) ScopedName (Formula ex) - where - newEntry (_,form) = form - keyVal form = (formName form, form) - --- | The namespace @http:\/\/id.ninebynine.org\/2003\/Ruleset\/null@ with the prefix @null:@. -nullScope :: Namespace -nullScope = makeNamespace (Just "null") nullScopeURI - --- | Create a scoped name with the null namespace. -nullSN :: - T.Text -- ^ local name. - -> ScopedName -nullSN = makeNSScopedName nullScope - -tU :: String -> URI -tU = fromJust . parseURI - -nullScopeURI :: URI -nullScopeURI = tU "http://id.ninebynine.org/2003/Ruleset/null" - --- | The null formula. -nullFormula :: Formula ex -nullFormula = Formula - { formName = makeScopedName (Just "null") nullScopeURI "nullFormula" - , formExpr = error "Null formula" - } - --- testf1 = Formula "f1" ('f',1) --- testf2 = Formula "f2" ('f',2) - --- |Return a displayable form of a list of labelled formulae -showsFormulae :: - (ShowM ex) - => String -- ^ newline - -> [Formula ex] -- ^ the formulae to show - -> String -- ^ text to be placed after the formulae - -> ShowS -showsFormulae _ [] _ = id -showsFormulae newline [f] after = showsFormula newline f . - showString after -showsFormulae newline (f:fs) after = showsFormula newline f . - showString newline . - showsFormulae newline fs after - --- |Create a displayable form of a labelled formula -showsFormula :: - (ShowM ex) - => String -- ^ newline - -> Formula ex -- ^ formula - -> ShowS -showsFormula newline f = - showsWidth 16 ("["++show (formName f)++"] ") . - showms (newline ++ replicate 16 ' ') (formExpr f) - ------------------------------------------------------------- --- Rule ------------------------------------------------------------- - --- |Rule is a data type for inference rules that can be used --- to construct a step in a proof. -data Rule ex = Rule - { - -- |Name of rule, for use when displaying a proof - ruleName :: ScopedName, - - -- |Forward application of a rule, takes a list of - -- expressions and returns a list (possibly empty) - -- of forward applications of the rule to combinations - -- of the antecedent expressions. - -- Note that all of the results returned can be assumed to - -- be (simultaneously) true, given the antecedents provided. - fwdApply :: [ex] -> [ex], - - -- |Backward application of a rule, takes an expression - -- and returns a list of alternative antecedents, each of - -- which is a list of expressions that jointly yield the - -- given consequence through application of the inference - -- rule. An empty list is returned if no antecedents - -- will allow the consequence to be inferred. - bwdApply :: ex -> [[ex]], - - -- |Inference check. Takes a list of antecedent expressions - -- and a consequent expression, returning True if the - -- consequence can be obtained from the antecedents by - -- application of the rule. When the antecedents and - -- consequent are both given, this is generally more efficient - -- that using either forward or backward chaining. - -- Also, a particular rule may not fully support either - -- forward or backward chaining, but all rules are required - -- to fully support this function. - -- - -- A default implementation based on forward chaining is - -- given below. - checkInference :: [ex] -> ex -> Bool - } - --- |Define equality of rules as equality of the rule names. -instance Eq (Rule ex) where - r1 == r2 = ruleName r1 == ruleName r2 - --- |Define ordering of rules based on the rule names. -instance Ord (Rule ex) where - r1 <= r2 = ruleName r1 <= ruleName r2 - -instance Show (Rule ex) where - show rl = "Rule "++show (ruleName rl) - -instance LookupEntryClass (Rule ex) ScopedName (Rule ex) - where - newEntry (_,rule) = rule - keyVal rule = (ruleName rule, rule) - -type RuleMap ex = LookupMap (Rule ex) - --- | Checks that consequence is a result of --- applying the rule to the antecedants. -fwdCheckInference :: - (Eq ex) - => Rule ex -- ^ rule - -> [ex] -- ^ antecedants - -> ex -- ^ consequence - -> Bool -fwdCheckInference rule ante cons = - cons `elem` fwdApply rule ante - -bwdCheckInference :: - (Eq ex) - => Rule ex -- ^ rule - -> [ex] -- ^ antecedants - -> ex -- ^ consequence - -> Bool -bwdCheckInference rule ante cons = any checkAnts (bwdApply rule cons) - where - checkAnts = all (`elem` ante) - --- | The null rule. -nullRule :: Rule ex -nullRule = Rule - { ruleName = makeScopedName (Just "null") nullScopeURI "nullRule" - , fwdApply = \ _ -> [] - , bwdApply = \ _ -> [] - , checkInference = \ _ _ -> False - } - ------------------------------------------------------------- --- Shows formatting support functions ------------------------------------------------------------ - --- |Show a string left justified in a field of at least the specified --- number of characters width. -showsWidth :: Int -> String -> ShowS -showsWidth wid str more = str++replicate pad ' '++more - where - pad = wid - length str - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Ruleset.hs b/src/Swish/RDF/Ruleset.hs --- a/src/Swish/RDF/Ruleset.hs +++ b/src/Swish/RDF/Ruleset.hs @@ -1,158 +1,525 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Ruleset --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : MultiParamTypeClasses +-- Portability : OverloadedStrings -- --- This module defines a ruleset data type, used to collect information --- about a ruleset that may contribute torwards inferences in RDF; --- e.g. RDF and RDFS are rulesets. +-- This module defines some datatypes and functions that are +-- used to define rules and rulesets over RDF graphs. -- --- A ruleset consists of a namespace, a collection of axioms, and --- a collection of rules. +-- For the routines that accept a graph in N3 format, the following +-- namespaces are pre-defined for use by the graph: +-- @rdf:@ and @rdfs:@. -- -------------------------------------------------------------------------------- module Swish.RDF.Ruleset - ( Ruleset(..), RulesetMap - , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules - , getRulesetAxiom, getRulesetRule - , getContextAxiom, getMaybeContextAxiom - , getContextRule, getMaybeContextRule + ( + -- * Data types for RDF Ruleset + RDFFormula, RDFRule, RDFRuleMap + , RDFClosure, RDFRuleset, RDFRulesetMap + , nullRDFFormula + , GraphClosure(..), makeGraphClosureRule + , makeRDFGraphFromN3Builder + , makeRDFFormula + , makeRDFClosureRule + -- * Create rules using Notation3 statements + , makeN3ClosureRule + , makeN3ClosureSimpleRule + , makeN3ClosureModifyRule + , makeN3ClosureAllocatorRule + , makeNodeAllocTo + -- * Debugging + , graphClosureFwdApply, graphClosureBwdApply ) where -import Swish.Utils.Namespace (Namespace, ScopedName) -import Swish.RDF.Rule (Formula(..), Rule(..)) +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (makeNSScopedName, namespaceToBuilder) +import Swish.QName (LName) +import Swish.Rule (Formula(..), Rule(..), RuleMap) +import Swish.Rule (fwdCheckInference, nullSN) +import Swish.Ruleset (Ruleset(..), RulesetMap) +import Swish.GraphClass (Label(..), Arc(..), LDGraph(..)) +import Swish.VarBinding (VarBindingModify(..)) +import Swish.VarBinding (makeVarBinding, applyVarBinding, joinVarBindings, vbmCompose, varBindingId) -import Swish.Utils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFindMaybe +import Swish.RDF.Query + ( rdfQueryFind + , rdfQueryBack, rdfQueryBackModify + , rdfQuerySubs + , rdfQuerySubsBlank ) -{- -Used for the Show instance of Ruleset, which was -used for debugging but has been removed as not -really needed by the general user. +import Swish.RDF.Graph + ( RDFLabel(..), RDFGraph + , makeBlank, newNodes + , merge, allLabels + , toRDFGraph) -import Swish.Utils.ShowM (ShowM(..)) -import Data.List (intercalate) --} +import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingModify) +import Swish.RDF.Parser.N3 (parseN3) -import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import Swish.RDF.Vocabulary (swishName, namespaceRDF, namespaceRDFS) --- | A Rule set. +import Swish.Utils.ListHelpers (equiv, flist) -data Ruleset ex = Ruleset - { rsNamespace :: Namespace -- ^ Namespace. - , rsAxioms :: [Formula ex] -- ^ Axioms. - , rsRules :: [Rule ex] -- ^ Rules. +import Data.List (nub) +import Data.Maybe (fromMaybe) +import Data.Monoid (Monoid(..)) + +import qualified Data.Text.Lazy.Builder as B + +------------------------------------------------------------ +-- Datatypes for RDF ruleset +------------------------------------------------------------ + +-- | A named formula expressed as a RDF Graph. +type RDFFormula = Formula RDFGraph + +-- | A named inference rule expressed in RDF. +type RDFRule = Rule RDFGraph + +-- | A 'LookupMap' for 'RDFRule' rules. +type RDFRuleMap = RuleMap RDFGraph + +-- | A 'GraphClosure' for RDF statements. +type RDFClosure = GraphClosure RDFLabel + +-- | A 'Ruleset' for RDF. +type RDFRuleset = Ruleset RDFGraph + +-- | 'LookupMap' for 'RDFRuleset'. +type RDFRulesetMap = RulesetMap RDFGraph + +------------------------------------------------------------ +-- Declare null RDF formula +------------------------------------------------------------ + +-- | The null RDF formula. +nullRDFFormula :: Formula RDFGraph +nullRDFFormula = Formula + { formName = nullSN "nullRDFGraph" + , formExpr = mempty } -{- +------------------------------------------------------------ +-- Datatype for graph closure rule +------------------------------------------------------------ -Used for debugging. +-- |Datatype for constructing a graph closure rule +data GraphClosure lb = GraphClosure + { nameGraphRule :: ScopedName -- ^ Name of rule for proof display + , ruleAnt :: [Arc lb] -- ^ Antecedent triples pattern + -- (may include variable nodes) + , ruleCon :: [Arc lb] -- ^ Consequent triples pattern + -- (may include variable nodes) + , ruleModify :: VarBindingModify lb lb + -- ^ Structure that defines additional + -- constraints and/or variable + -- bindings based on other matched + -- query variables. Matching the + -- antecedents. Use 'varBindingId' if + -- no additional variable constraints + -- or bindings are added beyond those + -- arising from graph queries. + } -instance (ShowM ex) => Show (Ruleset ex) where - show (Ruleset ns axs rls) = - intercalate "\n" - [ "Ruleset: " ++ show ns - , "Axioms:" ] - ++ (showsFormulae "\n" axs - (intercalate "\n" ("Rules:" : map show rls))) "" --} +instance (Label lb) => Eq (GraphClosure lb) where + c1 == c2 = nameGraphRule c1 == nameGraphRule c2 && + ruleAnt c1 `equiv` ruleAnt c2 && + ruleCon c1 `equiv` ruleCon c2 --- | Ruleset comparisons are based only on their namespace components. -instance Eq (Ruleset ex) where - r1 == r2 = rsNamespace r1 == rsNamespace r2 +instance (Label lb) => Show (GraphClosure lb) where + show c = "GraphClosure " ++ show (nameGraphRule c) -instance LookupEntryClass (Ruleset ex) Namespace (Ruleset ex) +------------------------------------------------------------ +-- Define inference rule based on RDF graph closure rule +------------------------------------------------------------ + +-- |Define a value of type Rule based on an RDFClosure value. +makeGraphClosureRule :: GraphClosure RDFLabel -> Rule RDFGraph +makeGraphClosureRule grc = newrule where - keyVal r@(Ruleset k _ _) = (k,r) - newEntry (_,r) = r + newrule = Rule + { ruleName = nameGraphRule grc + , fwdApply = graphClosureFwdApply grc + , bwdApply = graphClosureBwdApply grc + , checkInference = fwdCheckInference newrule + } -type RulesetMap ex = LookupMap (Ruleset ex) +-- | Forward chaining function based on RDF graph closure description +-- +-- Note: antecedents here are presumed to share bnodes. +-- +graphClosureFwdApply :: + GraphClosure RDFLabel + -> [RDFGraph] + -> [RDFGraph] +graphClosureFwdApply grc grs = + let gr = if null grs then mempty else foldl1 addGraphs grs + vars = queryFind (ruleAnt grc) gr + varm = vbmApply (ruleModify grc) vars + cons = querySubs varm (ruleCon grc) + in + {- + seq cons $ + seq (trace "\ngraphClosureFwdApply") $ + seq (traceShow "\nvars: " vars) $ + seq (traceShow "\nvarm: " varm) $ + seq (traceShow "\ncons: " cons) $ + seq (trace "\n") $ + -} + -- Return null list or single result graph that is the union + -- (not merge) of individual results: + if null cons then [] else [foldl1 addGraphs cons] + -- cons {- don't merge results -} --- | Create a ruleset. -makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex -makeRuleset nsp fms rls = Ruleset - { rsNamespace = nsp - , rsAxioms = fms - , rsRules = rls +-- | Backward chaining function based on RDF graph closure description +graphClosureBwdApply :: GraphClosure RDFLabel -> RDFGraph -> [[RDFGraph]] +graphClosureBwdApply grc gr = + let vars = rdfQueryBackModify (ruleModify grc) $ + queryBack (ruleCon grc) gr + -- This next function eliminates duplicate variable bindings. + -- It is strictly redundant, but comparing variable + -- bindings is much cheaper than comparing graphs. + -- I don't know if many duplicate graphs will be result + -- of exact duplicate variable bindings, so this may be + -- not very effective. + varn = map nub vars + in + -- The 'nub ante' below eliminates duplicate antecedent graphs, + -- based on graph matching, which tests for equivalence under + -- bnode renaming, with a view to reducing redundant arcs in + -- the merged antecedent graph, hence less to prove in + -- subsequent back-chaining steps. + -- + -- Each antecedent is reduced to a single RDF graph, when + -- bwdApply specifies a list of expressions corresponding to + -- each antecedent. + [ [foldl1 merge (nub ante)] + | vs <- varn + , let ante = querySubsBlank vs (ruleAnt grc) ] + +------------------------------------------------------------ +-- RDF graph query and substitution support functions +------------------------------------------------------------ + +queryFind :: [Arc RDFLabel] -> RDFGraph -> [RDFVarBinding] +queryFind qas = rdfQueryFind (toRDFGraph qas) + +queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] +queryBack qas = rdfQueryBack (toRDFGraph qas) + +querySubs :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubs vars = rdfQuerySubs vars . toRDFGraph + +querySubsBlank :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubsBlank vars = rdfQuerySubsBlank vars . toRDFGraph + +------------------------------------------------------------ +-- Method for creating an RDF formula value from N3 text +------------------------------------------------------------ + +mkPrefix :: Namespace -> B.Builder +mkPrefix = namespaceToBuilder + +prefixRDF :: B.Builder +prefixRDF = + mconcat + [ mkPrefix namespaceRDF + , mkPrefix namespaceRDFS + ] + +-- |Helper function to parse a string containing Notation3 +-- and return the corresponding RDFGraph value. +-- +makeRDFGraphFromN3Builder :: B.Builder -> RDFGraph +makeRDFGraphFromN3Builder b = + let t = B.toLazyText (prefixRDF `mappend` b) + in case parseN3 t Nothing of + Left msg -> error msg + Right gr -> gr + +-- |Create an RDF formula. +makeRDFFormula :: + Namespace -- ^ namespace to which the formula is allocated + -> LName -- ^ local name for the formula in the namespace + -> B.Builder -- ^ graph in Notation 3 format + -> RDFFormula +makeRDFFormula scope local gr = + Formula + { formName = makeNSScopedName scope local + , formExpr = makeRDFGraphFromN3Builder gr } --- | Extract the namespace of a ruleset. -getRulesetNamespace :: Ruleset ex -> Namespace -getRulesetNamespace = rsNamespace +------------------------------------------------------------ +-- Create an RDF closure rule from supplied graphs +------------------------------------------------------------ --- | Extract the axioms from a ruleset. -getRulesetAxioms :: Ruleset ex -> [Formula ex] -getRulesetAxioms = rsAxioms +-- |Constructs an RDF graph closure rule. That is, a rule that +-- given some set of antecedent statements returns new statements +-- that may be added to the graph. +-- +makeRDFClosureRule :: + ScopedName -- ^ scoped name for the new rule + -> [RDFGraph] -- ^ RDFGraphs that are the entecedent of the rule. + -- + -- (Note: bnodes and variable names are assumed to be shared + -- by all the entecedent graphs supplied. /is this right?/) + -> RDFGraph -- ^ the consequent graph + -> RDFVarBindingModify -- ^ is a variable binding modifier value that may impose + -- additional conditions on the variable bindings that + -- can be used for this inference rule, or which may + -- cause new values to be allocated for unbound variables. + -- These modifiers allow for certain inference patterns + -- that are not captured by simple "closure rules", such + -- as the allocation of bnodes corresponding to literals, + -- and are an extension point for incorporating datatypes + -- into an inference process. + -- + -- If no additional constraints or variable bindings are + -- to be applied, use value 'varBindingId' + -- + -> RDFRule +makeRDFClosureRule sname antgrs congr vmod = makeGraphClosureRule + GraphClosure + { nameGraphRule = sname + , ruleAnt = concatMap getArcs antgrs + , ruleCon = getArcs congr + , ruleModify = vmod + } --- | Extract the rules from a ruleset. -getRulesetRules :: Ruleset ex -> [Rule ex] -getRulesetRules = rsRules +------------------------------------------------------------ +-- Methods to create an RDF closure rule from N3 input +------------------------------------------------------------ +-- +-- These functions are used internally by Swish to construct +-- rules from textual descriptions. --- | Find a named axiom in a ruleset. -getRulesetAxiom :: ScopedName -> Ruleset ex -> Maybe (Formula ex) -getRulesetAxiom nam rset = - mapFindMaybe nam (LookupMap (getRulesetAxioms rset)) - -- listToMaybe $ filter ( (matchName nam) . formName ) $ getRulesetAxioms rset +-- |Constructs an RDF graph closure rule. That is, a rule that +-- given some set of antecedent statements returns new statements +-- that may be added to the graph. This is the basis for +-- implementation of most of the inference rules given in the +-- RDF formal semantics document. +-- +makeN3ClosureRule :: + Namespace -- ^ namespace to which the rule is allocated + -> LName -- ^ local name for the rule in the namespace + -> B.Builder + -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> B.Builder -- ^ the Notation3 representation of the consequent graph. + -> RDFVarBindingModify + -- ^ a variable binding modifier value that may impose + -- additional conditions on the variable bindings that + -- can be used for this inference rule, or which may + -- cause new values to be allocated for unbound variables. + -- These modifiers allow for certain inference patterns + -- that are not captured by simple closure rules, such + -- as the allocation of bnodes corresponding to literals, + -- and are an extension point for incorporating datatypes + -- into an inference process. + -- + -- If no additional constraints or variable bindings are + -- to be applied, use a value of 'varBindingId', or use + -- 'makeN3ClosureSimpleRule'. + -> RDFRule +makeN3ClosureRule scope local ant con = + makeRDFClosureRule (makeNSScopedName scope local) [antgr] congr + where + antgr = makeRDFGraphFromN3Builder ant + congr = makeRDFGraphFromN3Builder con --- | Find a named rule in a ruleset. -getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) -getRulesetRule nam rset = - mapFindMaybe nam (LookupMap (getRulesetRules rset)) - -- listToMaybe $ filter ( (matchName nam) . ruleName ) $ getRulesetRules rset +-- |Construct a simple RDF graph closure rule without +-- additional node allocations or variable binding constraints. +-- +makeN3ClosureSimpleRule :: + Namespace -- ^ namespace to which the rule is allocated + -> LName -- ^ local name for the rule in the namepace + -> B.Builder + -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> B.Builder -- ^ the Notation3 representation of the consequent graph. + -> RDFRule +makeN3ClosureSimpleRule scope local ant con = + makeN3ClosureRule scope local ant con varBindingId --- | Find a named axiom in a proof context. -getContextAxiom :: - ScopedName -- ^ Name of axiom. - -> Formula ex -- ^ Default axiom (used if named component does not exist). - -> [Ruleset ex] -- ^ Rulesets to search. - -> Formula ex -getContextAxiom nam def rsets = fromMaybe def (getMaybeContextAxiom nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetAxiom nam) rsets - -} +-- |Constructs an RDF graph closure rule that incorporates +-- a variable binding filter and a variable binding modifier. +-- +makeN3ClosureModifyRule :: + Namespace -- ^ namespace to which the rule is allocated + -> LName -- ^ local name for the rule in the given namespace + -> B.Builder -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> B.Builder -- ^ the Notation3 representation of the consequent graph. + -> RDFVarBindingModify + -- ^ a variable binding modifier value that may impose + -- additional conditions on the variable bindings that + -- can be used for this inference rule (@vflt@). + -- + -- These modifiers allow for certain inference patterns + -- that are not captured by simple closure rules, such + -- as deductions that pertain only to certain kinds of + -- nodes in a graph. + -> RDFVarBindingModify + -- ^ a variable binding modifier that is applied to the + -- variable bindings obtained, typically to create some + -- additional variable bindings. This is applied before + -- the preceeding filter rule (@vflt@). + -> RDFRule +makeN3ClosureModifyRule scope local ant con vflt vmod = + makeN3ClosureRule scope local ant con modc + where + modc = fromMaybe varBindingId $ vbmCompose vmod vflt --- | Find a named axiom in a proof context. -getMaybeContextAxiom :: - ScopedName -- ^ Name of axiom. - -> [Ruleset ex] -- ^ Rulesets to search. - -> Maybe (Formula ex) -getMaybeContextAxiom nam rsets = - listToMaybe $ mapMaybe (getRulesetAxiom nam) rsets +{- + makeRDFClosureRule (ScopedName scope local) [antgr] congr modc + where + antgr = makeRDFGraphFromN3String ant + congr = makeRDFGraphFromN3String con + modc = case vbmCompose vmod vflt of + Just x -> x + Nothing -> varBindingId +-} --- | Find a named rule in a proof context. -getContextRule :: - ScopedName -- ^ Name of rule. - -> Rule ex -- ^ Default rule (used if named component does not exist). - -> [Ruleset ex] -- ^ Rulesets to search. - -> Rule ex -getContextRule nam def rsets = fromMaybe def (getMaybeContextRule nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetRule nam) rsets - -} +-- |Construct an RDF graph closure rule with a bnode allocator. +-- +-- This function is rather like 'makeN3ClosureModifyRule', except that +-- the variable binding modifier is a function from the variables in +-- the variables and bnodes contained in the antecedent graph. +-- +makeN3ClosureAllocatorRule :: + Namespace -- ^ namespace to which the rule is allocated + -> LName -- ^ local name for the rule in the given namespace + -> B.Builder -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> B.Builder -- ^ the Notation3 representation of the consequent graph. + -> RDFVarBindingModify + -- ^ variable binding modifier value that may impose + -- additional conditions on the variable bindings that + -- can be used for this inference rule (@vflt@). + -> ( [RDFLabel] -> RDFVarBindingModify ) + -- ^ function applied to a list of nodes to yield a + -- variable binding modifier value. + -- + -- The supplied parameter is applied to a list of all of + -- the variable nodes (including all blank nodes) in the + -- antecedent graph, and then composed with the @vflt@ + -- value. This allows any node allocation + -- function to avoid allocating any blank nodes that + -- are already used in the antecedent graph. + -- (See 'makeNodeAllocTo'). + -> RDFRule +makeN3ClosureAllocatorRule scope local ant con vflt aloc = + makeRDFClosureRule (makeNSScopedName scope local) [antgr] congr modc + where + antgr = makeRDFGraphFromN3Builder ant + congr = makeRDFGraphFromN3Builder con + vmod = aloc (allLabels labelIsVar antgr) + modc = fromMaybe varBindingId $ vbmCompose vmod vflt --- | Find a named rule in a proof context. -getMaybeContextRule :: - ScopedName -- ^ Name of rule. - -> [Ruleset ex] -- ^ Rulesets to search. - -> Maybe (Rule ex) -getMaybeContextRule nam rsets = - listToMaybe $ mapMaybe (getRulesetRule nam) rsets +------------------------------------------------------------ +-- Query binding modifier for "allocated to" logic +------------------------------------------------------------ +-- |This function defines a variable binding modifier that +-- allocates a new blank node for each value bound to +-- a query variable, and binds it to another variable +-- in each query binding. +-- +-- This provides a single binding for query variables that would +-- otherwise be unbound by a query. For example, consider the +-- inference pattern: +-- +-- > ?a hasUncle ?c => ?a hasFather ?b . ?b hasBrother ?c . +-- +-- For a given @?a@ and @?c@, there is insufficient information +-- here to instantiate a value for variable @?b@. Using this +-- function as part of a graph instance closure rule allows +-- forward chaining to allocate a single bnode for each +-- occurrence of @?a@, so that given: +-- +-- > Jimmy hasUncle Fred . +-- > Jimmy hasUncle Bob . +-- +-- leads to exactly one bnode inference of: +-- +-- > Jimmy hasFather _:f . +-- +-- giving: +-- +-- > Jimmy hasFather _:f . +-- > _:f hasBrother Fred . +-- > _:f hasBrother Bob . +-- +-- rather than: +-- +-- > Jimmy hasFather _:f1 . +-- > _:f1 hasBrother Fred . +-- > Jimmy hasFather _:f2 . +-- > _:f2 hasBrother Bob . +-- +-- This form of constrained allocation of bnodes is also required for +-- some of the inference patterns described by the RDF formal semantics, +-- particularly those where bnodes are substituted for URIs or literals. +-- +makeNodeAllocTo :: + RDFLabel -- ^ variable node to which a new blank node is bound + -> RDFLabel -- ^ variable which is bound in each query to a graph + -- node to which new blank nodes are allocated. + -> [RDFLabel] + -> RDFVarBindingModify +makeNodeAllocTo bindvar alocvar exbnode = VarBindingModify + { vbmName = swishName "makeNodeAllocTo" + , vbmApply = applyNodeAllocTo bindvar alocvar exbnode + , vbmVocab = [alocvar,bindvar] + , vbmUsage = [[bindvar]] + } + +-- Auxiliary function that performs the node allocation defined +-- by makeNodeAllocTo. +-- +-- bindvar is a variable node to which a new blank node is bound +-- alocvar is a variable which is bound in each query to a graph +-- node to which new blank nodes are allocated. +-- exbnode is a list of existing blank nodes, to be avoided by +-- the new blank node allocator. +-- vars is a list of variable bindings to which new bnode +-- allocations for the indicated bindvar are to be added. +-- +applyNodeAllocTo :: + RDFLabel -> RDFLabel -> [RDFLabel] -> [RDFVarBinding] -> [RDFVarBinding] +applyNodeAllocTo bindvar alocvar exbnode vars = + let + app = applyVarBinding + alocnodes = zip (nub $ flist (map app vars) alocvar) + (newNodes (makeBlank bindvar) exbnode) + newvb var = joinVarBindings + ( makeVarBinding $ head + [ [(bindvar,b)] | (v,b) <- alocnodes, app var alocvar == v ] ) + var + in + map newvb vars + + -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/SwishCommands.hs b/src/Swish/RDF/SwishCommands.hs deleted file mode 100644 --- a/src/Swish/RDF/SwishCommands.hs +++ /dev/null @@ -1,422 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishCommands --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- SwishCommands: functions to deal with indivudual Swish command options. --- --------------------------------------------------------------------------------- - -module Swish.RDF.SwishCommands - ( swishFormat - , swishBase - -- , swishVerbose - , swishInput - , swishOutput - , swishMerge - , swishCompare - , swishGraphDiff - , swishScript - ) -where - -import Swish.RDF.SwishMonad - ( SwishStateIO, SwishState(..), SwishStatus(..) - , setFormat, setBase, setGraph - , resetInfo, resetError, setStatus - -- , setVerbose - , SwishFormat(..) - , swishError - , reportLine - ) - -import Swish.RDF.SwishScript (parseScriptFromText) - -import Swish.RDF.GraphPartition - ( GraphPartition(..) - , partitionGraph, comparePartitions - , partitionShowP - ) - -import Swish.RDF.RDFGraph - ( RDFGraph, merge ) - -import qualified Swish.RDF.TurtleFormatter as TTLF -import qualified Swish.RDF.N3Formatter as N3F -import qualified Swish.RDF.NTFormatter as NTF - -import Swish.RDF.TurtleParser (parseTurtle) -import Swish.RDF.N3Parser (parseN3) -import Swish.RDF.NTParser (parseNT) -import Swish.RDF.RDFParser (appendURIs) - -import Swish.RDF.GraphClass - ( LDGraph(..) - , Label(..) - ) - -import Swish.Utils.QName (QName, qnameFromURI, qnameFromFilePath, getQNameURI) - -import System.IO - ( Handle, openFile, IOMode(..) - , hPutStr, hPutStrLn, hClose - , hIsReadable, hIsWritable - , stdin, stdout - ) - -import Network.URI (parseURIReference) - -import Control.Monad.Trans (MonadTrans(..)) -import Control.Monad.State (modify, gets) -import Control.Monad (liftM, when) - -import qualified Data.Text.Lazy as T -import qualified Data.Text.Lazy.IO as IO -import System.IO.Error - -import Data.Maybe (isJust, fromMaybe) - ------------------------------------------------------------- --- Set file format to supplied value ------------------------------------------------------------- - --- the second argument allows for options to be passed along --- with the format (a la cwm) but this is not supported yet --- -swishFormat :: SwishFormat -> Maybe String -> SwishStateIO () -swishFormat fmt _ = modify (setFormat fmt) - ------------------------------------------------------------- --- Set base URI to supplied value ------------------------------------------------------------- - --- the Maybe String argument is ignored (a result of a lack of --- design with the command-line processing) --- -swishBase :: Maybe QName -> Maybe String -> SwishStateIO () -swishBase mb _ = modify (setBase mb) - ------------------------------------------------------------- --- Read graph from named file ------------------------------------------------------------- - -swishInput :: Maybe String -> SwishStateIO () -swishInput fnam = - swishReadGraph fnam >>= maybe (return ()) (modify . setGraph) - ------------------------------------------------------------- --- Merge graph from named file ------------------------------------------------------------- - -swishMerge :: Maybe String -> SwishStateIO () -swishMerge fnam = - swishReadGraph fnam >>= maybe (return ()) (modify . mergeGraph) - -mergeGraph :: RDFGraph -> SwishState -> SwishState -mergeGraph gr state = state { graph = newgr } - where - newgr = merge gr (graph state) - ------------------------------------------------------------- --- Compare graph from named file ------------------------------------------------------------- - -swishCompare :: Maybe String -> SwishStateIO () -swishCompare fnam = - swishReadGraph fnam >>= maybe (return ()) compareGraph - -compareGraph :: RDFGraph -> SwishStateIO () -compareGraph gr = do - oldGr <- gets graph - let exitCode = if gr == oldGr then SwishSuccess else SwishGraphCompareError - modify $ setStatus exitCode - ------------------------------------------------------------- --- Display graph differences from named file ------------------------------------------------------------- - -swishGraphDiff :: Maybe String -> SwishStateIO () -swishGraphDiff fnam = - swishReadGraph fnam >>= maybe (return ()) diffGraph - -diffGraph :: RDFGraph -> SwishStateIO () -diffGraph gr = do - oldGr <- gets graph - let p1 = partitionGraph (getArcs oldGr) - p2 = partitionGraph (getArcs gr) - diffs = comparePartitions p1 p2 - - swishWriteFile (swishOutputDiffs diffs) Nothing - -swishOutputDiffs :: (Label lb) => - [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] - -> Maybe String - -> Handle - -> SwishStateIO () -swishOutputDiffs diffs fnam hnd = do - lift $ hPutStrLn hnd ("Graph differences: "++show (length diffs)) - mapM_ (swishOutputDiff fnam hnd) (zip [1..] diffs) - -swishOutputDiff :: (Label lb) => - Maybe String - -> Handle - -> (Int,(Maybe (GraphPartition lb),Maybe (GraphPartition lb))) - -> SwishStateIO () -swishOutputDiff fnam hnd (diffnum,(part1,part2)) = do - lift $ hPutStrLn hnd ("---- Difference "++show diffnum++" ----") - lift $ hPutStr hnd "Graph 1:" - swishOutputPart fnam hnd part1 - lift $ hPutStr hnd "Graph 2:" - swishOutputPart fnam hnd part2 - -swishOutputPart :: (Label lb) => - Maybe String - -> Handle - -> Maybe (GraphPartition lb) - -> SwishStateIO () -swishOutputPart _ hnd part = - let out = maybe "\n(No arcs)" (partitionShowP "\n") part - in lift $ hPutStrLn hnd out - ------------------------------------------------------------- --- Execute script from named file ------------------------------------------------------------- - -swishScript :: Maybe String -> SwishStateIO () -swishScript fnam = swishReadScript fnam >>= mapM_ swishCheckResult - -swishReadScript :: Maybe String -> SwishStateIO [SwishStateIO ()] -swishReadScript = swishReadFile swishParseScript [] - -{-| -Calculate the base URI to use; it combines the file name -with any user-supplied base. - -If both the file name and user-supplied base are Nothing -then the value - - http://id.ninebynine.org/2003/Swish/ - -is used. - -Needs some work. --} - -defURI :: QName -defURI = "http://id.ninebynine.org/2003/Swish/" - -calculateBaseURI :: - Maybe FilePath -- ^ file name - -> SwishStateIO QName -- ^ base URI -calculateBaseURI Nothing = fromMaybe defURI `liftM` gets base -calculateBaseURI (Just fnam) = - case parseURIReference fnam of - Just furi -> do - mbase <- gets base - case mbase of - Just buri -> case appendURIs (getQNameURI buri) furi of - Left emsg -> fail emsg -- TODO: think about this ... - Right res -> return $ qnameFromURI res - Nothing -> lift $ qnameFromFilePath fnam - - Nothing -> fail $ "Unable to convert to URI: filepath=" ++ fnam - -swishParseScript :: - Maybe String -- file name (or "stdin" if Nothing) - -> T.Text -- script contents - -> SwishStateIO [SwishStateIO ()] -swishParseScript mfpath inp = do - buri <- calculateBaseURI mfpath - case parseScriptFromText (Just buri) inp of - Left err -> do - let inName = maybe "standard input" ("file " ++) mfpath - swishError ("Script syntax error in " ++ inName ++ ": "++err) SwishDataInputError - return [] - - Right scs -> return scs - -swishCheckResult :: SwishStateIO () -> SwishStateIO () -swishCheckResult swishcommand = do - swishcommand - er <- gets errormsg - case er of - Just x -> swishError x SwishExecutionError >> modify resetError - _ -> return () - - ms <- gets infomsg - case ms of - Just x -> reportLine x >> modify resetInfo - _ -> return () - ------------------------------------------------------------- --- Output graph to named file ------------------------------------------------------------- - -swishOutput :: Maybe String -> SwishStateIO () -swishOutput = swishWriteFile swishOutputGraph - -swishOutputGraph :: Maybe String -> Handle -> SwishStateIO () -swishOutputGraph _ hnd = do - fmt <- gets format - - let writeOut formatter = do - out <- gets $ formatter . graph - lift $ IO.hPutStrLn hnd out - - case fmt of - N3 -> writeOut N3F.formatGraphAsLazyText - NT -> writeOut NTF.formatGraphAsLazyText - Turtle -> writeOut TTLF.formatGraphAsLazyText - -- _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError - ------------------------------------------------------------- --- Common input functions ------------------------------------------------------------- --- --- Keep the logic separate for reading file data and --- parsing it to an RDF graph value. - -swishReadGraph :: Maybe String -> SwishStateIO (Maybe RDFGraph) -swishReadGraph = swishReadFile swishParse Nothing - --- | Open a file (or stdin), read its contents, and process them. --- -swishReadFile :: - (Maybe String -> T.Text -> SwishStateIO a) -- ^ Convert filename and contents into desired value - -> a -- ^ the value to use if the file can not be read in - -> Maybe String -- ^ the file name or @stdin@ if @Nothing@ - -> SwishStateIO a -swishReadFile conv errVal fnam = - let reader (h,f,i) = do - res <- conv fnam i - when f $ lift $ hClose h -- given that we use IO.hGetContents not sure the close is needed - return res - - in swishOpenFile fnam >>= maybe (return errVal) reader - --- | Open and read file, returning its handle and content, or Nothing --- WARNING: the handle must not be closed until input is fully evaluated --- -swishOpenFile :: Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text)) -swishOpenFile Nothing = readFromHandle stdin Nothing -swishOpenFile (Just fnam) = do - o <- lift $ try $ openFile fnam ReadMode - case o of - Left _ -> do - swishError ("Cannot open file: "++fnam) SwishDataAccessError - return Nothing - - Right hnd -> readFromHandle hnd $ Just ("file: " ++ fnam) - -readFromHandle :: Handle -> Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text)) -readFromHandle hdl mlbl = do - hrd <- lift $ hIsReadable hdl - if hrd - then do - fc <- lift $ IO.hGetContents hdl - return $ Just (hdl, isJust mlbl, fc) - - else do - lbl <- case mlbl of - Just l -> lift (hClose hdl) >> return l - Nothing -> return "standard input" - swishError ("Cannot read from " ++ lbl) SwishDataAccessError - return Nothing - -swishParse :: - Maybe String -- ^ filename (if not stdin) - -> T.Text -- ^ contents of file - -> SwishStateIO (Maybe RDFGraph) -swishParse mfpath inp = do - fmt <- gets format - buri <- calculateBaseURI mfpath - - let toError eMsg = - swishError (show fmt ++ " syntax error in " ++ inName ++ ": " ++ eMsg) SwishDataInputError - >> return Nothing - - inName = maybe "standard input" ("file " ++) mfpath - - readIn reader = case reader inp of - Left eMsg -> toError eMsg - Right res -> return $ Just res - - case fmt of - Turtle -> readIn (`parseTurtle` Just (getQNameURI buri)) - N3 -> readIn (`parseN3` Just buri) - NT -> readIn parseNT - {- - _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError >> - return Nothing - -} - -swishWriteFile :: - (Maybe String -> Handle -> SwishStateIO ()) -- ^ given a file name and a handle, write to it - -> Maybe String - -> SwishStateIO () -swishWriteFile conv fnam = - let hdlr (h, c) = conv fnam h >> when c (lift $ hClose h) - in swishCreateWriteableFile fnam >>= maybe (return ()) hdlr - --- | Open file for writing, returning its handle, or Nothing --- Also returned is a flag indicating whether or not the --- handled should be closed when writing is done (if writing --- to standard output, the handle should not be closed as the --- run-time system should deal with that). -swishCreateWriteableFile :: Maybe String -> SwishStateIO (Maybe (Handle,Bool)) -swishCreateWriteableFile Nothing = do - hwt <- lift $ hIsWritable stdout - if hwt - then return $ Just (stdout, False) - else do - swishError "Cannot write to standard output" SwishDataAccessError - return Nothing - -swishCreateWriteableFile (Just fnam) = do - o <- lift $ try $ openFile fnam WriteMode - case o of - Left _ -> do - swishError ("Cannot open file for writing: " ++ fnam) SwishDataAccessError - return Nothing - - Right hnd -> do - hwt <- lift $ hIsWritable hnd - if hwt - then return $ Just (hnd, True) - else do - lift $ hClose hnd - swishError ("Cannot write to file: "++fnam) SwishDataAccessError - return Nothing - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/SwishMain.hs b/src/Swish/RDF/SwishMain.hs deleted file mode 100644 --- a/src/Swish/RDF/SwishMain.hs +++ /dev/null @@ -1,291 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishMain --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- I anticipate that this module may be used as a starting point for --- creating new programs rather then as a complete program in its own --- right. The functionality built into this code is selected with a --- view to testing the Haskell modules for handling RDF rather than --- for performing any particular application processing (though --- development as a tool with some broader utility is not ruled out). --- --- With the following in ghci: --- --- >>> :m + Swish --- >>> :set prompt "swish> " --- --- then we can run a Swish script (format described in "Swish.RDF.SwishScript") --- by saying: --- --- >>> runSwish "-s=script.ss" --- ExitSuccess --- --- or convert a file from Turtle to NTriples format with: --- --- >>> runSwish "-ttl -i=foo.ttl -nt -o=foo.nt" --- ExitSuccess --- --- You can also use `validateCommands` by giving it the individual commands, --- such as --- --- >>> let Right cs = validateCommands ["-ttl", "-i=file1.ttl", "-c=file2.ttl"] --- >>> cs --- [SwishAction: -ttl,SwishAction: -i=file1.ttl,SwishAction: -c=file2.ttl] --- >>> st <- runSwishActions cs --- >>> st --- The graphs do not compare as equal. --- --------------------------------------------------------------------------------- - --- TODO: --- --- * Add RDF/XML input and output --- - -module Swish.RDF.SwishMain ( - SwishStatus(..), SwishAction, - runSwish, - runSwishActions, - displaySwishHelp, - splitArguments, - validateCommands - ) where - -import Swish.RDF.SwishCommands - ( swishFormat - , swishBase - , swishInput - , swishOutput - , swishMerge - , swishCompare - , swishGraphDiff - , swishScript - ) - -import Swish.RDF.SwishMonad - ( SwishStateIO, SwishState(..), SwishStatus(..) - , emptyState - , SwishFormat(..) - ) - -import Swish.Utils.QName (qnameFromURI) -import Swish.Utils.ListHelpers (breakAll) - -import Control.Monad.State (execStateT) -import Control.Monad (liftM) - -import Network.URI (parseURI) - -import Data.Char (isSpace) -import Data.Either (partitionEithers) - -import System.Exit (ExitCode(ExitSuccess, ExitFailure)) - ------------------------------------------------------------- --- Command line description ------------------------------------------------------------- - --- we do not display the version in the help file to avoid having --- to include the Paths_swish module (so that we can use this from --- an interactive environment). --- - -usageText :: [String] -usageText = - [ "Swish: Read, merge, write, compare and process RDF graphs." - , "" - , "Usage: swish option option ..." - , "" - , "where the options are processed from left to right, and may be" - , "any of the following:" - , "-h display this message." - , "-? display this message." - , "-v display Swish version and quit." - , "-q do not display Swish version on start up." - , "-nt use Ntriples format for subsequent input and output." - , "-ttl use Turtle format for subsequent input and output." - , "-n3 use Notation3 format for subsequent input and output (default)" - , "-i[=file] read file in selected format into the graph workspace," - , " replacing any existing graph." - , "-m[=file] merge file in selected format with the graph workspace." - , "-c[=file] compare file in selected format with the graph workspace." - , "-d[=file] show graph differences between the file in selected" - , " format and the graph workspace. Differences are displayed" - , " to the standard output stream." - , "-o[=file] write the graph workspace to a file in the selected format." - , "-s[=file] read and execute Swish script commands from the named file." - , "-b[=base] set or clear the base URI. The semantics of this are not" - , " fully defined yet." - , "" - , " If an optional filename value is omitted, the standard input" - , " or output stream is used, as appropriate." - , "" - , "Exit status codes:" - , "Success - operation completed successfully/graphs compare equal" - , "1 - graphs compare different" - , "2 - input data format error" - , "3 - file access problem" - , "4 - command line error" - , "5 - script file execution error" - , "" - , "Examples:" - , "" - , "swish -i=file" - , " read file as Notation3, and report any syntax errors." - , "swish -i=file1 -o=file2" - , " read file1 as Notation3, report any syntax errors, and output the" - , " resulting graph as reformatted Notation3 (the output format" - , " is not perfect but may be improved)." - , "swish -nt -i=file -n3 -o" - , " read file as NTriples and output as Notation3 to the screen." - , "swich -i=file1 -c=file2" - , " read file1 and file2 as notation3, report any syntax errors, and" - , " if both are OK, compare the resulting graphs to indicate whether" - , " or not they are equivalent." - ] - --- | Write out the help for Swish -displaySwishHelp :: IO () -displaySwishHelp = mapM_ putStrLn usageText - ------------------------------------------------------------- --- Swish command line interpreter ------------------------------------------------------------- --- --- This is a composite monad combining some state with an IO --- Monad. lift allows a pure IO monad to be used as a step --- of the computation. --- - --- | Return any arguments that need processing immediately, namely --- the \"help\", \"quiet\" and \"version\" options. --- -splitArguments :: [String] -> ([String], [String]) -splitArguments = partitionEithers . map splitArgument - -splitArgument :: String -> Either String String -splitArgument "-?" = Left "-h" -splitArgument "-h" = Left "-h" -splitArgument "-v" = Left "-v" -splitArgument "-q" = Left "-q" -splitArgument x = Right x - --- | Represent a Swish action. At present there is no way to create these --- actions other than 'validateCommands'. --- -newtype SwishAction = SA (String, SwishStateIO ()) - -instance Show SwishAction where - show (SA (lbl,_)) = "SwishAction: " ++ lbl - --- | Given a list of command-line arguments create the list of actions --- to perform or a string and status value indicating an input error. -validateCommands :: [String] -> Either (String, SwishStatus) [SwishAction] -validateCommands args = - let (ls, rs) = partitionEithers (map validateCommand args) - in case ls of - (e:_) -> Left e - [] -> Right rs - --- This allows you to say "-nt=foo" and currently ignores the values --- passed through. This may change --- -validateCommand :: String -> Either (String, SwishStatus) SwishAction -validateCommand cmd = - let (nam,more) = break (=='=') cmd - arg = drop 1 more - marg = if null arg then Nothing else Just arg - - wrap f = Right $ SA (cmd, f marg) - in case nam of - "-ttl" -> wrap $ swishFormat Turtle - "-nt" -> wrap $ swishFormat NT - "-n3" -> wrap $ swishFormat N3 - "-i" -> wrap swishInput - "-m" -> wrap swishMerge - "-c" -> wrap swishCompare - "-d" -> wrap swishGraphDiff - "-o" -> wrap swishOutput - "-b" -> validateBase cmd marg - "-s" -> wrap swishScript - _ -> Left ("Invalid command line argument: "++cmd, SwishArgumentError) - --- | Execute the given set of actions. -swishCommands :: [SwishAction] -> SwishStateIO () -swishCommands = mapM_ swishCommand - --- | Execute an action. -swishCommand :: SwishAction -> SwishStateIO () -swishCommand (SA (_,act)) = act - -validateBase :: String -> Maybe String -> Either (String, SwishStatus) SwishAction -validateBase arg Nothing = Right $ SA (arg, swishBase Nothing Nothing) -validateBase arg (Just b) = - case fmap qnameFromURI (parseURI b) of - j@(Just _) -> Right $ SA (arg, swishBase j Nothing) - _ -> Left ("Invalid base URI <" ++ b ++ ">", SwishArgumentError) - ------------------------------------------------------------- --- Interactive test function (e.g. for use in ghci) ------------------------------------------------------------- - --- this ignores the "flags" options, namely --- -q / -h / -? / -v - --- | Parse and run the given string as if given at the command --- line. The \"quiet\", \"version\" and \"help\" options are --- ignored. --- -runSwish :: String -> IO ExitCode -runSwish cmdline = do - let args = breakAll isSpace cmdline - (_, cmds) = splitArguments args - - case validateCommands cmds of - Left (emsg, ecode) -> do - putStrLn $ "Swish exit: " ++ emsg - return $ ExitFailure $ fromEnum ecode - - Right acts -> do - ec <- runSwishActions acts - case ec of - SwishSuccess -> return ExitSuccess - _ -> do - putStrLn $ "Swish exit: " ++ show ec - return $ ExitFailure $ fromEnum ec - --- | Execute the given set of actions. -runSwishActions :: [SwishAction] -> IO SwishStatus -runSwishActions acts = exitcode `liftM` execStateT (swishCommands acts) emptyState - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/SwishMonad.hs b/src/Swish/RDF/SwishMonad.hs deleted file mode 100644 --- a/src/Swish/RDF/SwishMonad.hs +++ /dev/null @@ -1,270 +0,0 @@ -{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishMonad --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : FlexibleInstances, MultiParamTypeClasses --- --- Composed state and IO monad for Swish --- --------------------------------------------------------------------------------- - -module Swish.RDF.SwishMonad - ( SwishStateIO, SwishState(..), SwishStatus(..) - , setFormat, setBase, setGraph - , modGraphs, findGraph, findFormula - , modRules, findRule - , modRulesets, findRuleset - , findOpenVarModify, findDatatype - , setInfo, resetInfo, setError, resetError - , setStatus - -- , setVerbose - , emptyState - , SwishFormat(..) - , NamedGraph(..), NamedGraphMap - , swishError - , reportLines, reportLine - ) -where - -import Swish.RDF.RDFGraph - ( RDFGraph, emptyRDFGraph ) - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleMap, RDFRuleset, RDFRulesetMap ) - -import Swish.RDF.RDFDatatype - ( RDFDatatype ) - -import Swish.RDF.RDFVarBinding - ( RDFOpenVarBindingModify - ) - -import Swish.RDF.BuiltInMap - ( findRDFOpenVarBindingModifier - , findRDFDatatype - , rdfRulesetMap - ) - -import Swish.RDF.Ruleset - ( getMaybeContextAxiom - , getMaybeContextRule - ) - -import Swish.RDF.Rule - ( Formula(..) - ) - -import Swish.Utils.Namespace (ScopedName, getScopeNamespace) -import Swish.Utils.QName (QName) - -import Swish.Utils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap - , mapFindMaybe - , mapVals - ) - -import Control.Monad.Trans (MonadTrans(..)) -import Control.Monad.State (StateT(..), modify) - -import System.IO (hPutStrLn, stderr) - -{-| -The supported input and output formats. --} -data SwishFormat = - Turtle -- ^ Turtle format - | N3 -- ^ N3 format - | NT -- ^ NTriples format - deriving Eq - -instance Show SwishFormat where - show N3 = "N3" - show NT = "Ntriples" - show Turtle = "Turtle" - -- show RDF = "RDF/XML" - --- | The State for a Swish \"program\". - -data SwishState = SwishState - { format :: SwishFormat -- ^ format to use for I/O - , base :: Maybe QName -- ^ base to use rather than file name - , graph :: RDFGraph -- ^ current graph - , graphs :: NamedGraphMap -- ^ script processor named graphs - , rules :: RDFRuleMap -- ^ script processor named rules - , rulesets :: RDFRulesetMap -- ^ script processor rulesets - , infomsg :: Maybe String -- ^ information message, or Nothing - , errormsg :: Maybe String -- ^ error message, or Nothing - , exitcode :: SwishStatus -- ^ current status message - } - --- | Status of the processor --- -data SwishStatus = - SwishSuccess -- ^ successful run - | SwishGraphCompareError -- ^ graphs do not compare - | SwishDataInputError -- ^ input data problem (ie format/syntax) - | SwishDataAccessError -- ^ data access error - | SwishArgumentError -- ^ command-line argument error - | SwishExecutionError -- ^ error executing a Swish script - deriving (Eq, Enum) - -instance Show SwishStatus where - show SwishSuccess = "Success." - show SwishGraphCompareError = "The graphs do not compare as equal." - show SwishDataInputError = "There was a format or syntax error in the input data." - show SwishDataAccessError = "There was a problem accessing data." - show SwishArgumentError = "Argument error: use -h or -? for help." - show SwishExecutionError = "There was a problem executing a Swish script." - -type SwishStateIO a = StateT SwishState IO a - -emptyState :: SwishState -emptyState = SwishState - { format = N3 - , base = Nothing - , graph = emptyRDFGraph - , graphs = emptyLookupMap - , rules = emptyLookupMap - , rulesets = rdfRulesetMap - , infomsg = Nothing - , errormsg = Nothing - , exitcode = SwishSuccess - } - -setFormat :: SwishFormat -> SwishState -> SwishState -setFormat fm state = state { format = fm } - -setBase :: Maybe QName -> SwishState -> SwishState -setBase bs state = state { base = bs } - -setGraph :: RDFGraph -> SwishState -> SwishState -setGraph gr state = state { graph = gr } - -modGraphs :: - ( NamedGraphMap -> NamedGraphMap ) -> SwishState -> SwishState -modGraphs grmod state = state { graphs = grmod (graphs state) } - -findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph] -findGraph nam state = mapFindMaybe nam (graphs state) - -findFormula :: ScopedName -> SwishState -> Maybe RDFFormula -findFormula nam state = case findGraph nam state of - Nothing -> getMaybeContextAxiom nam (mapVals $ rulesets state) - Just [] -> Just $ Formula nam emptyRDFGraph - Just grs -> Just $ Formula nam (head grs) - -modRules :: - ( RDFRuleMap -> RDFRuleMap ) -> SwishState -> SwishState -modRules rlmod state = state { rules = rlmod (rules state) } - -findRule :: ScopedName -> SwishState -> Maybe RDFRule -findRule nam state = - let - localrule = mapFindMaybe nam (rules state) - contextrule = getMaybeContextRule nam $ mapVals $ rulesets state - in - case localrule of - Nothing -> contextrule - justlr -> justlr - -modRulesets :: - ( RDFRulesetMap -> RDFRulesetMap ) -> SwishState -> SwishState -modRulesets rsmod state = state { rulesets = rsmod (rulesets state) } - -findRuleset :: - ScopedName -> SwishState -> Maybe RDFRuleset -findRuleset nam state = mapFindMaybe (getScopeNamespace nam) (rulesets state) - -findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify -findOpenVarModify nam _ = findRDFOpenVarBindingModifier nam - -findDatatype :: ScopedName -> SwishState -> Maybe RDFDatatype -findDatatype nam _ = findRDFDatatype nam - -setInfo :: String -> SwishState -> SwishState -setInfo msg state = state { infomsg = Just msg } - -resetInfo :: SwishState -> SwishState -resetInfo state = state { infomsg = Nothing } - -setError :: String -> SwishState -> SwishState -setError msg state = state { errormsg = Just msg } - -resetError :: SwishState -> SwishState -resetError state = state { errormsg = Nothing } - -setStatus :: SwishStatus -> SwishState -> SwishState -setStatus ec state = state { exitcode = ec } - -{- -setVerbose :: Bool -> SwishState -> SwishState -setVerbose f state = state { banner = f } --} - --- | The graphs dictionary contains named graphs and/or lists --- of graphs that are created and used by script statements. - -data NamedGraph = NamedGraph - { ngName :: ScopedName - , ngGraph :: [RDFGraph] - } - -instance LookupEntryClass NamedGraph ScopedName [RDFGraph] - where - keyVal (NamedGraph k v) = (k,v) - newEntry (k,v) = NamedGraph k v - -type NamedGraphMap = LookupMap NamedGraph - --- | Report error and set exit status code - -swishError :: String -> SwishStatus -> SwishStateIO () -swishError msg sts = do - reportLines [msg, show sts ++ "\n"] - -- when (sts == 4) $ reportLine "Use 'Swish -h' or 'Swish -?' for help\n" - modify $ setStatus sts - --- | Output text to the standard error stream --- --- Each string in the supplied list is a line of text to --- be displayed. - -reportLines :: [String] -> SwishStateIO () -reportLines = mapM_ reportLine - -reportLine :: String -> SwishStateIO () -reportLine line = - -- lift putStrLn line - lift $ hPutStrLn stderr line - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/SwishScript.hs b/src/Swish/RDF/SwishScript.hs deleted file mode 100644 --- a/src/Swish/RDF/SwishScript.hs +++ /dev/null @@ -1,1512 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- -{- | -Module : SwishScript -Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke -License : GPL V2 - -Maintainer : Douglas Burke -Stability : experimental -Portability : OverloadedStrings - -This module implements the Swish script processor: it parses a script -from a supplied string, and returns a list of Swish state transformer -functions whose effect, when applied to a state value, is to implement -the supplied script. - --} - -module Swish.RDF.SwishScript - ( - -- * Syntax - -- $syntax - - -- ** Defining a prefix - -- $prefixLine - - -- ** Naming a graph - -- $nameItem - - -- ** Reading and writing graphs - - -- $readGraph - - -- $writeGraph - - -- ** Merging graphs - -- $mergeGraphs - - -- ** Comparing graphs - - -- $compareGraphs - - -- $assertEquiv - - -- $assertMember - - -- ** Defining rules - - -- $defineRule - - -- $defineRuleset - - -- $defineConstraints - - -- ** Apply a rule - -- $fwdChain - - -- $bwdChain - - -- ** Define a proof - -- $proof - - -- * An example script - -- $exampleScript - - -- * Parsing - - parseScriptFromText - ) -where - -import Swish.RDF.SwishMonad - ( SwishStateIO, SwishStatus(..) - , modGraphs, findGraph, findFormula - , modRules, findRule - , modRulesets, findRuleset - , findOpenVarModify, findDatatype - , setInfo, setError, setStatus - , NamedGraph(..) - ) - -import Swish.RDF.RDFDatatype - ( RDFDatatype ) - -import Swish.RDF.RDFRuleset - ( RDFFormula, RDFRule - , RDFRuleset - , makeRDFClosureRule - ) - -import Swish.RDF.RDFProof - ( RDFProofStep, makeRDFProof, makeRDFProofStep ) - -import Swish.RDF.RDFVarBinding - ( RDFVarBindingModify - ) - -import Swish.RDF.RDFGraphShowM() - -import Swish.RDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , emptyRDFGraph - , NamespaceMap - , setNamespaces - , merge, add - ) - -import Swish.RDF.RDFParser (whiteSpace, lexeme, symbol, eoln, manyTill) - -import Swish.RDF.N3Parser - ( parseAnyfromText - , parseN3 - , N3Parser, N3State(..) - , getPrefix - , subgraph - , n3symbol -- was uriRef2, - , quickVariable -- was varid - , lexUriRef - , newBlankNode - ) - -import Swish.RDF.N3Formatter (formatGraphAsBuilder) -import Swish.RDF.Datatype (typeMkRules) -import Swish.RDF.Proof (explainProof, showsProof) -import Swish.RDF.Ruleset (makeRuleset, getRulesetRule, getMaybeContextRule) -import Swish.RDF.Rule (Formula(..), Rule(..)) -import Swish.RDF.VarBinding (composeSequence) - -import Swish.Utils.Namespace (ScopedName, getScopeNamespace) -import Swish.Utils.QName (QName, qnameFromURI) -import Swish.Utils.LookupMap (mapReplaceOrAdd) -import Swish.Utils.ListHelpers (equiv, flist) - -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.IO as LIO -import Text.ParserCombinators.Poly.StateText - -import Control.Monad (unless, when, liftM) -import Control.Monad.State (modify, gets, lift) - -import Network.URI (URI(..)) - -import Data.Monoid (Monoid(..)) - -import qualified System.IO.Error as IO - ------------------------------------------------------------- --- --- The parser used to be based on the Notation3 parser, and used many --- of the same syntax productions, but the top-level productions used --- are quite different. With the parser re-write it's less clear --- what is going on. --- --- NOTE: during the parser re-write we strip out some of this functionality --- - --- | Parser for Swish script processor -parseScriptFromText :: - Maybe QName -- ^ Default base for the script - -> L.Text -- ^ Swish script - -> Either String [SwishStateIO ()] -parseScriptFromText = parseAnyfromText script - ----------------------------------------------------------------------- --- Syntax productions ----------------------------------------------------------------------- - -between :: Parser s lbr -> Parser s rbr -> Parser s a -> Parser s a -between = bracket - -n3SymLex :: N3Parser ScopedName -n3SymLex = lexeme n3symbol - -setTo :: N3Parser () -setTo = isymbol ":-" - -semicolon :: N3Parser () -semicolon = isymbol ";" - -comma :: N3Parser () -comma = isymbol "," - -commentText :: N3Parser String -commentText = semicolon *> restOfLine - -script :: N3Parser [SwishStateIO ()] -script = do - whiteSpace - scs <- many command - eof - return scs - -isymbol :: String -> N3Parser () -isymbol s = symbol s >> return () - -command :: N3Parser (SwishStateIO ()) -command = - prefixLine - <|> nameItem - <|> readGraph - <|> writeGraph - <|> mergeGraphs - <|> compareGraphs - <|> assertEquiv - <|> assertMember - <|> defineRule - <|> defineRuleset - <|> defineConstraints - <|> checkProofCmd - <|> fwdChain - <|> bwdChain - -prefixLine :: N3Parser (SwishStateIO ()) -prefixLine = do - -- try $ isymbol "@prefix" - isymbol "@prefix" - getPrefix - whiteSpace - isymbol "." - return $ return () - --- name :- graph --- name :- ( graph* ) -nameItem :: N3Parser (SwishStateIO ()) -nameItem = - ssAddGraph <$> n3SymLex <*> (symbol ":-" *> graphOrList) - -maybeURI :: N3Parser (Maybe URI) -maybeURI = (Just <$> lexUriRef) <|> return Nothing - --- @read name [ ] -readGraph :: N3Parser (SwishStateIO ()) -readGraph = commandName "@read" *> (ssRead <$> n3SymLex <*> maybeURI) - --- @write name [ ] ; Comment -writeGraph :: N3Parser (SwishStateIO ()) -writeGraph = - do { commandName "@write" - ; n <- n3SymLex - ; let gs = ssGetList n :: SwishStateIO (Either String [RDFGraph]) - ; muri <- maybeURI - ; c <- commentText - ; return $ ssWriteList muri gs c - } - --- @merge ( name* ) => name -mergeGraphs :: N3Parser (SwishStateIO ()) -mergeGraphs = do - commandName "@merge" - gs <- graphList - isymbol "=>" - n <- n3SymLex - return $ ssMerge n gs - --- @compare name name -compareGraphs :: N3Parser (SwishStateIO ()) -compareGraphs = - commandName "@compare" *> (ssCompare <$> n3SymLex <*> n3SymLex) - --- @ name name ; Comment -assertArgs :: (ScopedName -> ScopedName -> String -> SwishStateIO ()) - -> String -> N3Parser (SwishStateIO ()) -assertArgs assertFunc cName = do - commandName $ '@':cName - assertFunc <$> n3SymLex <*> n3SymLex <*> commentText - --- @asserteq name name ; Comment -assertEquiv :: N3Parser (SwishStateIO ()) -assertEquiv = assertArgs ssAssertEq "asserteq" - --- @assertin name name ; Comment -assertMember :: N3Parser (SwishStateIO ()) -assertMember = assertArgs ssAssertIn "assertin" - --- @rule name :- ( name* ) => name [ | ( (name var*)* ) ] -defineRule :: N3Parser (SwishStateIO ()) -defineRule = - do { commandName "@rule" - ; rn <- n3SymLex - ; setTo - ; ags <- graphOrList - ; isymbol "=>" - ; cg <- graphExpr - ; vms <- varModifiers <|> pure [] - ; return $ ssDefineRule rn ags cg vms - } - --- @ruleset name :- ( name* ) ; ( name* ) -defineRuleset :: N3Parser (SwishStateIO ()) -defineRuleset = - commandName "@ruleset" *> - (ssDefineRuleset <$> n3SymLex <*> (setTo *> nameList) <*> (semicolon *> nameList)) - --- @constraints pref :- ( name* ) | ( name* ) -defineConstraints :: N3Parser (SwishStateIO ()) -defineConstraints = - commandName "@constraints" *> - (ssDefineConstraints <$> n3SymLex <*> (setTo *> graphOrList) <*> (symbol "|" *> nameOrList)) - --- @proof name ( name* ) --- @input name --- @step name ( name* ) => name # rule-name, antecedents, consequent --- @result name -checkProofCmd :: N3Parser (SwishStateIO ()) -checkProofCmd = - do { commandName "@proof" - ; pn <- n3SymLex - ; sns <- nameList - ; commandName "@input" - ; igf <- formulaExpr - ; sts <- many checkStep - ; commandName "@result" - ; rgf <- formulaExpr - ; return $ ssCheckProof pn sns igf sts rgf - } - -checkStep :: - N3Parser (Either String [RDFRuleset] - -> SwishStateIO (Either String RDFProofStep)) -checkStep = - commandName "@step" *> - (ssCheckStep <$> n3SymLex <*> formulaList <*> (symbol "=>" *> formulaExpr)) - --- # ruleset rule (antecedents) => result --- @fwdchain pref name ( name* ) => name -fwdChain :: N3Parser (SwishStateIO ()) -fwdChain = - do { commandName "@fwdchain" - ; sn <- n3SymLex - ; rn <- n3SymLex - ; ags <- graphOrList - ; isymbol "=>" - ; cn <- n3SymLex - ; s <- stGet - ; let prefs = prefixUris s - ; return $ ssFwdChain sn rn ags cn prefs - } - --- # ruleset rule consequent <= (antecedent-alts) --- @bwdchain pref name graph <= name -bwdChain :: N3Parser (SwishStateIO ()) -bwdChain = - do { commandName "@bwdchain" - ; sn <- n3SymLex - ; rn <- n3SymLex - ; cg <- graphExpr - ; isymbol "<=" - ; an <- n3SymLex - ; s <- stGet - ; let prefs = prefixUris s - ; return $ ssBwdChain sn rn cg an prefs - } - ----------------------------------------------------------------------- --- Syntax clause helpers ----------------------------------------------------------------------- - --- TODO: is the loss of identLetter a problem? -commandName :: String -> N3Parser () --- commandName cmd = try (string cmd *> notFollowedBy identLetter *> whiteSpace) -commandName cmd = symbol cmd *> pure () - -restOfLine :: N3Parser String -restOfLine = manyTill (satisfy (const True)) eoln <* whiteSpace - -br :: N3Parser a -> N3Parser a -br = between (symbol "(") (symbol ")") - -nameList :: N3Parser [ScopedName] -nameList = br $ many n3SymLex - -toList :: a -> [a] -toList = (:[]) - -nameOrList :: N3Parser [ScopedName] -nameOrList = - (toList <$> n3SymLex) - <|> nameList - -graphExpr :: N3Parser (SwishStateIO (Either String RDFGraph)) -graphExpr = - graphOnly - <|> - do { f <- formulaExpr - ; return $ liftM (liftM formExpr) f - } - -graphOnly :: N3Parser (SwishStateIO (Either String RDFGraph)) -graphOnly = - do { isymbol "{" - ; b <- newBlankNode - ; g <- subgraph b - ; isymbol "}" - ; s <- stGet - ; let gp = setNamespaces (prefixUris s) g - ; return $ return (Right gp) - } - -graphList :: N3Parser [SwishStateIO (Either String RDFGraph)] -graphList = br (many graphExpr) - -graphOrList :: N3Parser [SwishStateIO (Either String RDFGraph)] -graphOrList = - (toList <$> graphExpr) - <|> graphList - -formulaExpr :: N3Parser (SwishStateIO (Either String RDFFormula)) -formulaExpr = n3SymLex >>= namedGraph - -namedGraph :: ScopedName -> N3Parser (SwishStateIO (Either String RDFFormula)) -namedGraph n = - (ssAddReturnFormula n <$> (setTo *> graphOnly)) - <|> return (ssGetFormula n) - -formulaList :: N3Parser [SwishStateIO (Either String RDFFormula)] -formulaList = between (symbol "(") (symbol ")") (many formulaExpr) - -varModifiers :: N3Parser [(ScopedName,[RDFLabel])] -varModifiers = symbol "|" *> varModList - -varModList :: N3Parser [(ScopedName,[RDFLabel])] -varModList = - br (sepBy varMod comma) - <|> toList <$> lexeme varMod - -varMod :: N3Parser (ScopedName,[RDFLabel]) -varMod = (,) <$> n3SymLex <*> many (lexeme quickVariable) - ----------------------------------------------------------------------- --- SwishState helper functions ----------------------------------------------------------------------- --- --- The functions below operate in the SwishStateIO monad, and are used --- to assemble an executable version of the parsed script. - --- | Return a message to the user. At present the message begins with '# ' --- but this may be removed. --- -ssReport :: - String -- ^ message contents - -> SwishStateIO () --- ssReport msg = lift $ putStrLn $ "# " ++ msg -ssReport msg = modify $ setInfo $ "# " ++ msg - -ssReportLabel :: - String -- ^ label for the message - -> String -- ^ message contents - -> SwishStateIO () -ssReportLabel lbl msg = ssReport $ lbl ++ ": " ++ msg - -ssAddReturnFormula :: - ScopedName -> SwishStateIO (Either String RDFGraph) - -> SwishStateIO (Either String RDFFormula) -ssAddReturnFormula nam gf = - do { egr <- gf - ; ssAddGraph nam [return egr] - ; return $ liftM (Formula nam) egr - } - -ssAddGraph :: - ScopedName -> [SwishStateIO (Either String RDFGraph)] - -> SwishStateIO () -ssAddGraph nam gf = - let errmsg = "Graph/list not added: "++show nam++"; " - in - do { esg <- sequence gf -- [Either String RDFGraph] - ; let egs = sequence esg -- Either String [RDFGraph] - ; let fgs = case egs of - Left er -> setError (errmsg++er) - Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam gs)) - ; modify fgs - } - -ssGetGraph :: ScopedName -> SwishStateIO (Either String RDFGraph) -ssGetGraph nam = liftM head <$> ssGetList nam - -ssGetFormula :: ScopedName -> SwishStateIO (Either String RDFFormula) -ssGetFormula nam = gets find - where - find st = case findFormula nam st of - Nothing -> Left ("Formula not present: "++show nam) - Just gr -> Right gr - -ssGetList :: ScopedName -> SwishStateIO (Either String [RDFGraph]) -ssGetList nam = gets find - where - find st = case findGraph nam st of - Nothing -> Left ("Graph or list not present: "++show nam) - Just grs -> Right grs - -ssRead :: ScopedName -> Maybe URI -> SwishStateIO () -ssRead nam muri = ssAddGraph nam [ssReadGraph muri] - -ssReadGraph :: Maybe URI -> SwishStateIO (Either String RDFGraph) -ssReadGraph muri = - let gf inp = case inp of - Left es -> Left es - Right is -> parseN3 is (fmap qnameFromURI muri) - - in gf `liftM` getResourceData muri - -ssWriteList :: - Maybe URI -> SwishStateIO (Either String [RDFGraph]) -> String - -> SwishStateIO () -ssWriteList muri gf comment = do - esgs <- gf - case esgs of - Left er -> modify $ setError ("Cannot write list: "++er) - Right [] -> putResourceData Nothing (B.fromLazyText (L.concat ["# ", L.pack comment, "\n+ Swish: Writing empty list"])) - Right [gr] -> ssWriteGraph muri gr comment - Right grs -> mapM_ writegr (zip [(0::Int)..] grs) - where - writegr (n,gr) = ssWriteGraph (murin muri n) gr - ("["++show n++"] "++comment) - murin Nothing _ = Nothing - murin (Just uri) n = - let rp = reverse $ uriPath uri - (rLastSet, rRest) = break (=='/') rp - (before, after) = break (=='.') $ reverse rLastSet - newPath = reverse rRest ++ "/" ++ before ++ show n ++ after - in case rLastSet of - "" -> error $ "Invalid URI (path ends in /): " ++ show uri - _ -> Just $ uri { uriPath = newPath } - - - -{- -ssWrite :: - Maybe String -> SwishStateIO (Either String RDFGraph) -> String - -> SwishStateIO () -ssWrite muri gf comment = - do { esg <- gf - ; case esg of - Left er -> modify $ setError ("Cannot write graph: "++er) - Right gr -> ssWriteGraph muri gr comment - } --} - -ssWriteGraph :: Maybe URI -> RDFGraph -> String -> SwishStateIO () -ssWriteGraph muri gr comment = - putResourceData muri (c `mappend` formatGraphAsBuilder gr) - where - c = B.fromLazyText $ L.concat ["# ", L.pack comment, "\n"] - -ssMerge :: - ScopedName -> [SwishStateIO (Either String RDFGraph)] - -> SwishStateIO () -ssMerge nam gfs = - let errmsg = "Graph merge not defined: "++show nam++"; " - in - do { ssReportLabel "Merge" (show nam) - ; esg <- sequence gfs -- [Either String RDFGraph] - ; let egs = sequence esg -- Either String [RDFGraph] - ; let fgs = case egs of - Left er -> setError (errmsg++er) - Right [] -> setError (errmsg++"No graphs to merge") - Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam [g])) - where g = foldl1 merge gs - ; modify fgs - } - -ssCompare :: ScopedName -> ScopedName -> SwishStateIO () -ssCompare n1 n2 = - do { ssReportLabel "Compare" (show n1 ++ " " ++ show n2) - ; g1 <- ssGetGraph n1 - ; g2 <- ssGetGraph n2 - ; when (g1 /= g2) (modify $ setStatus SwishGraphCompareError) - } - -ssAssertEq :: ScopedName -> ScopedName -> String -> SwishStateIO () -ssAssertEq n1 n2 comment = - let er1 = ":\n Graph or list compare not performed: invalid graph/list." - in - do { ssReportLabel "AssertEq" comment - ; g1 <- ssGetList n1 - ; g2 <- ssGetList n2 - ; case (g1,g2) of - (Left er,_) -> modify $ setError (comment++er1++"\n "++er) - (_,Left er) -> modify $ setError (comment++er1++"\n "++er) - (Right gr1,Right gr2) -> - unless (equiv gr1 gr2) $ modify $ - setError (comment++":\n Graph "++show n1 - ++" differs from "++show n2++".") - } - -ssAssertIn :: ScopedName -> ScopedName -> String -> SwishStateIO () -ssAssertIn n1 n2 comment = - let er1 = ":\n Membership test not performed: invalid graph." - er2 = ":\n Membership test not performed: invalid list." - in - do { ssReportLabel "AssertIn" comment - ; g1 <- ssGetGraph n1 - ; g2 <- ssGetList n2 - ; case (g1,g2) of - (Left er,_) -> modify $ setError (comment++er1++"\n "++er) - (_,Left er) -> modify $ setError (comment++er2++"\n "++er) - (Right gr,Right gs) -> - unless (gr `elem` gs) $ modify $ - setError (comment++":\n Graph "++show n1 - ++" not a member of "++show n2) - } - --- Note: this is probably incomplete, though it should work in simple cases. --- A complete solution would have the binding modifiers subject to --- re-arrangement to suit the actual bound variables encountered. --- See VarBinding.findCompositions and VarBinding.findComposition --- --- This code should be adequate if variable bindings are always used --- in combinations consisting of a single modifier followed by any number --- of filters. --- -ssDefineRule :: - ScopedName - -> [SwishStateIO (Either String RDFGraph)] - -> SwishStateIO (Either String RDFGraph) - -> [(ScopedName,[RDFLabel])] - -> SwishStateIO () -ssDefineRule rn agfs cgf vmds = - let errmsg1 = "Rule definition error in antecedent graph(s): " - errmsg2 = "Rule definition error in consequent graph: " - errmsg3 = "Rule definition error in variable modifier(s): " - errmsg4 = "Incompatible variable binding modifier sequence" - in - do { aesg <- sequence agfs -- [Either String RDFGraph] - ; let ags = sequence aesg :: Either String [RDFGraph] - ; cg <- cgf -- Either String RDFGraph - ; let vmfs = map ssFindVarModify vmds - ; evms <- sequence vmfs -- [Either String RDFVarBindingModify] - ; let vms = sequence evms :: Either String [RDFVarBindingModify] - ; let frl = case (ags,cg,vms) of - (Left er,_,_) -> setError (errmsg1++er) - (_,Left er,_) -> setError (errmsg2++er) - (_,_,Left er) -> setError (errmsg3++er) - (Right agrs,Right cgr,Right vbms) -> - let - newRule = makeRDFClosureRule rn agrs cgr - in - case composeSequence vbms of - Just vm -> modRules (mapReplaceOrAdd (newRule vm)) - Nothing -> setError errmsg4 - ; modify frl - } - -ssFindVarModify :: - (ScopedName,[RDFLabel]) -> SwishStateIO (Either String RDFVarBindingModify) -ssFindVarModify (nam,lbs) = gets $ \st -> - case findOpenVarModify nam st of - Just ovbm -> Right (ovbm lbs) - Nothing -> Left ("Undefined modifier: "++show nam) - -ssDefineRuleset :: - ScopedName - -> [ScopedName] - -> [ScopedName] - -> SwishStateIO () -ssDefineRuleset sn ans rns = - let errmsg1 = "Error in ruleset axiom(s): " - errmsg2 = "Error in ruleset rule(s): " - in - do { let agfs = mapM ssGetFormula ans - :: SwishStateIO [Either String RDFFormula] - ; aesg <- agfs -- [Either String RDFFormula] - ; let eags = sequence aesg :: Either String [RDFFormula] - ; let erlf = mapM ssFindRule rns - :: SwishStateIO [Either String RDFRule] - ; rles <- erlf -- [Either String RDFRule] - ; let erls = sequence rles :: Either String [RDFRule] - ; let frs = case (eags,erls) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right ags,Right rls) -> - modRulesets (mapReplaceOrAdd rs) - where - rs = makeRuleset (getScopeNamespace sn) ags rls - ; modify frs - } - -ssFindRule :: ScopedName -> SwishStateIO (Either String RDFRule) -ssFindRule nam = gets find - where - find st = case findRule nam st of - Nothing -> Left ("Rule not found: "++show nam) - Just rl -> Right rl - -ssDefineConstraints :: - ScopedName - -> [SwishStateIO (Either String RDFGraph)] - -> [ScopedName] - -> SwishStateIO () -ssDefineConstraints sn cgfs dtns = - let errmsg1 = "Error in constraint graph(s): " - errmsg2 = "Error in datatype(s): " - in - do { cges <- sequence cgfs -- [Either String RDFGraph] - ; let ecgs = sequence cges :: Either String [RDFGraph] - ; let ecgr = case ecgs of - Left er -> Left er - Right [] -> Right emptyRDFGraph - Right grs -> Right $ foldl1 merge grs - ; edtf <- mapM ssFindDatatype dtns - -- [Either String RDFDatatype] - ; let edts = sequence edtf :: Either String [RDFDatatype] - ; let frs = case (ecgr,edts) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right cgr,Right dts) -> - modRulesets (mapReplaceOrAdd rs) - where - rs = makeRuleset (getScopeNamespace sn) [] rls - rls = concatMap (`typeMkRules` cgr) dts - ; modify frs - } - -ssFindDatatype :: ScopedName -> SwishStateIO (Either String RDFDatatype) -ssFindDatatype nam = gets find - where - find st = case findDatatype nam st of - Nothing -> Left ("Datatype not found: "++show nam) - Just dt -> Right dt - - -ssCheckProof :: - ScopedName -- proof name - -> [ScopedName] -- ruleset names - -> SwishStateIO (Either String RDFFormula) -- input formula - -> [Either String [RDFRuleset] -- proof step from rulesets - -> SwishStateIO (Either String RDFProofStep)] - -> SwishStateIO (Either String RDFFormula) -- result formula - -> SwishStateIO () -ssCheckProof pn sns igf stfs rgf = - let - infmsg1 = "Proof satisfied: " - errmsg1 = "Error in proof ruleset(s): " - errmsg2 = "Error in proof input: " - errmsg3 = "Error in proof step(s): " - errmsg4 = "Error in proof goal: " - errmsg5 = "Proof not satisfied: " - proofname = " (Proof "++show pn++")" - in - do { let rs1 = map ssFindRuleset sns :: [SwishStateIO (Either String RDFRuleset)] - ; rs2 <- sequence rs1 -- [Either String RDFRuleset] - ; let erss = sequence rs2 :: Either String [RDFRuleset] - ; eig <- igf -- Either String RDFFormula - ; let st1 = sequence $ flist stfs erss :: SwishStateIO [Either String RDFProofStep] - ; st2 <- st1 -- [Either String RDFProofStep] - ; let ests = sequence st2 :: Either String [RDFProofStep] - ; erg <- rgf -- Either String RDFFormula - ; let proof = case (erss,eig,ests,erg) of - (Left er,_,_,_) -> Left (errmsg1++er++proofname) - (_,Left er,_,_) -> Left (errmsg2++er++proofname) - (_,_,Left er,_) -> Left (errmsg3++er++proofname) - (_,_,_,Left er) -> Left (errmsg4++er++proofname) - (Right rss, Right ig, Right sts, Right rg) -> - Right (makeRDFProof rss ig rg sts) - ; when False $ case proof of - (Left _) -> return () - (Right pr) -> putResourceData Nothing $ - B.fromLazyText (L.concat ["Proof ", L.pack (show pn), "\n"]) - `mappend` - B.fromString (showsProof "\n" pr "\n") - -- TODO: clean up - ; let checkproof = case proof of - (Left er) -> setError er - (Right pr) -> - case explainProof pr of - Nothing -> setInfo (infmsg1++show pn) - Just ex -> setError (errmsg5++show pn++", "++ex) - {- - if not $ checkProof pr then - setError (errmsg5++show pn) - else - setInfo (infmsg1++show pn) - -} - ; modify checkproof - } - -ssCheckStep :: - ScopedName -- rule name - -> [SwishStateIO (Either String RDFFormula)] -- antecedent graph formulae - -> SwishStateIO (Either String RDFFormula) -- consequent graph formula - -> Either String [RDFRuleset] -- rulesets - -> SwishStateIO (Either String RDFProofStep) -- resulting proof step -ssCheckStep _ _ _ (Left er) = return $ Left er -ssCheckStep rn eagf ecgf (Right rss) = - let - errmsg1 = "Rule not in proof step ruleset(s): " - errmsg2 = "Error in proof step antecedent graph(s): " - errmsg3 = "Error in proof step consequent graph: " - in - do { let mrul = getMaybeContextRule rn rss :: Maybe RDFRule - ; esag <- sequence eagf -- [Either String RDFFormula]] - ; let eags = sequence esag :: Either String [RDFFormula] - ; ecg <- ecgf -- Either String RDFFormula - ; let est = case (mrul,eags,ecg) of - (Nothing,_,_) -> Left (errmsg1++show rn) - (_,Left er,_) -> Left (errmsg2++er) - (_,_,Left er) -> Left (errmsg3++er) - (Just rul,Right ags,Right cg) -> - Right $ makeRDFProofStep rul ags cg - ; return est - } - -ssFwdChain :: - ScopedName -- ruleset name - -> ScopedName -- rule name - -> [SwishStateIO (Either String RDFGraph)] -- antecedent graphs - -> ScopedName -- consequent graph name - -> NamespaceMap -- prefixes for new graph - -> SwishStateIO () -ssFwdChain sn rn agfs cn prefs = - let - errmsg1 = "FwdChain rule error: " - errmsg2 = "FwdChain antecedent error: " - in - do { erl <- ssFindRulesetRule sn rn - ; aesg <- sequence agfs -- [Either String RDFGraph] - ; let eags = sequence aesg :: Either String [RDFGraph] - ; let fcr = case (erl,eags) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right rl,Right ags) -> - modGraphs (mapReplaceOrAdd (NamedGraph cn [cg])) - where - cg = case fwdApply rl ags of - [] -> emptyRDFGraph - grs -> setNamespaces prefs $ foldl1 add grs - ; modify fcr - } - -ssFindRulesetRule :: - ScopedName -> ScopedName -> SwishStateIO (Either String RDFRule) -ssFindRulesetRule sn rn = gets find - where - find st = case findRuleset sn st of - Nothing -> Left ("Ruleset not found: "++show sn) - Just rs -> find1 rs - find1 rs = case getRulesetRule rn rs of - Nothing -> Left ("Rule not in ruleset: "++show sn++": "++show rn) - Just rl -> Right rl - -ssFindRuleset :: - ScopedName -> SwishStateIO (Either String RDFRuleset) -ssFindRuleset sn = gets find - where - find st = case findRuleset sn st of - Nothing -> Left ("Ruleset not found: "++show sn) - Just rs -> Right rs - -ssBwdChain :: - ScopedName -- ruleset name - -> ScopedName -- rule name - -> SwishStateIO (Either String RDFGraph) -- consequent graphs - -> ScopedName -- antecedent alts name - -> NamespaceMap -- prefixes for new graphs - -> SwishStateIO () -ssBwdChain sn rn cgf an prefs = - let - errmsg1 = "BwdChain rule error: " - errmsg2 = "BwdChain goal error: " - in - do { erl <- ssFindRulesetRule sn rn - ; ecg <- cgf -- Either String RDFGraph - ; let fcr = case (erl,ecg) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right rl,Right cg) -> - modGraphs (mapReplaceOrAdd (NamedGraph an ags)) - where - ags = map mergegr (bwdApply rl cg) - mergegr grs = case grs of - [] -> emptyRDFGraph - _ -> setNamespaces prefs $ foldl1 add grs - ; modify fcr - } - --- Temporary implementation: just read local file WNH --- (Add logic to separate filenames from URIs, and --- attempt HTTP GET, or similar.) -getResourceData :: Maybe URI -> SwishStateIO (Either String L.Text) -getResourceData muri = - case muri of - Nothing -> fromStdin - Just uri -> fromUri uri - where - fromStdin = - do { dat <- lift LIO.getContents - ; return $ Right dat - } - fromUri = fromFile - fromFile uri | uriScheme uri == "file:" = Right `fmap` lift (LIO.readFile $ uriPath uri) - | otherwise = error $ "Unsupported file name for read: " ++ show uri - --- Temporary implementation: just write local file --- (Need to add logic to separate filenames from URIs, and --- attempt HTTP PUT, or similar.) -putResourceData :: Maybe URI -> B.Builder -> SwishStateIO () -putResourceData muri gsh = - do { ios <- lift $ IO.try $ - case muri of - Nothing -> toStdout - Just uri -> toUri uri - ; case ios of - Left ioe -> modify $ setError - ("Error writing graph: "++ - IO.ioeGetErrorString ioe) - Right a -> return a - } - where - toStdout = LIO.putStrLn gstr - toUri uri | uriScheme uri == "file:" = LIO.writeFile (uriPath uri) gstr - | otherwise = error $ "Unsupported file name for write: " ++ show uri - gstr = B.toLazyText gsh - -{- $syntax - -The script syntax is based loosely on Notation3, and the script parser is an -extension of the Notation3 parser in the module "Swish.RDF.N3Parser". -The comment character is @#@ and white space is ignored. - -> script := command * -> command := prefixLine | -> nameItem | -> readGraph | -> writeGraph | -> mergeGraphs | -> compareGraphs | -> assertEquiv | -> assertMember | -> defineRule | -> defineRuleset | -> defineConstraints | -> checkProofCmd | -> fwdChain | -> bwdChain - --} - -{- $prefixLine - -> prefixLine := @prefix []: . - -Define a namespace prefix and URI. - -The prefix thus defined is available for use in any subsequent script -command, and also in any graphs contained within the script file. (So, -prefix declarations do not need to be repeated for each graph -contained within the script.) - -Graphs read from external files must contain their own prefix -declarations. - -Example: - - > @prefix gex: . - > @prefix : . - --} - -{- $nameItem - -> nameItem := name :- graph | -> name :- ( graph* ) - -Graphs or lists of graphs can be given a name for use in other -statements. A name is a qname (prefix:local) or a URI enclosed in -angle - -Example: - -> @prefix ex1: . -> @prefix ex2: . -> -> ex1:gr1 :- { -> ex2:foo a ex2:Foo . -> ex2:bar a ex2:Bar . -> ex2:Bar rdfs:subClassOf ex2:Foo . -> } - --} - -{- $readGraph - -> readGraph := @read name [] - -The @\@read@ command reads in the contents of the given URI -- which at present only supports reading local files, so -no HTTP access - and stores it under the given name. - -If no URI is given then the file is read from standard input. - -Example: - - > @prefix ex: . - > @read ex:foo - --} - -{- $writeGraph - -> writeGraph := @write name [] ; comment - -The @\@write@ command writes out the contents of the given graph -- which at present only supports writing local files, so -no HTTP access. The comment text is written as a comment line -preceeding the graph contents. - -If no URI is given then the file is written to the standard output. - -Example: - - > @prefix ex: . - > @read ex:gr1 - > @read ex:gr2 - > @merge (ex:gr1 ex:gr2) => ex:gr3 - > @write ex:gr3 ; the merged data - > @write ex:gr3 ; merge of graph1.n3 and graph2.n3 - --} - -{- $mergeGraphs - -> mergeGraphs := @merge ( name* ) => name - -Create a new named graph that is the merge two or more graphs, -renaming bnodes as required to avoid node-merging. - -When the merge command is run, the message - - > # Merge: - -will be created on the standard output channel. - -Example: - - > @prefix gex: . - > @prefix ex: . - > gex:gr1 :- { ex:foo ex:bar _:b1 . } - > gex:gr2 :- { _:b1 ex:foobar 23. } - > @merge (gex:gr1 gex:gr2) => gex:gr3 - > @write gex:gr3 ; merged graphs - -When run in Swish, this creates the following output (along with -several other namespace declarations): - - > # merged graphs - > @prefix ex: . - > ex:foo ex:bar [] . - > [ - > ex:foobar "23"^^xsd:integer - > ] . - --} - -{- $compareGraphs - -> compareGraphs := @compare name name - -Compare two graphs for isomorphism, setting the Swish exit status to -reflect the result. - -When the compare command is run, the message - - > # Compare: - -will be created on the standard output channel. - -Example: - - > @prefix gex: . - > @read gex:gr1 - > @read gex:gr2 - > @compare gex:gr1 gex:gr2 - --} - -{- $assertEquiv - -> assertEquiv := @asserteq name name ; comment - -Test two graphs or lists of graphs for isomorphism, reporting if they -differ. The comment text is included with any report generated. - -When the command is run, the message - - > # AssertEq: - -will be created on the standard output channel. - -Example: - - > @prefix ex: . - > - > # Set up the graphs for the rules - > ex:Rule01Ant :- { ?p ex:son ?o . } - > ex:Rule01Con :- { ?o a ex:Male ; ex:parent ?p . } - > - > # Create a rule and a ruleset - > @rule ex:Rule01 :- ( ex:Rule01Ant ) => ex:Rule01Con - > @ruleset ex:rules :- (ex:TomSonDick ex:TomSonHarry) ; (ex:Rule01) - > - > # Apply the rule - > @fwdchain ex:rules ex:Rule01 { :Tom ex:son :Charles . } => ex:Rule01fwd - > - > # Compare the results to the expected value - > ex:ExpectedRule01fwd :- { :Charles a ex:Male ; ex:parent :Tom . } - > @asserteq ex:Rule01fwd ex:ExpectedRule01fwd - > ; Infer that Charles is male and has parent Tom - --} - -{- $assertMember - -> assertMember := @assertin name name ; comment - -Test if a graph is isomorphic to a member of a list of graphs, -reporting if no match is found. The comment text is included with any -report generated. - -Example: - -> @bwdchain pv:rules :PassengerVehicle ex:Test01Inp <= :t1b -> -> @assertin ex:Test01Bwd0 :t1b ; Backward chain component test (0) -> @assertin ex:Test01Bwd1 :t1b ; Backward chain component test (1) - --} - -{- $defineRule - -> defineRule := @rule name :- ( name* ) => name -> defineRule := @rule name :- ( name* ) => name -> | ( (name var*)* ) - -Define a named Horn-style rule. - -The list of names preceding and following @=>@ are the antecedent and consequent -graphs, respectivelu. Both sets may contain variable nodes of the form -@?var@. - -The optional part, after the @|@ separator, is a list of variable -binding modifiers, each of which consists of a name and a list of -variables (@?var@) to which the modifier is applied. Variable binding -modifiers are built in to Swish, and are used to incorporate datatype -value inferences into a rule. - --} - -{- $defineRuleset - -> defineRuleset := @ruleset name :- ( name* ) ; ( name* ) - -Define a named ruleset (a collection of axioms and rules). The first -list of names are the axioms that are part of the ruleset, and the -second list are the rules. - --} - -{- $defineConstraints - -> defineConstraints := @constraints pref :- ( name* ) | [ name | ( name* ) ] - -Define a named ruleset containing class-restriction rules based on a -datatype value constraint. The first list of -names is a list of graphs that together comprise the class-restriction -definitions (rule names are the names of the corresponding restriction -classes). The second list of names is a list of datatypes whose -datatype relations are referenced by the class restriction -definitions. - --} - -{- $fwdChain - -> fwdChain := @fwdchain pref name ( name* ) => name - -Define a new graph obtained by forward-chaining a rule. The first name -is the ruleset to be used. The second name is the rule name. The list -of names are the antecedent graphs to which the rule is applied. The -name following the @=>@ names a new graph that is the result of formward -chaining from the given antecedents using the indicated rule. - --} - -{- $bwdChain - -> bwdChain := @bwdchain pref name graph <= name - -Define a new list of alternative graphs obtained by backward-chaining -a rule. The first name is the ruleset to be used. The second name is -the rule name. The third name (before the @<=@) is the name of a goal graph -from which to backward chain. The final name (after the @<=@) names a new -list of graphs, each of which is an alternative antecedent from which -the given goal can be deduced using the indicated rule. - - --} - -{- $proof - -> checkProofCmd := proofLine nl -> inputLine nl -> (stepLine nl)* -> resultLine -> proofLine := @proof name ( name* ) - -Check a proof, reporting the step that fails, if any. - -The @\@proof@ line names the proof and specifies a list rulesets -(proof context) used. The remaining lines specify the input -expression (@\@input@), proof steps (@\@step@) and the final result -(@\@result@) that is demonstrated by the proof. - -> inputLine := @input name - -In a proof, indicates an input expression upon which the proof is -based. Exactly one of these immediately follows the @\@proof@ command. - -> stepLine := @step name ( name* ) => name - -This defines a step of the proof; any number of these immediately -follow the @\@input@ command. - -It indicates the name of the rule applied for this step, a list of -antecedent graphs, and a named graph that is deduced by this step. -For convenience, the deduced graph may introduce a new named graph -using an expression of the form: - - > name :- { statements } - -> resultLine := @result name - -This defines the goal of the proof, and completes a proof -definition. Exactly one of these immediately follows the @\@step@ -commands. For convenience, the result statement may introduce a new -named graph using an expression of the form: - - > name :- { statements } - --} - -{- $exampleScript - -This is the example script taken from - -with the proof step adjusted so that it passes. - -> # -- Example Swish script -- -> # -> # Comment lines start with a '#' -> # -> # The script syntax is loosely based on Notation3, but it is a quite -> # different language, except that embedded graphs (enclosed in {...}) -> # are encoded using Notation3 syntax. -> # -> # -- Prefix declarations -- -> # -> # As well as being used for all labels defined and used by the script -> # itself, these are applied to all graph expressions within the script -> # file, and to graphs created by scripted inferences, -> # but are not applied to any graphs read in from an external source. -> -> @prefix ex: . -> @prefix pv: . -> @prefix xsd: . -> @prefix xsd_integer: . -> @prefix rs_rdf: . -> @prefix rs_rdfs: . -> @prefix : . -> -> # Additionally, prefix declarations are provided automatically for: -> # @prefix rdf: . -> # @prefix rdfs: . -> # @prefix rdfd: . -> # @prefix rdfo: . -> # @prefix owl: . -> -> # -- Simple named graph declarations -- -> -> ex:Rule01Ant :- { ?p ex:son ?o . } -> -> ex:Rule01Con :- { ?o a ex:Male ; ex:parent ?p . } -> -> ex:TomSonDick :- { :Tom ex:son :Dick . } -> ex:TomSonHarry :- { :Tom ex:son :Harry . } -> -> # -- Named rule definition -- -> -> @rule ex:Rule01 :- ( ex:Rule01Ant ) => ex:Rule01Con -> -> # -- Named ruleset definition -- -> # -> # A 'ruleset' is a collection of axioms and rules. -> # -> # Currently, the ruleset is identified using the namespace alone; -> # i.e. the 'rules' in 'ex:rules' below is not used. -> # This is under review. -> -> @ruleset ex:rules :- (ex:TomSonDick ex:TomSonHarry) ; (ex:Rule01) -> -> # -- Forward application of rule -- -> # -> # The rule is identified here by ruleset and a name within the ruleset. -> -> @fwdchain ex:rules ex:Rule01 { :Tom ex:son :Charles . } => ex:Rule01fwd -> -> # -- Compare graphs -- -> # -> # Compare result of inference with expected result. -> # This is a graph isomorphism test rather than strict equality, -> # to allow for bnode renaming. -> # If the graphs are not equal, a message is generated, which -> # includes the comment (';' to end of line) -> -> ex:ExpectedRule01fwd :- { :Charles a ex:Male ; ex:parent :Tom . } -> -> @asserteq ex:Rule01fwd ex:ExpectedRule01fwd -> ; Infer that Charles is male and has parent Tom -> -> # -- Display graph (to screen and a file) -- -> # -> # The comment is included in the output. -> -> @write ex:Rule01fwd ; Charles is male and has parent Tom -> @write ex:Rule01fwd ; Charles is male and has parent Tom -> -> # -- Read graph from file -- -> # -> # Creates a new named graph in the Swish environment. -> -> @read ex:Rule01inp -> -> # -- Proof check -- -> # -> # This proof uses the built-in RDF and RDFS rulesets, -> # which are the RDF- and RDFS- entailment rules described in the RDF -> # formal semantics document. -> # -> # To prove: -> # ex:foo ex:prop "a" . -> # RDFS-entails -> # ex:foo ex:prop _:x . -> # _:x rdf:type rdfs:Resource . -> # -> # If the proof is not valid according to the axioms and rules of the -> # ruleset(s) used and antecedents given, then an error is reported -> # indicating the failed proof step. -> -> ex:Input :- { ex:foo ex:prop "a" . } -> ex:Result :- { ex:foo ex:prop _:a . _:a rdf:type rdfs:Resource . } -> -> @proof ex:Proof ( rs_rdf:rules rs_rdfs:rules ) -> @input ex:Input -> @step rs_rdfs:r3 ( rs_rdfs:a10 rs_rdfs:a39 ) -> => ex:Stepa :- { rdfs:Literal rdf:type rdfs:Class . } -> @step rs_rdfs:r8 ( ex:Stepa ) -> => ex:Stepb :- { rdfs:Literal rdfs:subClassOf rdfs:Resource . } -> @step rs_rdf:lg ( ex:Input ) -> => ex:Stepc :- { ex:foo ex:prop _:a . _:a rdf:_allocatedTo "a" . } -> @step rs_rdfs:r1 ( ex:Stepc ) -> => ex:Stepd :- { _:a rdf:type rdfs:Literal . } -> @step rs_rdfs:r9 ( ex:Stepb ex:Stepd ) -> => ex:Stepe :- { _:a rdf:type rdfs:Resource . } -> @step rs_rdf:se ( ex:Stepc ex:Stepd ex:Stepe ) -> => ex:Result -> @result ex:Result -> -> # -- Restriction based datatype inferencing -- -> # -> # Datatype inferencing based on a general class restriction and -> # a predefined relation (per idea noted by Pan and Horrocks). -> -> ex:VehicleRule :- -> { :PassengerVehicle a rdfd:GeneralRestriction ; -> rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; -> rdfd:constraint xsd_integer:sum ; -> rdfd:maxCardinality "1"^^xsd:nonNegativeInteger . } -> -> # Define a new ruleset based on a declaration of a constraint class -> # and reference to built-in datatype. -> # The datatype constraint xsd_integer:sum is part of the definition -> # of datatype xsd:integer that is cited in the constraint ruleset -> # declaration. It relates named properties of a class instance. -> -> @constraints pv:rules :- ( ex:VehicleRule ) | xsd:integer -> -> # Input data for test cases: -> -> ex:Test01Inp :- -> { _:a1 a :PassengerVehicle ; -> :seatedCapacity "30"^^xsd:integer ; -> :standingCapacity "20"^^xsd:integer . } -> -> # Forward chaining test case: -> -> ex:Test01Fwd :- { _:a1 :totalCapacity "50"^^xsd:integer . } -> -> @fwdchain pv:rules :PassengerVehicle ex:Test01Inp => :t1f -> @asserteq :t1f ex:Test01Fwd ; Forward chain test -> -> # Backward chaining test case: -> # -> # Note that the result of backward chaining is a list of alternatives, -> # any one of which is sufficient to derive the given conclusion. -> -> ex:Test01Bwd0 :- -> { _:a1 a :PassengerVehicle . -> _:a1 :totalCapacity "50"^^xsd:integer . -> _:a1 :seatedCapacity "30"^^xsd:integer . } -> -> ex:Test01Bwd1 :- -> { _:a1 a :PassengerVehicle . -> _:a1 :totalCapacity "50"^^xsd:integer . -> _:a1 :standingCapacity "20"^^xsd:integer . } -> -> # Declare list of graphs: -> -> ex:Test01Bwd :- ( ex:Test01Bwd0 ex:Test01Bwd1 ) -> -> @bwdchain pv:rules :PassengerVehicle ex:Test01Inp <= :t1b -> @asserteq :t1b ex:Test01Bwd ; Backward chain test -> -> # Can test for graph membership in a list -> -> @assertin ex:Test01Bwd0 :t1b ; Backward chain component test (0) -> @assertin ex:Test01Bwd1 :t1b ; Backward chain component test (1) -> -> # -- Merge graphs -- -> # -> # Merging renames bnodes to avoid collisions. -> -> @merge ( ex:Test01Bwd0 ex:Test01Bwd1 ) => ex:Merged -> -> # This form of comparison sets the Swish exit status based on the result. -> -> ex:ExpectedMerged :- -> { _:a1 a :PassengerVehicle . -> _:a1 :totalCapacity "50"^^xsd:integer . -> _:a1 :seatedCapacity "30"^^xsd:integer . -> _:a2 a :PassengerVehicle . -> _:a2 :totalCapacity "50"^^xsd:integer . -> _:a2 :standingCapacity "20"^^xsd:integer . } -> -> @compare ex:Merged ex:ExpectedMerged -> -> # End of example script - -If saved in the file example.ss, then it can be evaluated by saying -either of: - -> % Swish -s=example.ss - -or, from @ghci@: - -> Prelude> :m + Swish.RDF.SwishMain -> Prelude Swish.RDF.SwishMain> :set prompt "Swish> " -> Swish> runSwish "-s=example.ss" - -and the output is - -> # AssertEq: Infer that Charles is male and has parent Tom -> # Charles is male and has parent Tom -> @prefix rdf: . -> @prefix rdfs: . -> @prefix rdfd: . -> @prefix owl: . -> @prefix log: . -> @prefix : . -> @prefix ex: . -> @prefix pv: . -> @prefix xsd: . -> @prefix xsd_integer: . -> @prefix rs_rdf: . -> @prefix rs_rdfs: . -> :Charles ex:parent :Tom ; -> a ex:Male . -> -> Proof satisfied: ex:Proof -> # AssertEq: Forward chain test -> # AssertEq: Backward chain test -> # AssertIn: Backward chain component test (0) -> # AssertIn: Backward chain component test (1) -> # Merge: ex:Merged -> # Compare: ex:Merged ex:ExpectedMerged - --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/TurtleFormatter.hs b/src/Swish/RDF/TurtleFormatter.hs deleted file mode 100644 --- a/src/Swish/RDF/TurtleFormatter.hs +++ /dev/null @@ -1,879 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : TurtleFormatter --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This Module implements a Turtle formatter --- for an RDFGraph value. See --- --- \"Turtle, Terse RDF Triple Language\", --- W3C Working Draft 09 August 2011 () --- --------------------------------------------------------------------------------- - -{- -TODO: - -The code used to determine whether a blank node can be written -using the "[]" short form could probably take advantage of the -GraphPartition module. - --} - -module Swish.RDF.TurtleFormatter - ( NodeGenLookupMap - , formatGraphAsText - , formatGraphAsLazyText - , formatGraphAsBuilder - , formatGraphIndent - , formatGraphDiag - - -- * Auxillary routines - , quoteText - ) -where - -import Swish.RDF.RDFGraph ( - RDFGraph, RDFLabel(..) - , NamespaceMap, RevNamespaceMap - -- emptyNamespaceMap, - -- FormulaMap, emptyFormulaMap, - , getArcs - , labels - -- , setNamespaces - , getNamespaces, - -- getFormulae, - emptyRDFGraph - , quote - , quoteT - , resRdfFirst, resRdfRest, resRdfNil - ) - -import Swish.RDF.Vocabulary ( - isLang - , langTag - , rdfType - , rdfNil - , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble - ) - -import Swish.RDF.GraphClass (Arc(..)) - -import Swish.Utils.LookupMap - ( LookupEntryClass(..) - , LookupMap, emptyLookupMap, reverseLookupMap - , listLookupMap - , mapFind, mapFindMaybe, mapAdd - -- , mapDelete - , mapMerge - ) - -import Swish.Utils.Namespace (ScopedName, getScopeLocal, getScopeURI) - -import Data.Char (isDigit) - -import Data.List (foldl', delete, groupBy, partition, sort, intersperse) - -import Data.Monoid (Monoid(..)) -import Control.Monad (liftM, when) -import Control.Monad.State (State, modify, get, put, runState) - --- it strikes me that using Lazy Text here is likely to be --- wrong; however I have done no profiling to back this --- assumption up! - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B - --- temporary conversion -quoteB :: Bool -> String -> B.Builder -quoteB f v = B.fromString $ quote f v - ----------------------------------------------------------------------- --- Graph formatting state monad ----------------------------------------------------------------------- --- --- The graph to be formatted is carried as part of the formatting --- state, so that decisions about what needs to be formatted can --- themselves be based upon and reflected in the state (e.g. if a --- decision is made to include a blank node inline, it can be removed --- from the graph state that remains to be formatted). - -type SubjTree lb = [(lb,PredTree lb)] -type PredTree lb = [(lb,[lb])] - -data TurtleFormatterState = TFS - { indent :: B.Builder - , lineBreak :: Bool - , graph :: RDFGraph - , subjs :: SubjTree RDFLabel - , props :: PredTree RDFLabel -- for last subject selected - , objs :: [RDFLabel] -- for last property selected - -- , formAvail :: FormulaMap RDFLabel - -- , formQueue :: [(RDFLabel,RDFGraph)] - , nodeGenSt :: NodeGenState - , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format - , traceBuf :: [String] - } - -type Formatter a = State TurtleFormatterState a - -emptyTFS :: NodeGenState -> TurtleFormatterState -emptyTFS ngs = TFS - { indent = "\n" - , lineBreak = False - , graph = emptyRDFGraph - , subjs = [] - , props = [] - , objs = [] - -- , formAvail = emptyFormulaMap - -- , formQueue = [] - , nodeGenSt = ngs - , bNodesCheck = [] - , traceBuf = [] - } - --- | Node name generation state information that carries through --- and is updated by nested formulae -type NodeGenLookupMap = LookupMap (RDFLabel,Int) - -data NodeGenState = Ngs - { prefixes :: NamespaceMap - , nodeMap :: NodeGenLookupMap - , nodeGen :: Int - } - -emptyNgs :: NodeGenState -emptyNgs = Ngs - { prefixes = emptyLookupMap - , nodeMap = emptyLookupMap - , nodeGen = 0 - } - --- simple context for label creation --- (may be a temporary solution to the problem --- of label creation) --- -data LabelContext = SubjContext | PredContext | ObjContext - deriving (Eq, Show) - -getIndent :: Formatter B.Builder -getIndent = indent `liftM` get - -setIndent :: B.Builder -> Formatter () -setIndent ind = modify $ \st -> st { indent = ind } - -getLineBreak :: Formatter Bool -getLineBreak = lineBreak `liftM` get - -setLineBreak :: Bool -> Formatter () -setLineBreak brk = modify $ \st -> st { lineBreak = brk } - -getNgs :: Formatter NodeGenState -getNgs = nodeGenSt `liftM` get - -setNgs :: NodeGenState -> Formatter () -setNgs ngs = modify $ \st -> st { nodeGenSt = ngs } - -getPrefixes :: Formatter NamespaceMap -getPrefixes = prefixes `liftM` getNgs - -getSubjs :: Formatter (SubjTree RDFLabel) -getSubjs = subjs `liftM` get - -setSubjs :: SubjTree RDFLabel -> Formatter () -setSubjs sl = modify $ \st -> st { subjs = sl } - -getProps :: Formatter (PredTree RDFLabel) -getProps = props `liftM` get - -setProps :: PredTree RDFLabel -> Formatter () -setProps ps = modify $ \st -> st { props = ps } - -{- -getObjs :: Formatter ([RDFLabel]) -getObjs = objs `liftM` get - -setObjs :: [RDFLabel] -> Formatter () -setObjs os = do - st <- get - put $ st { objs = os } --} - -getBnodesCheck :: Formatter [RDFLabel] -getBnodesCheck = bNodesCheck `liftM` get - -{- -addTrace :: String -> Formatter () -addTrace tr = do - st <- get - put $ st { traceBuf = tr : traceBuf st } --} - -{- -queueFormula :: RDFLabel -> Formatter () -queueFormula fn = do - st <- get - let fa = formAvail st - newState fv = st { - formAvail = mapDelete fa fn, - formQueue = (fn,fv) : formQueue st - } - case mapFindMaybe fn fa of - Nothing -> return () - Just v -> put (newState v) >> return () --} - -{- -Return the graph associated with the label and delete it -from the store, if there is an association, otherwise -return Nothing. - -extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) -extractFormula fn = do - st <- get - let fa = formAvail st - newState = st { formAvail=mapDelete fa fn } - case mapFindMaybe fn fa of - Nothing -> return Nothing - Just fv -> put newState >> return (Just fv) - --} - -{- -moreFormulae :: Formatter Bool -moreFormulae = do - st <- get - return $ not $ null (formQueue st) - -nextFormula :: Formatter (RDFLabel,RDFGraph) -nextFormula = do - st <- get - let (nf : fq) = formQueue st - put $ st { formQueue = fq } - return nf - --} - --- list has a length of 1 -len1 :: [a] -> Bool -len1 (_:[]) = True -len1 _ = False - -{-| -Given a set of statements and a label, return the details of the -RDF collection referred to by label, or Nothing. - -For label to be considered as representing a collection we require the -following conditions to hold (this is only to support the -serialisation using the '(..)' syntax and does not make any statement -about semantics of the statements with regard to RDF Collections): - - - there must be one rdf_first and one rdfRest statement - - there must be no other predicates for the label - --} -getCollection :: - SubjTree RDFLabel -- ^ statements organized by subject - -> RDFLabel -- ^ does this label represent a list? - -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) - -- ^ the statements with the elements removed; the - -- content elements of the collection (the objects of the rdf:first - -- predicate) and the nodes that represent the spine of the - -- collection (in reverse order, unlike the actual contents which are in - -- order). -getCollection subjList lbl = go subjList lbl ([],[]) - where - go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) - | otherwise = do - (pList1, sl') <- removeItem sl l - (pFirst, pList2) <- removeItem pList1 resRdfFirst - (pNext, pList3) <- removeItem pList2 resRdfRest - - -- QUS: could I include these checks implicitly in the pattern matches above? - -- ie instrad of (pFirst, pos1) <- .. - -- have ([content], pos1) <- ... - -- ? - if and [len1 pFirst, len1 pNext, null pList3] - then go sl' (head pNext) (head pFirst : cs, l : ss) - else Nothing - -{- -TODO: - -Should we change the preds/objs entries as well? - --} -extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) -extractList lctxt ln = do - osubjs <- getSubjs - oprops <- getProps - let mlst = getCollection osubjs' ln - - -- we only want to send in rdf:first/rdf:rest here - fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops - - osubjs' = - case lctxt of - SubjContext -> (ln, fprops) : osubjs - _ -> osubjs - - -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" - -- addTrace tr - case mlst of - -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext - Just (sl,ls,_) -> do - setSubjs sl - when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops - return (Just ls) - - Nothing -> return Nothing - -{-| -Removes the first occurrence of the item from the -association list, returning it's contents and the rest -of the list, if it exists. --} -removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) -removeItem os x = - let (as, bs) = break (\a -> fst a == x) os - in case bs of - ((_,b):bbs) -> Just (b, as ++ bbs) - [] -> Nothing - ----------------------------------------------------------------------- --- Define a top-level formatter function: ----------------------------------------------------------------------- - -formatGraphAsText :: RDFGraph -> T.Text -formatGraphAsText = L.toStrict . formatGraphAsLazyText - -formatGraphAsLazyText :: RDFGraph -> L.Text -formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder - -formatGraphAsBuilder :: RDFGraph -> B.Builder -formatGraphAsBuilder = formatGraphIndent "\n" True - -formatGraphIndent :: B.Builder -> Bool -> RDFGraph -> B.Builder -formatGraphIndent indnt flag gr = - let (res, _, _, _) = formatGraphDiag indnt flag gr - in res - --- | Format graph and return additional information -formatGraphDiag :: - B.Builder -- ^ indentation - -> Bool -- ^ are prefixes to be generated? - -> RDFGraph - -> (B.Builder, NodeGenLookupMap, Int, [String]) -formatGraphDiag indnt flag gr = - let fg = formatGraph indnt " .\n" False flag gr - ngs = emptyNgs { - prefixes = emptyLookupMap, - nodeGen = findMaxBnode gr - } - - (out, fgs) = runState fg (emptyTFS ngs) - ogs = nodeGenSt fgs - - in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs) - ----------------------------------------------------------------------- --- Formatting as a monad-based computation ----------------------------------------------------------------------- - -formatGraph :: - B.Builder -- indentation string - -> B.Builder -- text to be placed after final statement - -> Bool -- True if a line break is to be inserted at the start - -> Bool -- True if prefix strings are to be generated - -> RDFGraph -- graph to convert - -> Formatter B.Builder -formatGraph ind end dobreak dopref gr = do - setIndent ind - setLineBreak dobreak - setGraph gr - - fp <- if dopref - then formatPrefixes (getNamespaces gr) - else return mempty - more <- moreSubjects - if more - then do - fr <- formatSubjects - return $ mconcat [fp, fr, end] - else return fp - -formatPrefixes :: NamespaceMap -> Formatter B.Builder -formatPrefixes pmap = do - let mls = map (pref . keyVal) (listLookupMap pmap) - ls <- sequence mls - return $ mconcat ls - where - pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."] - pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."] - -{- -NOTE: -I expect there to be confusion below where I need to -convert from Text to Builder --} - -formatSubjects :: Formatter B.Builder -formatSubjects = do - sb <- nextSubject - sbstr <- formatLabel SubjContext sb - - flagP <- moreProperties - if flagP - then do - prstr <- formatProperties sb sbstr - flagS <- moreSubjects - if flagS - then do - fr <- formatSubjects - return $ mconcat [prstr, " .", fr] - else return prstr - - else do - txt <- nextLine sbstr - - flagS <- moreSubjects - if flagS - then do - fr <- formatSubjects - return $ mconcat [txt, " .", fr] - else return txt - -{- -TODO: now we are throwing a Builder around it is awkward to -get the length of the text to calculate the indentation - -So - - a) change the indentation scheme - b) pass around text instead of builder - -mkIndent :: L.Text -> L.Text -mkIndent inVal = L.replicate (L.length inVal) " " --} - -hackIndent :: B.Builder -hackIndent = " " - -formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder -formatProperties sb sbstr = do - pr <- nextProperty sb - prstr <- formatLabel PredContext pr - obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] - more <- moreProperties - let sbindent = hackIndent -- mkIndent sbstr - if more - then do - fr <- formatProperties sb sbindent - nl <- nextLine $ obstr `mappend` " ;" - return $ nl `mappend` fr - else nextLine obstr - -formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder -formatObjects sb pr prstr = do - ob <- nextObject sb pr - obstr <- formatLabel ObjContext ob - more <- moreObjects - if more - then do - let prindent = hackIndent -- mkIndent prstr - fr <- formatObjects sb pr prindent - nl <- nextLine $ mconcat [prstr, " ", obstr, ","] - return $ nl `mappend` fr - else return $ mconcat [prstr, " ", obstr] - -{- -Add a list inline. We are given the labels that constitute -the list, in order, so just need to display them surrounded -by (). --} -insertList :: [RDFLabel] -> Formatter B.Builder -insertList [] = return "()" -- not convinced this can happen -insertList xs = do - ls <- mapM (formatLabel ObjContext) xs - return $ mconcat ("( " : intersperse " " ls) `mappend` " )" - -{- -Add a blank node inline. --} - -insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder -insertBnode SubjContext lbl = do - -- a safety check - flag <- moreProperties - if flag - then do - txt <- (`mappend` "\n") `liftM` formatProperties lbl "" - return $ mconcat ["[] ", txt] - else error $ "Internal error: expected properties with label: " ++ show lbl - -insertBnode _ lbl = do - ost <- get - let osubjs = subjs ost - oprops = props ost - oobjs = objs ost - - (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs - - rprops = case bsubj of - [(_,rs)] -> rs - _ -> [] - - -- we essentially want to create a new subgraph - -- for this node but it's not as simple as that since - -- we could have something like - -- :a :b [ :foo [ :bar "xx" ] ] - -- so we still need to carry around the whole graph - -- - nst = ost { subjs = rsubjs, - props = rprops, - objs = [] - } - - put nst - flag <- moreProperties - txt <- if flag - then (`mappend` "\n") `liftM` formatProperties lbl "" - else return "" - - -- TODO: how do we restore the original set up? - -- I can't believe the following is sufficient - -- - nst' <- get - let slist = map fst $ subjs nst' - nsubjs = filter (\(l,_) -> l `elem` slist) osubjs - - put $ nst' { subjs = nsubjs, - props = oprops, - objs = oobjs - } - - -- TODO: handle indentation? - return $ mconcat ["[", txt, "]"] - ----------------------------------------------------------------------- --- Formatting helpers ----------------------------------------------------------------------- - -setGraph :: RDFGraph -> Formatter () -setGraph gr = do - st <- get - - let ngs0 = nodeGenSt st - pre' = mapMerge (prefixes ngs0) (getNamespaces gr) - ngs' = ngs0 { prefixes = pre' } - arcs = sortArcs $ getArcs gr - nst = st { graph = gr - , subjs = arcTree arcs - , props = [] - , objs = [] - -- , formAvail = getFormulae gr - , nodeGenSt = ngs' - , bNodesCheck = countBnodes arcs - } - - put nst - -hasMore :: (TurtleFormatterState -> [b]) -> Formatter Bool -hasMore lens = (not . null . lens) `liftM` get - -moreSubjects :: Formatter Bool -moreSubjects = hasMore subjs --- moreSubjects = (not . null . subjs) `liftM` get - -moreProperties :: Formatter Bool -moreProperties = hasMore props --- moreProperties = (not . null . props) `liftM` get - -moreObjects :: Formatter Bool -moreObjects = hasMore objs --- moreObjects = (not . null . objs) `liftM` get - -nextSubject :: Formatter RDFLabel -nextSubject = do - st <- get - - let sb:sbs = subjs st - nst = st { subjs = sbs - , props = snd sb - , objs = [] - } - - put nst - return $ fst sb - -nextProperty :: RDFLabel -> Formatter RDFLabel -nextProperty _ = do - st <- get - - let pr:prs = props st - nst = st { props = prs - , objs = snd pr - } - - put nst - return $ fst pr - -nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel -nextObject _ _ = do - st <- get - - let ob:obs = objs st - nst = st { objs = obs } - - put nst - return ob - -nextLine :: B.Builder -> Formatter B.Builder -nextLine str = do - ind <- getIndent - brk <- getLineBreak - if brk - then return $ ind `mappend` str - else do - -- After first line, always insert line break - setLineBreak True - return str - --- Format a label --- Most labels are simply displayed as provided, but there are a --- number of wrinkles to take care of here: --- (a) blank nodes automatically allocated on input, with node --- identifiers of the form of a digit string nnn. These are --- not syntactically valid, and are reassigned node identifiers --- of the form _nnn, where nnn is chosen so that is does not --- clash with any other identifier in the graph. --- (b) URI nodes: if possible, replace URI with qname, --- else display as --- (c) formula nodes (containing graphs). --- (d) use the "special-case" formats for integer/float/double --- literals. --- --- [[[TODO:]]] --- (d) generate multi-line literals when appropriate --- --- This is being updated to produce inline formula, lists and --- blank nodes. The code is not efficient. --- --- --- Note: There is a lot less customisation possible in Turtle than N3. --- - -formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder - -{- -The "[..]" conversion is done last, after "()" and "{}" checks. --} -formatLabel lctxt lab@(Blank (_:_)) = do - mlst <- extractList lctxt lab - case mlst of - Just lst -> insertList lst - Nothing -> do - -- NOTE: unlike N3 we do not properly handle "formula"/named graphs - -- also we only expand out bnodes into [...] format when it's a object. - -- although we need to handle [] for the subject. - nb1 <- getBnodesCheck - if lctxt /= PredContext && lab `notElem` nb1 - then insertBnode lctxt lab - else formatNodeId lab - --- formatLabel _ lab@(Res sn) = -formatLabel ctxt (Res sn) - | ctxt == PredContext && sn == rdfType = return "a" - | ctxt == ObjContext && sn == rdfNil = return "()" - | otherwise = do - pr <- getPrefixes - let nsuri = getScopeURI sn - local = getScopeLocal sn - premap = reverseLookupMap pr :: RevNamespaceMap - prefix = mapFindMaybe nsuri premap - - name = case prefix of - Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames - _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] - - return name - --- The canonical notation for xsd:double in XSD, with an upper-case E, --- does not match the syntax used in N3, so we need to convert here. --- Rather than converting back to a Double and then displaying that --- we just convert E to e for now. --- -formatLabel _ (Lit lit (Just dtype)) - | dtype == xsdDouble = return $ B.fromText $ T.toLower lit - | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit - | otherwise = return $ quoteText lit `mappend` formatAnnotation dtype -formatLabel _ (Lit lit Nothing) = return $ quoteText lit - -formatLabel _ lab = return $ B.fromString $ show lab - --- the annotation for a literal (ie type or language) -formatAnnotation :: ScopedName -> B.Builder -formatAnnotation a | isLang a = "@" `mappend` B.fromText (langTag a) - | otherwise = "^^" `mappend` showScopedName a - -{-| -Convert text into a format for display in Turtle. The idea -is to use one double quote unless three are needed, and to -handle adding necessary @\\@ characters, or conversion -for Unicode characters. --} -quoteText :: T.Text -> B.Builder -quoteText txt = - let st = T.unpack txt -- TODO: fix - qst = quoteB (n==1) st - n = if '\n' `elem` st || '"' `elem` st then 3 else 1 - qch = B.fromString (replicate n '"') - in mconcat [qch, qst, qch] - -formatNodeId :: RDFLabel -> Formatter B.Builder -formatNodeId lab@(Blank (lnc:_)) = - if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab -formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall - -mapBlankNode :: RDFLabel -> Formatter B.Builder -mapBlankNode lab = do - ngs <- getNgs - let cmap = nodeMap ngs - cval = nodeGen ngs - nv <- case mapFind 0 lab cmap of - 0 -> do - let nval = succ cval - nmap = mapAdd cmap (lab, nval) - setNgs $ ngs { nodeGen = nval, nodeMap = nmap } - return nval - - n -> return n - - -- TODO: is this what we want? - return $ "_:swish" `mappend` B.fromString (show nv) - --- TODO: need to be a bit more clever with this than we did in NTriples --- not sure the following counts as clever enough ... --- -showScopedName :: ScopedName -> B.Builder -{- -showScopedName (ScopedName n l) = - let uri = nsURI n ++ l - in quote uri --} -showScopedName = quoteB True . show - ----------------------------------------------------------------------- --- Graph-related helper functions ----------------------------------------------------------------------- - -newtype SortedArcs lb = SA [Arc lb] - -sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb -sortArcs = SA . sort - --- Rearrange a list of arcs into a tree of pairs which group together --- all statements for a single subject, and similarly for multiple --- objects of a common predicate. --- -arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb -arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as - where - spopair (Arc s p o) = (s,(p,o)) - -{- -arcTree as = map spopair $ sort as - where - spopair (Arc s p o) = (s,[(p,[o])]) --} - --- Rearrange a list of pairs so that multiple occurrences of the first --- are commoned up, and the supplied function is applied to each sublist --- with common first elements to obtain the corresponding second value -commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] -commonFstEq f ps = - [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] - where - fstEq (f1,_) (f2,_) = f1 == f2 - -findMaxBnode :: RDFGraph -> Int -findMaxBnode = maximum . map getAutoBnodeIndex . labels - -getAutoBnodeIndex :: RDFLabel -> Int -getAutoBnodeIndex (Blank ('_':lns)) = res where - -- cf. prelude definition of read s ... - res = case [x | (x,t) <- reads lns, ("","") <- lex t] of - [x] -> x - _ -> 0 -getAutoBnodeIndex _ = 0 - -{- -Find all blank nodes that occur - - any number of times as a subject - - 0 or 1 times as an object - -Such nodes can be output using the "[..]" syntax. To make it simpler -to check we actually store those nodes that can not be expanded. - -Note that we do not try and expand any bNode that is used in -a predicate position. - -Should probably be using the SubjTree RDFLabel structure but this -is easier for now. - --} - -countBnodes :: SortedArcs RDFLabel -> [RDFLabel] -countBnodes (SA as) = snd (foldl' ctr ([],[]) as) - where - -- first element of tuple are those blank nodes only seen once, - -- second element those blank nodes seen multiple times - -- - inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (l:b1s, bms) - inc b _ = b - - -- if the bNode appears as a predicate we instantly add it to the - -- list of nodes not to expand, even if only used once - incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (b1s, l:bms) - incP b _ = b - - ctr orig (Arc _ p o) = inc (incP orig p) o - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/TurtleParser.hs b/src/Swish/RDF/TurtleParser.hs deleted file mode 100644 --- a/src/Swish/RDF/TurtleParser.hs +++ /dev/null @@ -1,1062 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -- only used in 'fromMaybe "" mbase' line of parseN3 - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : TurtleParser --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This Module implements a Turtle parser (see [1]), returning a --- new 'RDFGraph' consisting of triples and namespace information parsed from --- the supplied input string, or an error indication. --- --- REFERENCES: --- --- 1 --- Turtle, Terse RDF Triple Language --- W3C Working Draft 09 August 2011 () --- --- Notes: --- --- At present there is a lot of overlap with the N3 Parser. --- --------------------------------------------------------------------------------- - -module Swish.RDF.TurtleParser - ( ParseResult - , parseTurtle - , parseTurtlefromText - {- - , parseAnyfromText - , parseTextFromText, parseAltFromText - , parseNameFromText -- , parsePrefixFromText - , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText - -} - - {- - -- * Exports for parsers that embed Turtle in a bigger syntax - , TurtleParser, TurtleState(..), SpecialMap - - , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions - , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct - , quickVariable -- was varid - , lexUriRef - , document, subgraph - , newBlankNode - -} - ) -where - -import Swish.RDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , ToRDFLabel(..) - , NamespaceMap - , addArc - , setNamespaces - , emptyRDFGraph - ) - -import Swish.RDF.GraphClass (arc) - -import Swish.Utils.LookupMap - ( LookupMap(..) - , LookupEntryClass(..) - , mapFindMaybe, mapReplaceOrAdd, mapAdd, mapReplace ) - -import Swish.Utils.Namespace - ( Namespace, makeNamespace - , ScopedName - , getScopeNamespace - , getScopedNameURI - , getScopeNamespace - , makeURIScopedName - , makeNSScopedName - ) - -import Swish.RDF.Vocabulary - ( langName - , rdfType - , rdfFirst, rdfRest, rdfNil - , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble - , defaultBase - ) - -import Swish.RDF.RDFParser - ( ParseResult - , runParserWithError - , ignore - , noneOf - , char - , ichar - , string - , stringT - , symbol - , isymbol - , lexeme - , whiteSpace - , mkTypedLit - , hex4 - , hex8 - , appendURIs - ) - -import Control.Applicative -import Control.Monad (foldM) - -import Network.URI (URI(..), parseURIReference) - -import Data.Char (ord) -import Data.Maybe (fromMaybe, fromJust) - -import qualified Data.Text as T -import qualified Data.Text.Lazy as L -import Text.ParserCombinators.Poly.StateText - ----------------------------------------------------------------------- --- Define parser state and helper functions ----------------------------------------------------------------------- - --- | Turtle parser state -data TurtleState = TurtleState - { graphState :: RDFGraph -- Graph under construction - , prefixUris :: NamespaceMap -- namespace prefix mapping table - , baseUri :: URI -- base URI - , nodeGen :: Int -- blank node id generator - } deriving Show - --- | Functions to update TurtleState vector (use with stUpdate) - -setPrefix :: Maybe T.Text -> URI -> TurtleState -> TurtleState -setPrefix pre uri st = st { prefixUris=p' } - where - p' = mapReplaceOrAdd (makeNamespace pre uri) (prefixUris st) - --- | Change the base -setBase :: URI -> TurtleState -> TurtleState -setBase buri st = st { baseUri = buri } - --- Functions to access state: - --- | Return the default prefix -getDefaultPrefix :: TurtleParser Namespace -getDefaultPrefix = do - s <- stGet - case getPrefixURI s Nothing of - Just uri -> return $ makeNamespace Nothing uri - _ -> failBad "No default prefix defined; how unexpected (probably a programming error)!" - --- Map prefix to URI (naming needs a scrub here) -getPrefixURI :: TurtleState -> Maybe T.Text -> Maybe URI -getPrefixURI st pre = mapFindMaybe pre (prefixUris st) - -findPrefixNamespace :: Maybe L.Text -> TurtleParser Namespace -findPrefixNamespace (Just p) = findPrefix (L.toStrict p) -findPrefixNamespace Nothing = getDefaultPrefix - --- Return function to update graph in Turtle parser state, --- using the supplied function of a graph --- -updateGraph :: (RDFGraph -> RDFGraph) -> TurtleState -> TurtleState -updateGraph f s = s { graphState = f (graphState s) } - ----------------------------------------------------------------------- --- Define top-level parser function: --- accepts a string and returns a graph or error ----------------------------------------------------------------------- - -type TurtleParser a = Parser TurtleState a - --- | Parse as Turtle (with no real base URI). --- --- See 'parseTurtle' if you need to provide a base URI. --- -parseTurtlefromText :: - L.Text -- ^ input in N3 format. - -> ParseResult -parseTurtlefromText = flip parseTurtle Nothing - --- | Parse a string with an optional base URI. --- --- Unlike 'parseN3' we treat the base URI as a URI and not --- a QName. --- -parseTurtle :: - L.Text -- ^ input in N3 format. - -> Maybe URI -- ^ optional base URI - -> ParseResult -parseTurtle txt mbase = parseAnyfromText turtleDoc mbase txt - -hashURI :: URI -hashURI = fromJust $ parseURIReference "#" - -emptyState :: - Maybe URI -- ^ starting base for the graph - -> TurtleState -emptyState mbase = - let pmap = LookupMap [makeNamespace Nothing hashURI] - buri = fromMaybe (getScopedNameURI defaultBase) mbase - in TurtleState - { graphState = emptyRDFGraph - , prefixUris = pmap - , baseUri = buri - , nodeGen = 0 - } - --- | Function to supply initial context and parse supplied term. --- -parseAnyfromText :: - TurtleParser a -- ^ parser to apply - -> Maybe URI -- ^ base URI of the input, or @Nothing@ to use default base value - -> L.Text -- ^ input to be parsed - -> Either String a -parseAnyfromText parser mbase = runParserWithError parser (emptyState mbase) - -newBlankNode :: TurtleParser RDFLabel -newBlankNode = do - n <- stQuery (succ . nodeGen) - stUpdate $ \s -> s { nodeGen = n } - return $ Blank (show n) - -{- -This has been made tricky by the attempt to remove the default list -of prefixes from the starting point of a parse and the subsequent -attempt to add every new namespace we come across to the parser state. - -So we add in the original default namespaces for testing, since -this routine is really for testing. - -addTestPrefixes :: TurtleParser () -addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map - --} - --- helper routines - -comma, semiColon , fullStop :: TurtleParser () -comma = isymbol "," -semiColon = isymbol ";" -fullStop = isymbol "." - -sQuot, dQuot, sQuot3, dQuot3 :: TurtleParser () -sQuot = ichar '\'' -dQuot = ichar '"' -sQuot3 = ignore $ string "'''" -dQuot3 = ignore $ string "\"\"\"" - -match :: (Ord a) => a -> [(a,a)] -> Bool -match v = any (\(l,h) -> v >= l && v <= h) - --- a specialization of bracket -br :: String -> String -> TurtleParser a -> TurtleParser a -br lsym rsym = bracket (symbol lsym) (symbol rsym) - --- this is a lot simpler than N3 -atWord :: T.Text -> TurtleParser () -atWord s = char '@' *> lexeme (stringT s) *> pure () - -{- -Add statement to graph in the parser state; there is a special case -for the special-case literals in the grammar since we need to ensure -the necessary namespaces (in other words xsd) are added to the -namespace store. --} - -addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> TurtleParser () -addStatement s p o@(Lit _ (Just dtype)) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do - ost <- stGet - let stmt = arc s p o - oldp = prefixUris ost - ogs = graphState ost - newp = mapReplaceOrAdd (getScopeNamespace dtype) oldp - stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } -addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) - -isaz, isAZ, isaZ, is09, isaZ09 :: Char -> Bool -isaz c = c >= 'a' && c <= 'z' -isAZ c = c >= 'A' && c <= 'Z' -isaZ c = isaz c || isAZ c -is09 c = c >= '0' && c <= '9' -isaZ09 c = isaZ c || is09 c - -{- -Convert a string representing a double into canonical -XSD form. The input string is assumed to be syntactically -valid so we use read rather than reads. We use the String read -rather than Text one because of issues I have had in some tests -with the accuracy of the Text one. --} -d2s :: L.Text -> RDFLabel -d2s = - let conv :: String -> Double - conv = read - in toRDFLabel . conv . L.unpack - -{- -Since operatorLabel can be used to add a label with an -unknown namespace, we need to ensure that the namespace -is added if not known. If the namespace prefix is already -in use then it is over-written (rather than add a new -prefix for the label). - -TODO: - - could we use the reverse lookupmap functionality to - find if the given namespace URI is in the namespace - list? If it is, use it's key otherwise do a - mapReplaceOrAdd for the input namespace. - --} -operatorLabel :: ScopedName -> TurtleParser RDFLabel -operatorLabel snam = do - st <- stGet - let sns = getScopeNamespace snam - opmap = prefixUris st - pkey = entryKey sns - pval = entryVal sns - - rval = Res snam - - -- the lookup and the replacement could be fused - case mapFindMaybe pkey opmap of - Just val | val == pval -> return rval - | otherwise -> do - stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } - return rval - - _ -> do - stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } - return rval - -findPrefix :: T.Text -> TurtleParser Namespace -findPrefix pre = do - st <- stGet - case mapFindMaybe (Just pre) (prefixUris st) of - Just uri -> return $ makeNamespace (Just pre) uri - Nothing -> failBad $ "Undefined prefix '" ++ T.unpack pre ++ ":'." - -{- - -Syntax productions; the Turtle NBF grammar elements are from -http://www.w3.org/TR/turtle/turtle.bnf - -The element names are converted to match Haskell syntax -and idioms where possible: - - - camel Case rather than underscores and all upper case - - - upper-case identifiers prepended by _ after above form - --} - -{- -[1] turtleDoc ::= (statement)* --} -turtleDoc :: TurtleParser RDFGraph -turtleDoc = mkGr <$> (whiteSpace *> many statement *> eof *> stGet) - where - mkGr s = setNamespaces (prefixUris s) (graphState s) - -{- -[2] statement ::= directive "." - | triples "." --} -statement :: TurtleParser () -statement = (directive <|> triples) *> fullStop - -{- -[3] directive ::= prefixID - | base --} -directive :: TurtleParser () -directive = lexeme (prefixID <|> base) - -{- -[4] prefixID ::= PREFIX PNAME_NS IRI_REF --} -prefixID :: TurtleParser () -prefixID = do - _prefix - p <- lexeme _pnameNS - u <- _iriRef - stUpdate (setPrefix (fmap L.toStrict p) u) - -{- -[5] base ::= BASE IRI_REF --} -base :: TurtleParser () -base = _base >> _iriRef >>= stUpdate . setBase - -{- -[6] triples ::= subject predicateObjectList --} - -triples :: TurtleParser () -triples = subject >>= predicateObjectList - -{- -[7] predicateObjectList ::= verb objectList ( ";" verb objectList )* (";")? --} - -predicateObjectList :: RDFLabel -> TurtleParser () -predicateObjectList subj = - let term = verb >>= objectList subj - in sepBy1 term semiColon *> ignore (optional semiColon) - -- in sepBy1 (lexeme term) semiColon *> ignore (optional semiColon) - -{- -[8] objectList ::= object ( "," object )* --} - -objectList :: RDFLabel -> RDFLabel -> TurtleParser () -objectList subj prd = sepBy1 object comma >>= mapM_ (addStatement subj prd) - -{- -[9] verb ::= predicate - | "a" --} - -verb :: TurtleParser RDFLabel -verb = predicate <|> (lexeme (char 'a') *> operatorLabel rdfType) - -{- -[10] subject ::= IRIref - | blank --} - -subject :: TurtleParser RDFLabel -subject = (Res <$> iriref) <|> blank - -{- -[11] predicate ::= IRIref --} - -predicate :: TurtleParser RDFLabel -predicate = Res <$> iriref - -{- -[12] object ::= IRIref - | blank - | literal --} - -object :: TurtleParser RDFLabel -object = (Res <$> iriref) <|> blank <|> literal - -{- -[13] literal ::= RDFLiteral - | NumericLiteral - | BooleanLiteral --} - -literal :: TurtleParser RDFLabel -literal = lexeme $ rdfLiteral <|> numericLiteral <|> booleanLiteral - -{- -[14] blank ::= BlankNode - | blankNodePropertyList - | collection - -Since both BlankNode and blankNodePropertyList can match '[ ... ]' we pull -that out and treat this as - - blank ::= BLANK_NODE_LABEL - | "[" (predicateObjectList | WS*) "]" - | collection - -blank :: TurtleParser RDFLabel -blank = lexeme (blankNode <|> blankNodePropertyList <|> collection) - --} - -blank :: TurtleParser RDFLabel -blank = lexeme (_blankNodeLabel - <|> - bracket (char '[') (char ']') handleBlankNode - <|> - collection - ) - -{- -[15] blankNodePropertyList ::= "[" predicateObjectList "]" - -We now match the brackets in the parent rule. - -blankNodePropertyList :: TurtleParser RDFLabel -blankNodePropertyList = do - bNode <- newBlankNode - -- br "[" "]" (predicateObjectList bNode) - bracket (satisfy (=='[')) - (satisfy (==']')) - (_manyws *> predicateObjectList bNode *> _manyws) - -- ignore (optional _manyws) -- TODO: this is a hack - return bNode - --} - -handleBlankNode :: TurtleParser RDFLabel -handleBlankNode = do - bNode <- newBlankNode - _manyws - ignore $ optional $ predicateObjectList bNode - _manyws - return bNode - - -{- -[16] collection ::= "(" object* ")" --} - -collection :: TurtleParser RDFLabel -collection = do - os <- br "(" ")" (many object) - eNode <- operatorLabel rdfNil - case os of - [] -> return eNode - - (x:xs) -> do - sNode <- newBlankNode - first <- operatorLabel rdfFirst - addStatement sNode first x - lNode <- foldM addElem sNode xs - rest <- operatorLabel rdfRest - addStatement lNode rest eNode - return sNode - - where - addElem prevNode curElem = do - bNode <- newBlankNode - first <- operatorLabel rdfFirst - rest <- operatorLabel rdfRest - addStatement prevNode rest bNode - addStatement bNode first curElem - return bNode - -{- -[17] ::= "@base" --} - -_base :: TurtleParser () -_base = atWord "base" - -{- -[18] ::= "@prefix" --} - -_prefix :: TurtleParser () -_prefix = atWord "prefix" - -{- -[19] ::= ( "\\u" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) - | ( "\\U" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] - [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) - --} - -_uchar :: TurtleParser Char -_uchar = char '\\' *> _uchar' - -_uchar' :: TurtleParser Char -_uchar' = (char 'u' *> hex4) <|> (char 'U' *> hex8) - -{- -[60s] RDFLiteral ::= String ( LANGTAG | ( "^^" IRIref ) )? --} - -rdfLiteral :: TurtleParser RDFLabel -rdfLiteral = do - lbl <- turtleString - opt <- optional (_langTag <|> (string "^^" *> iriref)) - return $ Lit (L.toStrict lbl) opt - -{- -[61s] NumericLiteral ::= NumericLiteralUnsigned - | NumericLiteralPositive - | NumericLiteralNegative --} - -numericLiteral :: TurtleParser RDFLabel -numericLiteral = numericLiteralNegative <|> numericLiteralPositive <|> numericLiteralUnsigned - -{- -[62s] NumericLiteralUnsigned ::= INTEGER - | DECIMAL - | DOUBLE --} - -numericLiteralUnsigned :: TurtleParser RDFLabel -numericLiteralUnsigned = - d2s <$> _double - <|> - (mkTypedLit xsdDecimal . L.toStrict <$> _decimal) - <|> - (mkTypedLit xsdInteger . L.toStrict <$> _integer) - -{- -[63s] NumericLiteralPositive ::= INTEGER_POSITIVE - | DECIMAL_POSITIVE - | DOUBLE_POSITIVE --} - -numericLiteralPositive :: TurtleParser RDFLabel -numericLiteralPositive = - d2s <$> _doublePositive - <|> - (mkTypedLit xsdDecimal . L.toStrict <$> _decimalPositive) - <|> - (mkTypedLit xsdInteger . L.toStrict <$> _integerPositive) - -{- -[64s] NumericLiteralNegative ::= INTEGER_NEGATIVE - | DECIMAL_NEGATIVE - | DOUBLE_NEGATIVE --} - -numericLiteralNegative :: TurtleParser RDFLabel -numericLiteralNegative = - d2s <$> _doubleNegative - <|> - (mkTypedLit xsdDecimal . L.toStrict <$> _decimalNegative) - <|> - (mkTypedLit xsdInteger . L.toStrict <$> _integerNegative) - -{- -[65s] BooleanLiteral ::= "true" - | "false" --} - -booleanLiteral :: TurtleParser RDFLabel -booleanLiteral = mkTypedLit xsdBoolean . T.pack <$> (string "true" <|> string "false") - -{- -[66s] String ::= STRING_LITERAL1 - | STRING_LITERAL2 - | STRING_LITERAL_LONG1 - | STRING_LITERAL_LONG2 --} - -turtleString :: TurtleParser L.Text -turtleString = - lexeme ( - _stringLiteralLong1 <|> _stringLiteral1 <|> - _stringLiteralLong2 <|> _stringLiteral2) - -{- -[67s] IRIref ::= IRI_REF - | PrefixedName --} - -iriref :: TurtleParser ScopedName -iriref = lexeme ((makeURIScopedName <$> _iriRef) <|> prefixedName) - -{- -[68s] PrefixedName ::= PNAME_LN - | PNAME_NS --} - -prefixedName :: TurtleParser ScopedName -prefixedName = - _pnameLN <|> - flip makeNSScopedName T.empty <$> (_pnameNS >>= findPrefixNamespace) - -{- -[69s] BlankNode ::= BLANK_NODE_LABEL - | ANON - -blankNode :: TurtleParser RDFLabel -blankNode = lexeme (_blankNodeLabel <|> _anon) - --} - -{- -[70s] ::= "<" ( [^<>\"{}|^`\\] - [#0000- ] | UCHAR )* ">" - -Read [#0000- ] as [#x00-#x20] from -http://lists.w3.org/Archives/Public/public-rdf-comments/2011Aug/0011.html - -Unlike N3, whitespace is significant within the surrounding <>. - -At present relying on Network.URI to define what characters are valid -in a URI. This is not necessarily ideal. --} - -_iriRef :: TurtleParser URI -_iriRef = do - utxt <- bracket (char '<') (char '>') $ manySatisfy (/= '>') -- TODO: fix - let ustr = L.unpack utxt - case parseURIReference ustr of - Nothing -> fail $ "Unable to convert <" ++ ustr ++ "> to a URI" - Just uref -> do - s <- stGet - either fail return $ appendURIs (baseUri s) uref - -{- -[71s] ::= (PN_PREFIX)? ":" --} - -_pnameNS :: TurtleParser (Maybe L.Text) -_pnameNS = optional _pnPrefix <* char ':' - -{- -[72s] ::= PNAME_NS PN_LOCAL --} - -_pnameLN :: TurtleParser ScopedName -_pnameLN = makeNSScopedName - <$> (_pnameNS >>= findPrefixNamespace) - <*> fmap L.toStrict _pnLocal - -{- -[73s] ::= "_:" PN_LOCAL --} - -_blankNodeLabel :: TurtleParser RDFLabel -_blankNodeLabel = (Blank . L.unpack) <$> (string "_:" *> _pnLocal) - -{- - -These are unused in the grammar. - -[74s] ::= "?" VARNAME -[75s] ::= "$" VARNAME --} - -{- -[76s] ::= BASE - | PREFIX - | "@" [a-zA-Z]+ ( "-" [a-zA-Z0-9]+ )* - -I am ignoring the BASE and PREFIX lines here as they don't make sense to me. --} - -_langTag :: TurtleParser ScopedName -_langTag = do - ichar '@' - h <- many1Satisfy isaZ - mt <- optional (L.cons <$> char '-' <*> many1Satisfy isaZ09) - return $ langName $ L.toStrict $ L.append h (fromMaybe L.empty mt) - -{- -[77s] ::= [0-9]+ --} - -_integer :: TurtleParser L.Text -_integer = many1Satisfy is09 - -{- -[78s] ::= [0-9]+ "." [0-9]* - | "." [0-9]+ - -We try to produce a canonical form for the -numbers. --} - -_decimal :: TurtleParser L.Text -_decimal = - let dpart = L.cons <$> char '.' <*> (fromMaybe "0" <$> optional _integer) - in - (L.append <$> _integer <*> dpart) - <|> - (L.append "0." <$> (char '.' *> _integer)) - -{- -[79s] ::= [0-9]+ "." [0-9]* EXPONENT - | "." ( [0-9] )+ EXPONENT - | ( [0-9] )+ EXPONENT - -Unlike _decimal, the canonical form is enforced -later on, although it could be done here. --} - -_double :: TurtleParser L.Text -_double = - (L.append <$> _decimal <*> _exponent) - <|> - (L.append <$> _integer <*> _exponent) - -{- -[80s] ::= "+" INTEGER -[81s] ::= "+" DECIMAL -[82s] ::= "+" DOUBLE --} - -_integerPositive, _decimalPositive, _doublePositive :: TurtleParser L.Text -_integerPositive = char '+' *> _integer -_decimalPositive = char '+' *> _decimal -_doublePositive = char '+' *> _double - -{- -[83s] ::= "-" INTEGER -[84s] ::= "-" DECIMAL -[85s] ::= "-" DOUBLE --} - -_integerNegative, _decimalNegative, _doubleNegative :: TurtleParser L.Text -_integerNegative = L.cons <$> char '-' <*> _integer -_decimalNegative = L.cons <$> char '-' <*> _decimal -_doubleNegative = L.cons <$> char '-' <*> _double - -{- -[86s] ::= [eE] [+-]? [0-9]+ --} - -_exponent :: TurtleParser L.Text -_exponent = do - ignore $ satisfy (`elem` "eE") - ms <- optional (satisfy (`elem` "+-")) - e <- _integer - case ms of - Just '-' -> return $ L.append "E-" e - _ -> return $ L.cons 'E' e - -{- -[87s] ::= "'" ( ( [^'\\\n\r] ) | ECHAR | UCHAR )* "'" -[88s] ::= '"' ( ( [^\"\\\n\r] ) | ECHAR | UCHAR )* '"' -[89s] ::= "'''" ( ( "'" | "''" )? ( [^'\\] | ECHAR | UCHAR ) )* "'''" -[90s] ::= '"""' ( ( '"' | '""' )? ( [^\"\\] | ECHAR | UCHAR ) )* '"""' --} - -_stringLiteral1, _stringLiteral2 :: TurtleParser L.Text -_stringLiteral1 = _stringIt sQuot (_tChars "'\\\n\r") -_stringLiteral2 = _stringIt dQuot (_tChars "\"\\\n\r") - -_stringLiteralLong1, _stringLiteralLong2 :: TurtleParser L.Text -_stringLiteralLong1 = _stringItLong sQuot3 (_tCharsLong '\'' "'\\") -_stringLiteralLong2 = _stringItLong dQuot3 (_tCharsLong '"' "\"\\") - -_stringIt :: TurtleParser a -> TurtleParser Char -> TurtleParser L.Text -_stringIt sep chars = L.pack <$> bracket sep sep (many chars) - -_stringItLong :: TurtleParser a -> TurtleParser L.Text -> TurtleParser L.Text -_stringItLong sep chars = L.concat <$> bracket sep sep (many chars) - -_tChars :: String -> TurtleParser Char -_tChars excl = (char '\\' *> (_echar' <|> _uchar')) - <|> noneOf excl - -_tCharsLong :: Char -> String -> TurtleParser L.Text -_tCharsLong c excl = do - mq <- optional $ oneOrTwo c - r <- _tChars excl - return $ L.append (fromMaybe L.empty mq) (L.singleton r) - -oneOrTwo :: Char -> TurtleParser L.Text -oneOrTwo c = do - a <- char c - mb <- optional (char c) - case mb of - Just b -> return $ L.pack [a,b] - _ -> return $ L.singleton a - -{- -[91s] ::= "\\" [tbnrf\\\"'] --} - -_echar :: TurtleParser Char -_echar = char '\\' *> _echar' - -_echar' :: TurtleParser Char -_echar' = - (char 't' *> pure '\t') <|> - (char 'b' *> pure '\b') <|> - (char 'n' *> pure '\n') <|> - (char 'r' *> pure '\r') <|> - (char '\\' *> pure '\\') <|> - (char '"' *> pure '"') <|> - (char '\'' *> pure '\'') - - -{- - -Unused. - -[92s] ::= "(" (WS)* ")" --} - -{- -[93s] ::= " " - | "\t" - | "\r" - | "\n" - -_ws :: TurtleParser () -_ws = ignore $ satisfy (`elem` " \t\r\n") - --} - -_manyws :: TurtleParser () -_manyws = ignore $ manySatisfy (`elem` " \t\r\n") - -{- -[94s] ::= "[" (WS)* "]" - -Unused as we do not support the use of ANON in the BlankNode -terminal. - -_anon :: TurtleParser RDFLabel -_anon = br "[" "]" _manyws *> newBlankNode - --} - -{- -[95s] ::= [A-Z] - | [a-z] - | [#00C0-#00D6] - | [#00D8-#00F6] - | [#00F8-#02FF] - | [#0370-#037D] - | [#037F-#1FFF] - | [#200C-#200D] - | [#2070-#218F] - | [#2C00-#2FEF] - | [#3001-#D7FF] - | [#F900-#FDCF] - | [#FDF0-#FFFD] - | [#10000-#EFFFF] - | UCHAR - -TODO: may want to make this a Char -> Bool selector for -use with manySatisfy rather than a combinator. --} - -_pnCharsBase :: TurtleParser Char -_pnCharsBase = - let f c = let i = ord c - in isaZ c || - match i [(0xc0, 0xd6), (0xd8, 0xf6), (0xf8, 0x2ff), - (0x370, 0x37d), (0x37f, 0x1fff), (0x200c, 0x200d), - (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), - (0xf900, 0xfdcf), (0xfdf0, 0xfffd), (0x10000, 0xeffff)] - in satisfy f <|> _uchar - -{- -[96s] ::= PN_CHARS_BASE - | "_" --} - -_pnCharsU :: TurtleParser Char -_pnCharsU = _pnCharsBase <|> char '_' - -{- - -Only used in VAR1/2 rules which are themselves unused. - -Unused in the grammar (other than -[97s] ::= ( PN_CHARS_U | [0-9] ) ( PN_CHARS_U | [0-9] | #00B7 | [#0300-#036F] | [# - 203F-#2040] )* --} - -{- -[98s] ::= PN_CHARS_U - | "-" - | [0-9] - | #00B7 - | [#0300-#036F] - | [#203F-#2040] --} - -_pnChars :: TurtleParser Char -_pnChars = - _pnCharsU - <|> - satisfy (\c -> let i = ord c - in c == '-' || (c >= '0' && c <= '9') || i == 0xb7 || - match i [(0x0300, 0x036f), (0x203f, 0x2040)]) - -{- -[99s] ::= PN_CHARS_BASE ( ( PN_CHARS | "." )* PN_CHARS )? --} - -_pnPrefix :: TurtleParser L.Text -_pnPrefix = L.cons <$> _pnCharsBase <*> _pnRest - -{- -[100s] ::= ( PN_CHARS_U | [0-9] ) ( ( PN_CHARS | "." )* PN_CHARS )? --} - -_pnLocal :: TurtleParser L.Text -_pnLocal = L.cons <$> (_pnCharsU <|> satisfy is09) - <*> _pnRest - -{- -Extracted from PN_PREFIX and PN_LOCAL is - - :== ( ( PN_CHARS | "." )* PN_CHARS )? - -We assume below that the match is only ever done for small strings, so -the cost of the foldr isn't likely to be large. Let's see how well -this assumption holds up. - --} - -_pnRest :: TurtleParser L.Text -_pnRest = do - lbl <- many (_pnChars <|> char '.') - let (nret, lclean) = clean lbl - - -- a simple difference list implementation - edl = id - snocdl x xs = xs . (x:) - appenddl = (.) - replicatedl n x = (replicate n x ++) - - -- this started out as a simple automaton/transducer from - -- http://www.haskell.org/pipermail/haskell-cafe/2011-September/095347.html - -- but then I decided to complicate it - -- - clean :: String -> (Int, String) - clean = go 0 edl - where - go n acc [] = (n, acc []) - go n acc ('.':xs) = go (n+1) acc xs - go 0 acc (x:xs) = go 0 (snocdl x acc) xs - go n acc (x:xs) = go 0 (appenddl acc (snocdl x (replicatedl n '.'))) xs - - reparse $ L.replicate (fromIntegral nret) (L.singleton '.') - return $ L.pack lclean - -{- -Original from - - chop = go 0 [] - where - -- go :: State -> Stack -> String -> String - go 0 _ [] = [] - go 0 _ (x:xs) - | isSpace x = go 1 [x] xs - | otherwise = x : go 0 xs - - go 1 ss [] = [] - go 1 ss (x:xs) - | isSpace c = go 1 (x:ss) xs - | otherwise = reverse ss ++ x : go 0 xs - --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/VarBinding.hs b/src/Swish/RDF/VarBinding.hs --- a/src/Swish/RDF/VarBinding.hs +++ b/src/Swish/RDF/VarBinding.hs @@ -1,430 +1,75 @@ -{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances, OverloadedStrings #-} -{-# LANGUAGE FlexibleInstances #-} -- needed for ghc 7.12 +{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : VarBinding --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : MultiParamTypeClasses, TypeSynonymInstances, OverloadedStrings, FlexibleInstances +-- Portability : OverloadedStrings -- --- This module defines functions for representing and manipulating query --- binding variable sets. This is the key data that mediates between --- query and back substitution when performing inferences. A framework --- of query variable modifiers is provided that can be used to --- implement richer inferences, such as filtering of query results, --- or replacing values based on known relationships. +-- This module instantiates the `VarBinding` types and methods for use +-- with RDF graph labels. -- -------------------------------------------------------------------------------- +-- See module RDFQueryTest for test cases. + module Swish.RDF.VarBinding - ( VarBinding(..), nullVarBinding - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings, addVarBinding - , VarBindingModify(..), OpenVarBindingModify - , vbmCompatibility, vbmCompose - , composeSequence, findCompositions, findComposition - , VarBindingFilter(..) - , makeVarFilterModify - , makeVarTestFilter, makeVarCompareFilter - , varBindingId, nullVarBindingModify - , varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE + ( RDFVarBinding + , RDFVarBindingModify, RDFOpenVarBindingModify, RDFOpenVarBindingModifyMap + , RDFVarBindingFilter + , nullRDFVarBinding + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp ) where -import Swish.Utils.LookupMap - ( LookupEntryClass(..) - , makeLookupMap, mapFindMaybe - ) +import Swish.VarBinding (VarBinding(..), VarBindingModify(..), OpenVarBindingModify, VarBindingFilter(..)) +import Swish.VarBinding (nullVarBinding, applyVarBinding, makeVarTestFilter) -import Swish.Utils.Namespace (ScopedName, getScopeLocal) +import Swish.RDF.Graph + ( RDFLabel(..) + , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral + , isDatatyped, isMemberProp, isUri, isBlank + ) import Swish.RDF.Vocabulary (swishName) -import Swish.Utils.ListHelpers (equiv, subset, flist, headOrNothing, permutations) -import Data.Maybe (mapMaybe, fromMaybe, isJust, fromJust, listToMaybe) - -import Data.List (find, intersect, union, (\\), foldl') - -import Data.Monoid (mconcat) - --- import qualified Data.Text as T +import Data.LookupMap (LookupMap(..)) ------------------------------------------------------------ --- Query variable bindings +-- Types for RDF query variable bindings and modifiers ------------------------------------------------------------ --- TODO: is it worth making a Monoid instance of VarBinding? - --- |VarBinding is the type of an arbitrary variable bindings --- value, where the type of the bound values is not specified. --- -data VarBinding a b = VarBinding - { vbMap :: a -> Maybe b - , vbEnum :: [(a,b)] - , vbNull :: Bool - } - --- |VarBinding is an instance of class Eq, so that variable --- bindings can be compared for equivalence --- -instance (Eq a, Eq b) => Eq (VarBinding a b) where - vb1 == vb2 = vbEnum vb1 `equiv` vbEnum vb2 - --- |VarBinding is an instance of class Show, so that variable --- bindings can be displayed --- -instance (Show a, Show b) => Show (VarBinding a b) where - show = show . vbEnum +-- |@RDFVarBinding@ is the specific type type of a variable +-- binding value used with RDF graph queries. +type RDFVarBinding = VarBinding RDFLabel RDFLabel -- | maps no query variables. --- -nullVarBinding :: VarBinding a b -nullVarBinding = VarBinding - { vbMap = const Nothing - , vbEnum = [] - , vbNull = True - } - --- |Return a list of the variables bound by a supplied variable binding --- -boundVars :: VarBinding a b -> [a] -boundVars = map fst . vbEnum - --- |VarBinding subset function, tests to see if one query binding --- is a subset of another; i.e. every query variable mapping defined --- by one is also defined by the other. --- -subBinding :: (Eq a, Eq b) => VarBinding a b -> VarBinding a b -> Bool -subBinding vb1 vb2 = vbEnum vb1 `subset` vbEnum vb2 - --- |Function to make a variable binding from a list of --- pairs of variable and corresponding assigned value. --- -makeVarBinding :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> VarBinding a b -makeVarBinding vrbs = - if null vrbs then nullVarBinding -- (nullVarBinding :: VarBinding a b) - else VarBinding - { vbMap = selectFrom vrbs - , vbEnum = vrbs - , vbNull = null vrbs - } - where - selectFrom = flip mapFindMaybe . makeLookupMap - -- selectFrom bs is the VarBinding lookup function - {- - selectFrom :: (Eq a) => [(a,b)] -> a -> Maybe b - selectFrom [] _ = Nothing - selectFrom ((v,r):bs) l = if l == v then Just r - else selectFrom bs l - -} - --- |Apply query binding to a supplied value, returning the value --- unchanged if no binding is defined --- -applyVarBinding :: VarBinding a a -> a -> a -applyVarBinding vbind v = fromMaybe v (vbMap vbind v) - --- |Join a pair of query bindings, returning a new binding that --- maps all variables recognized by either of the input bindings. --- If the bindings should overlap, such overlap is not detected and --- the value from the first binding provided is used arbitrarily. --- -joinVarBindings :: (Eq a) => VarBinding a b -> VarBinding a b -> VarBinding a b -joinVarBindings vb1 vb2 - | vbNull vb1 = vb2 - | vbNull vb2 = vb1 - | otherwise = VarBinding - { vbMap = mv12 - , vbEnum = map (\v -> (v,fromJust (mv12 v))) bv12 - , vbNull = False - } - where - -- flist fs a = map ($ a) fs; see also monad function 'ap' - mv12 = headOrNothing . filter isJust . flist [ vbMap vb1, vbMap vb2 ] - bv12 = boundVars vb1 `union` boundVars vb2 - --- |Add a single new value to a variable binding and return the resulting --- new variable binding. --- -addVarBinding :: (Eq a, Show a, Eq b, Show b) => a -> b -> VarBinding a b - -> VarBinding a b -addVarBinding lb val vbind = joinVarBindings vbind $ makeVarBinding [(lb,val)] - ------------------------------------------------------------- --- Datatypes for variable binding modifiers ------------------------------------------------------------- - --- |Define the type of a function to modify variable bindings in --- forward chaining based on rule antecedent matches. This --- function is used to implement the \"allocated to\" logic described --- in Appendix B of the RDF semantics document, in which a specific --- blank node is associated with all matches of some specific value --- by applications of the rule on a given graph. --- Use 'id' if no modification of the variable bindings is required. --- --- This datatype consists of the modifier function itself, which --- operates on a list of variable bindings rather than a single --- variable binding (because some modifications share context across --- a set of bindings), and some additional descriptive information --- that allows possible usage patterns to be analyzed. --- --- Some usage patterns (see 'vbmUsage' for more details): --- --- [filter] all variables are input variables, and the effect --- of the modifier function is to drop variable bindings that --- don't satisfy some criterion. --- Identifiable by an empty element in @vbmUsage@. --- --- [source] all variables are output variables: a raw query --- could be viewed as a source of variable bindings. --- Identifiable by an element of @vbmUsage@ equal to @vbmVocab@. --- --- [modifier] for each supplied variable binding, one or more --- new variable bindings may be created that contain the --- input variables bound as supplied plus some additional variables. --- Identifiable by an element of @vbmUsage@ some subset of @vbmVocab@. --- --- A variety of variable usage patterns may be supported by a given --- modifier: a modifier may be used to define new variable bindings --- from existing bindings in a number of ways, or simply to check that --- some required relationship between bindings is satisfied. --- (Example, for @a + b = c@, any one variable can be deduced from the --- other two, or all three may be supplied to check that the relationship --- does indeed hold.) --- -data VarBindingModify a b = VarBindingModify - { vbmName :: ScopedName - -- ^Name used to identify this variable binding - -- modifier when building inference rules. - , vbmApply :: [VarBinding a b] -> [VarBinding a b] - -- ^Apply variable binding modifier to a - -- list of variable bindings, returning a - -- new list. The result list is not - -- necessarily the same length as the - -- supplied list. - , vbmVocab :: [a] -- ^List of variables used by this modifier. - -- All results of applying this modifier contain - -- bindings for these variables. - , vbmUsage :: [[a]] -- ^List of binding modifier usage patterns - -- supported. Each pattern is characterized as - -- a list of variables for which new bindings - -- may be created by some application of this - -- modifier, assuming that bindings for all other - -- variables in @vbmVocab@ are supplied. - } - --- |Allow a VarBindingModify value to be accessed using a 'LookupMap'. --- -instance LookupEntryClass - (VarBindingModify a b) ScopedName (VarBindingModify a b) - where - keyVal vbm = (vbmName vbm,vbm) - newEntry (_,vbm) = vbm - --- |Type for variable binding modifier that has yet to be instantiated --- with respect to the variables that it operates upon. --- -type OpenVarBindingModify lb vn = [lb] -> VarBindingModify lb vn - --- |Extract variable binding name from @OpenVarBindingModify@ value --- --- (Because only the name is required, the application to an undefined --- list of variable labels should never be evaluated, as long as the --- name is not dependent on the variable names in any way.) --- --- NOT QUITE... some of the functions that create @OpenVarBindingModify@ --- instances also pattern-match the number of labels provided, forcing --- evaluation of the labels parameter, even though it's not used. --- -openVbmName :: OpenVarBindingModify lb vn -> ScopedName -openVbmName ovbm = vbmName (ovbm (error "Undefined labels in variable binding")) - --- |Allow an @OpenVarBindingModify@ value to be accessed using a @LookupMap@. --- -instance LookupEntryClass - (OpenVarBindingModify a b) ScopedName (OpenVarBindingModify a b) - where - keyVal ovbm = (openVbmName ovbm,ovbm) - newEntry (_,ovbm) = ovbm - --- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. --- -instance Show (OpenVarBindingModify a b) - where - show = show . openVbmName - --- |Variable binding modifier compatibility test. --- --- Given a list of bound variables and a variable binding modifier, return --- a list of new variables that may be bound, or @Nothing@. --- --- Note: if the usage pattern component is well-formed (i.e. all --- elements different) then at most one element can be compatible with --- a given input variable set. --- -vbmCompatibility :: (Eq a) => VarBindingModify a b -> [a] -> Maybe [a] -vbmCompatibility vbm vars = find compat (vbmUsage vbm) - where - compat = vbmCompatibleVars vars (vbmVocab vbm) - --- |Variable binding usage compatibility test. --- --- Returns @True@ if the supplied variable bindings can be compatibly --- processed by a variable binding usage with supplied vocabulary and --- usage pattern. --- -vbmCompatibleVars :: - (Eq a) - => [a] -- ^ variables supplied with bindings - -> [a] -- ^ variables returned with bindings by a modifier - -> [a] -- ^ variables assigned new bindings by a modifier - -> Bool -vbmCompatibleVars bvars vocab ovars = - null (ivars `intersect` ovars) && -- ivars and ovars don't overlap - null ((vocab \\ ovars) \\ ivars) -- ovars and ivars cover vocab - where - ivars = bvars `intersect` vocab - --- |Compose variable binding modifiers. --- --- Returns @Just a@ new variable binding modifier that corresponds to --- applying the first supplied modifier and then applying the second --- one, or @Nothing@ if the two modifiers cannot be compatibly composed. --- --- NOTE: this function does not, in general, commute. --- --- NOTE: if there are different ways to achieve the same usage, that --- usage is currently repeated in the result returned. --- -vbmCompose :: (Eq a) => VarBindingModify a b -> VarBindingModify a b - -> Maybe (VarBindingModify a b) -vbmCompose - (VarBindingModify nam1 app1 voc1 use1) - (VarBindingModify nam2 app2 voc2 use2) - | not (null use12) = Just VarBindingModify - { vbmName = swishName $ mconcat ["_", getScopeLocal nam1, "_", getScopeLocal nam2, "_"] - , vbmApply = app2 . app1 - , vbmVocab = voc1 `union` voc2 - , vbmUsage = use12 - } - | otherwise = Nothing - where - use12 = compatibleUsage voc1 use1 use2 - --- |Determine compatible ways in which variable binding modifiers may --- be combined. --- --- The total vocabulary of a modifier is the complete set of variables --- that are used or bound by the modifier. After the modifier has been --- applied, bindings must exist for all of these variables. --- --- A usage pattern of a modifier is a set of variables for which new --- bindings may be generated by the modifier. --- --- The only way in which two variable binding modifiers can be incompatible --- with each other is when they both attempt to create a new binding for --- the same variable. (Note that this does not mean the composition will --- be compatible with all inputs: see 'vbmCompatibleVars'.) --- --- NOTE: if there are different ways to achieve the same usage, that --- usage is currently repeated in the result returned. --- -compatibleUsage :: - (Eq a) - => [a] -- ^ the total vocabulary of the first modifier to be applied - -> [[a]] -- ^ usage patterns for the first modifier - -> [[a]] -- ^ usage patterns for the second modifier - -> [[a]] -- ^ a list of possible usage patterns for the composition of - -- the first modifier with the second modifier, or an empty list if - -- the modifiers are incompatible. -compatibleUsage voc1 use1 use2 = - [ u1++u2 | u2 <- use2, null (voc1 `intersect` u2), u1 <- use1 ] - --- |Find all compatible compositions of a list of variable binding --- modifiers for a given set of supplied bound variables. -findCompositions :: (Eq a) => [VarBindingModify a b] -> [a] - -> [VarBindingModify a b] -findCompositions vbms vars = - mapMaybe (composeCheckSequence vars) (permutations vbms) - --- |Compose sequence of variable binding modifiers, and check --- that the result can be used compatibly with a supplied list --- of bound variables, returning @Just (composed modifier)@, --- or @Nothing@. --- -composeCheckSequence :: (Eq a) => [a] -> [VarBindingModify a b] - -> Maybe (VarBindingModify a b) -composeCheckSequence vars vbms = useWith vars $ composeSequence vbms - where - -- Check that a Maybe modifier is compatible for use with an - -- indicated set of bound variables, and return (Just modifier) - -- or Nothing. - useWith _ Nothing = Nothing - useWith vs v@(Just vbm) - | isJust $ vbmCompatibility vbm vs = v - | otherwise = Nothing - --- |Compose sequence of variable binding modifiers. --- -composeSequence :: (Eq a) => [VarBindingModify a b] - -> Maybe (VarBindingModify a b) -composeSequence [] = Just varBindingId -composeSequence (vbm:vbms) = foldl' composePair (Just vbm) vbms - --- |Compose a pair of variable binding modifiers, returning --- @Just (composed modifier)@, or @Nothing@. --- -composePair :: (Eq a) => Maybe (VarBindingModify a b) -> VarBindingModify a b - -> Maybe (VarBindingModify a b) -composePair Nothing _ = Nothing -composePair (Just vbm1) vbm2 = vbmCompose vbm1 vbm2 - --- |Return @Just a@ compatible composition of variable binding modifiers --- for a given set of supplied bound variables, or @Nothing@ if there --- is no compatible composition --- -findComposition :: (Eq a) => [VarBindingModify a b] -> [a] - -> Maybe (VarBindingModify a b) -findComposition = listToMaybe `c2` findCompositions - where - c2 = (.) . (.) -- compose with function of two arguments +nullRDFVarBinding :: RDFVarBinding +nullRDFVarBinding = nullVarBinding --- |Variable binding modifier that returns exactly those --- variable bindings presented. --- -varBindingId :: VarBindingModify a b -varBindingId = VarBindingModify - { vbmName = swishName "varBindingId" - , vbmApply = id - , vbmVocab = [] - , vbmUsage = [[]] - } +-- |Define type of query binding modifier for RDF graph inference +type RDFVarBindingModify = VarBindingModify RDFLabel RDFLabel --- |Null variable binding modifier --- --- This is like 'varBindingId' except parameterized by some labels. --- I think this is redundant, and should be eliminated. +-- |Open variable binding modifier that operates on RDFLabel values -- -nullVarBindingModify :: OpenVarBindingModify a b -nullVarBindingModify lbs = VarBindingModify - { vbmName = swishName "nullVarBindingModify" - , vbmApply = id - , vbmVocab = lbs - , vbmUsage = [[]] - } +type RDFOpenVarBindingModify = OpenVarBindingModify RDFLabel RDFLabel ------------------------------------------------------------- --- Query binding filters ------------------------------------------------------------- +-- |Define type for lookup map of open query binding modifiers +type RDFOpenVarBindingModifyMap = LookupMap RDFOpenVarBindingModify --- |VarBindingFilter is a function type that tests to see if --- a query binding satisfies some criterion. +-- |@RDFVarBindingFilter@ is a function type that tests to see if +-- a query binding satisfies some criterion, and is used to +-- create a variable binding modifier that simply filers +-- given variable bindings. -- -- Queries often want to apply some kind of filter or condition -- to the variable bindings that are processed. In inference rules, @@ -432,92 +77,88 @@ -- the things that are matched. -- -- This function type is used to perform such tests. --- A number of simple implementations are included below. -data VarBindingFilter a b = VarBindingFilter - { vbfName :: ScopedName - , vbfVocab :: [a] - , vbfTest :: VarBinding a b -> Bool - } +-- A number of simple implementations are included. +-- +type RDFVarBindingFilter = VarBindingFilter RDFLabel RDFLabel --- |Make a variable binding modifier from a variable binding filter value. -makeVarFilterModify :: VarBindingFilter a b -> VarBindingModify a b -makeVarFilterModify vbf = VarBindingModify - { vbmName = vbfName vbf - , vbmApply = filter (vbfTest vbf) - , vbmVocab = vbfVocab vbf - , vbmUsage = [[]] - } +------------------------------------------------------------ +-- Declare some query binding filters +------------------------------------------------------------ --- |Make a variable test filter for a named variable using a --- supplied value testing function. -makeVarTestFilter :: - ScopedName -> (b -> Bool) -> a -> VarBindingFilter a b -makeVarTestFilter nam vtest var = VarBindingFilter - { vbfName = nam - , vbfVocab = [var] - , vbfTest = \vb -> case vbMap vb var of - Just val -> vtest val - _ -> False - } +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a URI reference. +rdfVarBindingUriRef :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingUriRef = + makeVarTestFilter (swishName "rdfVarBindingUriRef") isUri --- |Make a variable comparison filter for named variables using --- a supplied value comparison function. -makeVarCompareFilter :: - ScopedName -> (b -> b -> Bool) -> a -> a -> VarBindingFilter a b -makeVarCompareFilter nam vcomp v1 v2 = VarBindingFilter - { vbfName = nam - , vbfVocab = [v1,v2] - , vbfTest = \vb -> case (vbMap vb v1,vbMap vb v2) of - (Just val1, Just val2) -> vcomp val1 val2 - _ -> False - } +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a blank node. +rdfVarBindingBlank :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingBlank = + makeVarTestFilter (swishName "rdfVarBindingBlank") isBlank ------------------------------------------------------------- --- Declare some generally useful query binding filters ------------------------------------------------------------- +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a literal value. +rdfVarBindingLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingLiteral = + makeVarTestFilter (swishName "rdfVarBindingLiteral") isLiteral --- |This function generates a query binding filter that ensures that --- two indicated query variables are mapped to the same value. -varFilterEQ :: (Eq b) => a -> a -> VarBindingFilter a b -varFilterEQ = - makeVarCompareFilter (swishName "varFilterEQ") (==) +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to an untyped literal value. +rdfVarBindingUntypedLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingUntypedLiteral = + makeVarTestFilter (swishName "rdfVarBindingUntypedLiteral") isUntypedLiteral --- |This function generates a query binding filter that ensures that --- two indicated query variables are mapped to different values. -varFilterNE :: (Eq b) => a -> a -> VarBindingFilter a b -varFilterNE = - makeVarCompareFilter (swishName "varFilterNE") (/=) +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a typed literal value. +rdfVarBindingTypedLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingTypedLiteral = + makeVarTestFilter (swishName "rdfVarBindingTypedLiteral") isTypedLiteral --- |This function composes a number of query binding filters --- into a composite filter that accepts any query binding that --- satisfies at least one of the component values. -varFilterDisjunction :: (Eq a) => [VarBindingFilter a b] - -> VarBindingFilter a b -varFilterDisjunction vbfs = VarBindingFilter - { vbfName = swishName "varFilterDisjunction" - , vbfVocab = foldl1 union (map vbfVocab vbfs) - , vbfTest = or . flist (map vbfTest vbfs) - } +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to an XML literal value. +rdfVarBindingXMLLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingXMLLiteral = + makeVarTestFilter (swishName "rdfVarBindingXMLLiteral") isXMLLiteral --- |This function composes a number of query binding filters --- into a composite filter that accepts any query binding that --- satisfies all of the component values. --- --- The same function could be achieved by composing the component --- filter-based modifiers, but this function is more convenient --- as it avoids the need to check for modifier compatibility. +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to container membership property. +rdfVarBindingMemberProp :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingMemberProp = + makeVarTestFilter (swishName "rdfVarBindingMemberProp") isMemberProp + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a literal value with a +-- datatype whose URI is bound to another node -- -varFilterConjunction :: (Eq a) => [VarBindingFilter a b] - -> VarBindingFilter a b -varFilterConjunction vbfs = VarBindingFilter - { vbfName = swishName "varFilterConjunction" - , vbfVocab = foldl1 union (map vbfVocab vbfs) - , vbfTest = and . flist (map vbfTest vbfs) +rdfVarBindingDatatyped :: + RDFLabel -- ^ variable bound to the required datatype. + -> RDFLabel -- ^ variable bound to the literal node to be tested. + -> RDFVarBindingFilter +rdfVarBindingDatatyped dvar lvar = VarBindingFilter + { vbfName = swishName "rdfVarBindingDatatyped" + , vbfVocab = [dvar,lvar] + , vbfTest = \vb -> testDatatyped vb dvar lvar } +testDatatyped :: RDFVarBinding -> RDFLabel -> RDFLabel -> Bool +testDatatyped vb dvar lvar = and + [ isUri dtype + , isDatatyped dqnam $ applyVarBinding vb lvar + ] + where + dtype = applyVarBinding vb dvar + -- NOTE: dqnam is not evaluated unless (isUri dtype) + -- but add in a _ handler to appease -Wall + -- dqnam = case dtype of { (Res x) -> x } + dqnam = case dtype of + Res x -> x + _ -> error $ "dqnam should not be evaluated with " ++ show dtype + -------------------------------------------------------------------------------- -- --- (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/RDF/Vocabulary.hs b/src/Swish/RDF/Vocabulary.hs --- a/src/Swish/RDF/Vocabulary.hs +++ b/src/Swish/RDF/Vocabulary.hs @@ -30,18 +30,27 @@ , namespaceDAML , namespaceDefault , namespaceSwish - , namespaceLang + -- ** RDF rules -- | The namespaces refer to RDF rules and axioms. , scopeRDF , scopeRDFS , scopeRDFD + + -- * Language tags + -- + -- | Support for language tags that follow RFC 3066. + -- + -- This replaces the use of @ScopedName@ and @langName@, @langTag@, + -- and @isLang@ in versions prior to @0.7.0.0@. + -- + , LanguageTag + , toLangTag + , fromLangTag + , isBaseLang -- * Miscellaneous routines - , langName, langTag, isLang , swishName - - -- * Miscellaneous , rdfdGeneralRestriction , rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality , logImplies @@ -54,16 +63,23 @@ ) where +import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) +import Swish.QName (LName, getLName) + import Swish.RDF.Vocabulary.RDF import Swish.RDF.Vocabulary.OWL import Swish.RDF.Vocabulary.XSD -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, getScopeLocal, getScopeNamespace, makeNSScopedName) - +import Data.Char (isDigit, isAsciiLower) +import Data.List (isPrefixOf) +import Data.List.NonEmpty (NonEmpty(..)) import Data.Monoid (mappend, mconcat) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) +import Data.String (IsString(..)) + import Network.URI (URI, parseURI) +import qualified Data.List.NonEmpty as NE import qualified Data.Text as T ------------------------------------------------------------ @@ -82,12 +98,14 @@ -- | Create a namespace for the datatype family schema used by Swish. namespaceXsdType :: - T.Text -- ^ lbl + LName -- ^ local name -> Namespace -- ^ Namespace has prefix @xsd_lbl@ and -- URI of @http:\/\/id.ninebynine.org\/2003\/XMLSchema\/lbl#@. -namespaceXsdType dtn = toNS ("xsd_" `mappend` dtn) - (mconcat ["http://id.ninebynine.org/2003/XMLSchema/", dtn, "#"]) +namespaceXsdType lbl = + let dtn = getLName lbl + in toNS ("xsd_" `mappend` dtn) + (mconcat ["http://id.ninebynine.org/2003/XMLSchema/", dtn, "#"]) -- | Maps @rdfd@ to @http:\/\/id.ninebynine.org\/2003\/rdfext\/rdfd#@. namespaceRDFD :: Namespace @@ -113,26 +131,20 @@ namespaceDefault :: Namespace namespaceDefault = toNSU "default" namespaceDefaultURI --- | Maps @lang@ to @http:\/\/id.ninebynine.org\/2003\/Swish\/Lang\/@. -namespaceLang :: Namespace -namespaceLang = toNSU "lang" namespaceLangURI - - tU :: String -> URI tU = fromMaybe (error "Internal error processing namespace URI") . parseURI namespaceRDFDURI, namespaceLOGURI, namespaceSwishURI, - namespaceLangURI, namespaceDefaultURI :: URI + namespaceDefaultURI :: URI namespaceRDFDURI = tU "http://id.ninebynine.org/2003/rdfext/rdfd#" namespaceLOGURI = tU "http://www.w3.org/2000/10/swap/log#" namespaceSwishURI = tU "http://id.ninebynine.org/2003/Swish/" -namespaceLangURI = tU "http://id.ninebynine.org/2003/Swish/Lang/" -- To be replaced by urn:ietf:params:lang? namespaceDefaultURI = tU "http://id.ninebynine.org/default/" -- | Convert a local name to a scoped name in the @swish@ namespace (`namespaceSwish`). -swishName :: T.Text -> ScopedName +swishName :: LName -> ScopedName swishName = makeNSScopedName namespaceSwish ----------------------------------------------------------- @@ -145,22 +157,103 @@ -- Fortunately, they do not currently need to appear in Notation3 as -- distinct labels (but future developments may change that). --- | Convert the label to a scoped name in the @lang@ namespace (`namespaceLang`). -langName :: - T.Text -- ^ The lower-case version of this label is used. - -> ScopedName -langName = makeNSScopedName namespaceLang . T.toLower +-- | Represent the language tag for a literal string, following +-- RFC 3066 . +-- +-- Use 'toLangTag' to create a tag and 'fromLangTag' to +-- convert back. The case is preserved for the tag, although +-- comparison (both the 'Eq' instance and 'compareLangTag') +-- is done using the lower-case form of the tags. +-- +-- As an example: +-- +-- > Prelude> :set prompt "swish> " +-- > swish> :set -XOverloadedStrings +-- > swish> :m + Swish.RDF.Vocabulary +-- > swish> let en = "en" :: LanguageTag +-- > swish> let us = "en-us" :: LanguageTag +-- > swish> let gb = "en-GB" :: LanguageTag +-- > swish> gb +-- > en-GB +-- > swish> gb == "en-gb" +-- > True +-- > swish> en == us +-- > False +-- > swish> en `isBaseLang` us +-- > True +-- > swish> us `isBaseLang` en +-- > False +-- > swish> us `isBaseLang` gb +-- > False +-- +data LanguageTag = + LanguageTag T.Text (NonEmpty T.Text) + -- store full value, then the tags --- | Get the name of the language tag (note that the result is --- only guaranteed to be semantically valid if 'isLang' returns @True@ --- but that there is no enforcement of this requirement). -langTag :: ScopedName -> T.Text -langTag = getScopeLocal +instance Show LanguageTag where + show = T.unpack . fromLangTag --- | Is the scoped name in the `namespaceLang` namespace? -isLang :: ScopedName -> Bool -isLang sname = getScopeNamespace sname == namespaceLang +-- | The 'IsString' instance is not total since it will fail +-- given a syntactically-invalid language tag. +instance IsString LanguageTag where + fromString = fromJust . toLangTag . T.pack +-- | The equality test matches on the full definition, so +-- @en-GB@ does not match @en@. See also 'isBaseLang'. +instance Eq LanguageTag where + LanguageTag _ t1 == LanguageTag _ t2 = t1 == t2 + +-- | Create a 'LanguageTag' element from the label. +-- +-- Valid tags follow the ABNF from RCF 3066, which is +-- +-- > Language-Tag = Primary-subtag *( "-" Subtag ) +-- > Primary-subtag = 1*8ALPHA +-- > Subtag = 1*8(ALPHA / DIGIT) +-- +-- There are no checks that the primary or secondary sub tag +-- values are defined in any standard, such as ISO 639, +-- or obey any other syntactical restriction than given above. +-- +toLangTag :: T.Text -> Maybe LanguageTag +toLangTag lbl = + let tag = T.toLower lbl + toks = T.split (=='-') tag + in if all (\s -> let l = T.length s in l > 0 && l < 9) toks + then let primtag : subtags = toks + in if T.all isAsciiLower primtag && all (T.all (\c -> isAsciiLower c || isDigit c)) subtags + then Just $ LanguageTag lbl (NE.fromList toks) + else Nothing + else Nothing + +-- | Convert a language tag back into text form. +fromLangTag :: LanguageTag -> T.Text +fromLangTag (LanguageTag f _) = f + +-- | Compare language tags using the Language-range specification +-- in section 2.5 of RFC 3066. +-- +-- 'True' is returned if the comparison tag is the same as, or +-- matches a prefix of, the base tag (where the match must be +-- over complete sub tags). +-- +-- Note that +-- +-- > l1 `isBaseLang` l2 == l2 `isBaseLang` l1 +-- +-- only when +-- +-- > l1 == l2 +-- +isBaseLang :: + LanguageTag -- ^ base language + -> LanguageTag -- ^ comparison language + -> Bool +isBaseLang (LanguageTag _ (a :| as)) + (LanguageTag _ (b :| bs)) + | a == b = as `isPrefixOf` bs + | otherwise = False + ------------------------------------------------------------ -- Define namespaces for RDF rules, axioms, etc ------------------------------------------------------------ @@ -181,7 +274,7 @@ -- Define some common vocabulary terms ------------------------------------------------------------ -toRDFD :: T.Text -> ScopedName +toRDFD :: LName -> ScopedName toRDFD = makeNSScopedName namespaceRDFD -- | @rdfd:GeneralRestriction@. diff --git a/src/Swish/RDF/Vocabulary/DublinCore.hs b/src/Swish/RDF/Vocabulary/DublinCore.hs --- a/src/Swish/RDF/Vocabulary/DublinCore.hs +++ b/src/Swish/RDF/Vocabulary/DublinCore.hs @@ -183,7 +183,8 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (parseURI) @@ -217,16 +218,10 @@ -- Terms ------------------------------------------------------------ -toDCT :: T.Text -> ScopedName +toDCT, toDCE, toDCAM, toDCTYPE :: LName -> ScopedName toDCT = makeNSScopedName namespaceDCTERMS - -toDCE :: T.Text -> ScopedName toDCE = makeNSScopedName namespaceDCELEM - -toDCAM :: T.Text -> ScopedName toDCAM = makeNSScopedName namespaceDCAM - -toDCTYPE :: T.Text -> ScopedName toDCTYPE = makeNSScopedName namespaceDCTYPE -- Classes diff --git a/src/Swish/RDF/Vocabulary/FOAF.hs b/src/Swish/RDF/Vocabulary/FOAF.hs --- a/src/Swish/RDF/Vocabulary/FOAF.hs +++ b/src/Swish/RDF/Vocabulary/FOAF.hs @@ -112,13 +112,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -134,7 +133,7 @@ -- Terms ------------------------------------------------------------ -toF :: T.Text -> ScopedName +toF :: LName -> ScopedName toF = makeNSScopedName namespaceFOAF -- Classes diff --git a/src/Swish/RDF/Vocabulary/Geo.hs b/src/Swish/RDF/Vocabulary/Geo.hs --- a/src/Swish/RDF/Vocabulary/Geo.hs +++ b/src/Swish/RDF/Vocabulary/Geo.hs @@ -35,13 +35,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -57,7 +56,7 @@ -- Terms ------------------------------------------------------------ -toG :: T.Text -> ScopedName +toG :: LName -> ScopedName toG = makeNSScopedName namespaceGEO -- | @geo:location@. diff --git a/src/Swish/RDF/Vocabulary/OWL.hs b/src/Swish/RDF/Vocabulary/OWL.hs --- a/src/Swish/RDF/Vocabulary/OWL.hs +++ b/src/Swish/RDF/Vocabulary/OWL.hs @@ -49,13 +49,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -71,7 +70,7 @@ -- Terms ------------------------------------------------------------ -toO :: T.Text -> ScopedName +toO :: LName -> ScopedName toO = makeNSScopedName namespaceOWL -- | @owl:sameAs@. diff --git a/src/Swish/RDF/Vocabulary/Provenance.hs b/src/Swish/RDF/Vocabulary/Provenance.hs --- a/src/Swish/RDF/Vocabulary/Provenance.hs +++ b/src/Swish/RDF/Vocabulary/Provenance.hs @@ -72,13 +72,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -94,7 +93,7 @@ -- Terms ------------------------------------------------------------ -toS :: T.Text -> ScopedName +toS :: LName -> ScopedName toS = makeNSScopedName namespacePROV -- Classes diff --git a/src/Swish/RDF/Vocabulary/RDF.hs b/src/Swish/RDF/Vocabulary/RDF.hs --- a/src/Swish/RDF/Vocabulary/RDF.hs +++ b/src/Swish/RDF/Vocabulary/RDF.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# Language OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. @@ -101,9 +101,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.QName (LName, newLName) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromMaybe, fromJust) +import Data.Word (Word32) + import Network.URI (URI, parseURI) import qualified Data.Text as T @@ -128,7 +131,7 @@ -- Terms ------------------------------------------------------------ -toRDF, toRDFS :: T.Text -> ScopedName +toRDF, toRDFS :: LName -> ScopedName toRDF = makeNSScopedName namespaceRDF toRDFS = makeNSScopedName namespaceRDFS @@ -169,8 +172,13 @@ rdfNodeID = toRDF "nodeID" -- | Create a @rdf:_n@ entity. -rdfn :: Int -> ScopedName -rdfn = toRDF . T.pack . ("_" ++) . show +-- +-- There is no check that the argument is not 0, so it is +-- possible to create the un-defined label @rdf:_0@. +rdfn :: + Word32 + -> ScopedName +rdfn = toRDF . fromJust . newLName . T.pack . ("_" ++) . show -- | @rdf:_1@. rdf1 :: ScopedName diff --git a/src/Swish/RDF/Vocabulary/SIOC.hs b/src/Swish/RDF/Vocabulary/SIOC.hs --- a/src/Swish/RDF/Vocabulary/SIOC.hs +++ b/src/Swish/RDF/Vocabulary/SIOC.hs @@ -107,13 +107,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -129,7 +128,7 @@ -- Terms ------------------------------------------------------------ -toS :: T.Text -> ScopedName +toS :: LName -> ScopedName toS = makeNSScopedName namespaceSIOC -- Classes diff --git a/src/Swish/RDF/Vocabulary/XSD.hs b/src/Swish/RDF/Vocabulary/XSD.hs --- a/src/Swish/RDF/Vocabulary/XSD.hs +++ b/src/Swish/RDF/Vocabulary/XSD.hs @@ -62,13 +62,12 @@ ) where -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) +import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) -import qualified Data.Text as T - ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ @@ -85,7 +84,7 @@ ------------------------------------------------------------ -- | Create a scoped name for an XSD datatype with the given name. -xsdType :: T.Text -> ScopedName +xsdType :: LName -> ScopedName xsdType = makeNSScopedName namespaceXSD -- | @xsd:string@ from . diff --git a/src/Swish/Rule.hs b/src/Swish/Rule.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Rule.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Rule +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses, OverloadedStrings +-- +-- This module defines a framework for defining inference rules +-- over some expression form. It is intended to be used with +-- RDF graphs, but the structures aim to be quite generic with +-- respect to the expression forms allowed. +-- +-------------------------------------------------------------------------------- + +module Swish.Rule + ( Expression(..), Formula(..), Rule(..), RuleMap + , nullScope, nullSN, nullFormula, nullRule + , fwdCheckInference, bwdCheckInference + , showsFormula, showsFormulae, showsWidth + ) + where + +import Swish.Namespace (Namespace, ScopedName) +import Swish.Namespace (makeNamespace, makeNSScopedName) +import Swish.QName (LName) + +import Data.LookupMap (LookupEntryClass(..), LookupMap(..)) +import Data.Maybe (fromJust) +import Data.String.ShowLines (ShowLines(..)) + +import Network.URI (URI, parseURI) + +------------------------------------------------------------ +-- Expressions +------------------------------------------------------------ + +-- |Expression is a type class for values over which proofs +-- may be constructed. +class (Eq ex) => Expression ex where + -- |Is expression true in all interpretations? + -- If so, then its truth is assumed without justification. + isValid :: ex -> Bool + +------------------------------------------------------------ +-- Formula: a named expression +------------------------------------------------------------ + +-- | A Formula is a named expression. +data Formula ex = Formula + { formName :: ScopedName -- ^ Name used for formula in proof chain + , formExpr :: ex -- ^ Named formula value + } deriving Show + +-- |Define equality of formulae as equality of formula names +instance Eq (Formula ex) where + f1 == f2 = formName f1 == formName f2 + +-- |Define ordering of formulae based on formula names +instance Ord (Formula ex) where + f1 <= f2 = formName f1 <= formName f2 + +instance LookupEntryClass (Formula ex) ScopedName (Formula ex) + where + newEntry (_,form) = form + keyVal form = (formName form, form) + +-- | The namespace @http:\/\/id.ninebynine.org\/2003\/Ruleset\/null@ with the prefix @null:@. +nullScope :: Namespace +nullScope = makeNamespace (Just "null") nullScopeURI + +-- | Create a scoped name with the null namespace. +nullSN :: + LName -- ^ local name. + -> ScopedName +nullSN = makeNSScopedName nullScope + +tU :: String -> URI +tU = fromJust . parseURI + +nullScopeURI :: URI +nullScopeURI = tU "http://id.ninebynine.org/2003/Ruleset/null" + +-- | The null formula. +nullFormula :: Formula ex +nullFormula = Formula + { formName = makeNSScopedName nullScope "nullFormula" + , formExpr = error "Null formula" + } + +-- testf1 = Formula "f1" ('f',1) +-- testf2 = Formula "f2" ('f',2) + +-- |Return a displayable form of a list of labelled formulae +showsFormulae :: + (ShowLines ex) + => String -- ^ newline + -> [Formula ex] -- ^ the formulae to show + -> String -- ^ text to be placed after the formulae + -> ShowS +showsFormulae _ [] _ = id +showsFormulae newline [f] after = showsFormula newline f . + showString after +showsFormulae newline (f:fs) after = showsFormula newline f . + showString newline . + showsFormulae newline fs after + +-- |Create a displayable form of a labelled formula +showsFormula :: + (ShowLines ex) + => String -- ^ newline + -> Formula ex -- ^ formula + -> ShowS +showsFormula newline f = + showsWidth 16 ("["++show (formName f)++"] ") . + showls (newline ++ replicate 16 ' ') (formExpr f) + +------------------------------------------------------------ +-- Rule +------------------------------------------------------------ + +-- |Rule is a data type for inference rules that can be used +-- to construct a step in a proof. +data Rule ex = Rule + { + -- |Name of rule, for use when displaying a proof + ruleName :: ScopedName, + + -- |Forward application of a rule, takes a list of + -- expressions and returns a list (possibly empty) + -- of forward applications of the rule to combinations + -- of the antecedent expressions. + -- Note that all of the results returned can be assumed to + -- be (simultaneously) true, given the antecedents provided. + fwdApply :: [ex] -> [ex], + + -- |Backward application of a rule, takes an expression + -- and returns a list of alternative antecedents, each of + -- which is a list of expressions that jointly yield the + -- given consequence through application of the inference + -- rule. An empty list is returned if no antecedents + -- will allow the consequence to be inferred. + bwdApply :: ex -> [[ex]], + + -- |Inference check. Takes a list of antecedent expressions + -- and a consequent expression, returning True if the + -- consequence can be obtained from the antecedents by + -- application of the rule. When the antecedents and + -- consequent are both given, this is generally more efficient + -- that using either forward or backward chaining. + -- Also, a particular rule may not fully support either + -- forward or backward chaining, but all rules are required + -- to fully support this function. + -- + -- A default implementation based on forward chaining is + -- given below. + checkInference :: [ex] -> ex -> Bool + } + +-- |Define equality of rules as equality of the rule names. +instance Eq (Rule ex) where + r1 == r2 = ruleName r1 == ruleName r2 + +-- |Define ordering of rules based on the rule names. +instance Ord (Rule ex) where + r1 <= r2 = ruleName r1 <= ruleName r2 + +instance Show (Rule ex) where + show rl = "Rule "++show (ruleName rl) + +instance LookupEntryClass (Rule ex) ScopedName (Rule ex) + where + newEntry (_,rule) = rule + keyVal rule = (ruleName rule, rule) + +-- | A 'LookupMap' for a 'Rule'. +type RuleMap ex = LookupMap (Rule ex) + +-- | Checks that consequence is a result of +-- applying the rule to the antecedants. +fwdCheckInference :: + (Eq ex) + => Rule ex -- ^ rule + -> [ex] -- ^ antecedants + -> ex -- ^ consequence + -> Bool +fwdCheckInference rule ante cons = + cons `elem` fwdApply rule ante + +-- | Checks that the antecedants are all required +-- to create the consequence using the given rule. +bwdCheckInference :: + (Eq ex) + => Rule ex -- ^ rule + -> [ex] -- ^ antecedants + -> ex -- ^ consequence + -> Bool +bwdCheckInference rule ante cons = any checkAnts (bwdApply rule cons) + where + checkAnts = all (`elem` ante) + +-- | The null rule. +nullRule :: Rule ex +nullRule = Rule + { ruleName = makeNSScopedName nullScope "nullRule" + , fwdApply = \ _ -> [] + , bwdApply = \ _ -> [] + , checkInference = \ _ _ -> False + } + +------------------------------------------------------------ +-- Shows formatting support functions +----------------------------------------------------------- + +-- |Show a string left justified in a field of at least the specified +-- number of characters width. +showsWidth :: Int -> String -> ShowS +showsWidth wid str more = str++replicate pad ' '++more + where + pad = wid - length str + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Ruleset.hs b/src/Swish/Ruleset.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Ruleset.hs @@ -0,0 +1,174 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Ruleset +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses +-- +-- This module defines a ruleset data type, used to collect information +-- about a ruleset that may contribute torwards inferences in RDF; +-- e.g. RDF and RDFS are rulesets. +-- +-- A 'Ruleset' consists of a namespace, a collection of axioms, and +-- a collection of rules. +-- +-------------------------------------------------------------------------------- + +module Swish.Ruleset + ( Ruleset(..), RulesetMap + , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules + , getRulesetAxiom, getRulesetRule + , getContextAxiom, getMaybeContextAxiom + , getContextRule, getMaybeContextRule + ) +where + +import Swish.Namespace (Namespace, ScopedName) +import Swish.Rule (Formula(..), Rule(..)) + +{- +Used for the Show instance of Ruleset, which was +used for debugging but has been removed as not +really needed by the general user. + +import Swish.Utils.ShowM (ShowM(..)) +import Data.List (intercalate) +-} + +import Data.LookupMap (LookupEntryClass(..), LookupMap(..), mapFindMaybe) +import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) + +-- | A Rule set. + +data Ruleset ex = Ruleset + { rsNamespace :: Namespace -- ^ Namespace. + , rsAxioms :: [Formula ex] -- ^ Axioms. + , rsRules :: [Rule ex] -- ^ Rules. + } + +{- + +Used for debugging. + +instance (ShowM ex) => Show (Ruleset ex) where + show (Ruleset ns axs rls) = + intercalate "\n" + [ "Ruleset: " ++ show ns + , "Axioms:" ] + ++ (showsFormulae "\n" axs + (intercalate "\n" ("Rules:" : map show rls))) "" +-} + +-- | Ruleset comparisons are based only on their namespace components. +instance Eq (Ruleset ex) where + r1 == r2 = rsNamespace r1 == rsNamespace r2 + +instance LookupEntryClass (Ruleset ex) Namespace (Ruleset ex) + where + keyVal r@(Ruleset k _ _) = (k,r) + newEntry (_,r) = r + +-- | A 'LookupMap' for a 'Ruleset'. +type RulesetMap ex = LookupMap (Ruleset ex) + +-- | Create a ruleset. +makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +makeRuleset nsp fms rls = Ruleset + { rsNamespace = nsp + , rsAxioms = fms + , rsRules = rls + } + +-- | Extract the namespace of a ruleset. +getRulesetNamespace :: Ruleset ex -> Namespace +getRulesetNamespace = rsNamespace + +-- | Extract the axioms from a ruleset. +getRulesetAxioms :: Ruleset ex -> [Formula ex] +getRulesetAxioms = rsAxioms + +-- | Extract the rules from a ruleset. +getRulesetRules :: Ruleset ex -> [Rule ex] +getRulesetRules = rsRules + +-- | Find a named axiom in a ruleset. +getRulesetAxiom :: ScopedName -> Ruleset ex -> Maybe (Formula ex) +getRulesetAxiom nam rset = + mapFindMaybe nam (LookupMap (getRulesetAxioms rset)) + -- listToMaybe $ filter ( (matchName nam) . formName ) $ getRulesetAxioms rset + +-- | Find a named rule in a ruleset. +getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) +getRulesetRule nam rset = + mapFindMaybe nam (LookupMap (getRulesetRules rset)) + -- listToMaybe $ filter ( (matchName nam) . ruleName ) $ getRulesetRules rset + +-- | Find a named axiom in a proof context. +getContextAxiom :: + ScopedName -- ^ Name of axiom. + -> Formula ex -- ^ Default axiom (used if named component does not exist). + -> [Ruleset ex] -- ^ Rulesets to search. + -> Formula ex +getContextAxiom nam def rsets = fromMaybe def (getMaybeContextAxiom nam rsets) + {- + foldr (flip fromMaybe) def $ map (getRulesetAxiom nam) rsets + -} + +-- | Find a named axiom in a proof context. +getMaybeContextAxiom :: + ScopedName -- ^ Name of axiom. + -> [Ruleset ex] -- ^ Rulesets to search. + -> Maybe (Formula ex) +getMaybeContextAxiom nam rsets = + listToMaybe $ mapMaybe (getRulesetAxiom nam) rsets + +-- | Find a named rule in a proof context. +getContextRule :: + ScopedName -- ^ Name of rule. + -> Rule ex -- ^ Default rule (used if named component does not exist). + -> [Ruleset ex] -- ^ Rulesets to search. + -> Rule ex +getContextRule nam def rsets = fromMaybe def (getMaybeContextRule nam rsets) + {- + foldr (flip fromMaybe) def $ map (getRulesetRule nam) rsets + -} + +-- | Find a named rule in a proof context. +getMaybeContextRule :: + ScopedName -- ^ Name of rule. + -> [Ruleset ex] -- ^ Rulesets to search. + -> Maybe (Rule ex) +getMaybeContextRule nam rsets = + listToMaybe $ mapMaybe (getRulesetRule nam) rsets + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Script.hs b/src/Swish/Script.hs new file mode 100644 --- /dev/null +++ b/src/Swish/Script.hs @@ -0,0 +1,1500 @@ +{-# LANGUAGE OverloadedStrings #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +{- | +Module : Script +Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +License : GPL V2 + +Maintainer : Douglas Burke +Stability : experimental +Portability : OverloadedStrings + +This module implements the Swish script processor: it parses a script +from a supplied string, and returns a list of Swish state transformer +functions whose effect, when applied to a state value, is to implement +the supplied script. + +-} + +module Swish.Script + ( + -- * Syntax + -- $syntax + + -- ** Defining a prefix + -- $prefixLine + + -- ** Naming a graph + -- $nameItem + + -- ** Reading and writing graphs + + -- $readGraph + + -- $writeGraph + + -- ** Merging graphs + -- $mergeGraphs + + -- ** Comparing graphs + + -- $compareGraphs + + -- $assertEquiv + + -- $assertMember + + -- ** Defining rules + + -- $defineRule + + -- $defineRuleset + + -- $defineConstraints + + -- ** Apply a rule + -- $fwdChain + + -- $bwdChain + + -- ** Define a proof + -- $proof + + -- * An example script + -- $exampleScript + + -- * Parsing + + parseScriptFromText + ) +where + +import Swish.Datatype (typeMkRules) +import Swish.Monad ( SwishStateIO, SwishStatus(..), NamedGraph(..)) +import Swish.Monad (modGraphs, findGraph, findFormula + , modRules, findRule + , modRulesets, findRuleset + , findOpenVarModify, findDatatype + , setInfo, setError, setStatus) +import Swish.Proof (explainProof, showsProof) +import Swish.Rule (Formula(..), Rule(..)) +import Swish.Ruleset (makeRuleset, getRulesetRule, getMaybeContextRule) +import Swish.VarBinding (composeSequence) + +import Swish.RDF.Datatype (RDFDatatype) + +import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) +import Swish.RDF.Ruleset (makeRDFClosureRule) +import Swish.RDF.Proof (RDFProofStep) +import Swish.RDF.Proof (makeRDFProof, makeRDFProofStep) +import Swish.RDF.VarBinding (RDFVarBindingModify) + +import Swish.RDF.GraphShowLines () + +import Swish.RDF.Graph + ( RDFGraph, RDFLabel(..) + , NamespaceMap + , setNamespaces + , merge, addGraphs + ) + +import Swish.RDF.Parser.Utils (whiteSpace, lexeme, symbol, eoln, manyTill) + +import Swish.RDF.Parser.N3 + ( parseAnyfromText + , parseN3 + , N3Parser, N3State(..) + , getPrefix + , subgraph + , n3symbol -- was uriRef2, + , quickVariable -- was varid + , lexUriRef + , newBlankNode + ) + +import Swish.Namespace (ScopedName, getScopeNamespace) +import Swish.QName (QName, qnameFromURI) + +import Swish.RDF.Formatter.N3 (formatGraphAsBuilder) + +import Swish.Utils.ListHelpers (equiv, flist) + +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.IO as LIO +import Text.ParserCombinators.Poly.StateText + +import Control.Monad (unless, when, liftM, void) +import Control.Monad.State (modify, gets, lift) + +import Data.LookupMap (mapReplace) +import Data.Monoid (Monoid(..)) + +import Network.URI (URI(..)) + +import qualified System.IO.Error as IO +import qualified Control.Exception as CE + +------------------------------------------------------------ +-- +-- The parser used to be based on the Notation3 parser, and used many +-- of the same syntax productions, but the top-level productions used +-- are quite different. With the parser re-write it's less clear +-- what is going on. +-- +-- NOTE: during the parser re-write we strip out some of this functionality +-- + +-- | Parser for Swish script processor +parseScriptFromText :: + Maybe QName -- ^ Default base for the script + -> L.Text -- ^ Swish script + -> Either String [SwishStateIO ()] +parseScriptFromText = parseAnyfromText script + +---------------------------------------------------------------------- +-- Syntax productions +---------------------------------------------------------------------- + +between :: Parser s lbr -> Parser s rbr -> Parser s a -> Parser s a +between = bracket + +n3SymLex :: N3Parser ScopedName +n3SymLex = lexeme n3symbol + +setTo :: N3Parser () +setTo = isymbol ":-" + +semicolon :: N3Parser () +semicolon = isymbol ";" + +comma :: N3Parser () +comma = isymbol "," + +commentText :: N3Parser String +commentText = semicolon *> restOfLine + +script :: N3Parser [SwishStateIO ()] +script = do + whiteSpace + scs <- many command + eof + return scs + +isymbol :: String -> N3Parser () +isymbol = void . symbol + +command :: N3Parser (SwishStateIO ()) +command = + prefixLine + <|> nameItem + <|> readGraph + <|> writeGraph + <|> mergeGraphs + <|> compareGraphs + <|> assertEquiv + <|> assertMember + <|> defineRule + <|> defineRuleset + <|> defineConstraints + <|> checkProofCmd + <|> fwdChain + <|> bwdChain + +prefixLine :: N3Parser (SwishStateIO ()) +prefixLine = do + -- try $ isymbol "@prefix" + isymbol "@prefix" + getPrefix + whiteSpace + isymbol "." + return $ return () + +-- name :- graph +-- name :- ( graph* ) +nameItem :: N3Parser (SwishStateIO ()) +nameItem = + ssAddGraph <$> n3SymLex <*> (symbol ":-" *> graphOrList) + +maybeURI :: N3Parser (Maybe URI) +maybeURI = (Just <$> lexUriRef) <|> return Nothing + +-- @read name [ ] +readGraph :: N3Parser (SwishStateIO ()) +readGraph = commandName "@read" *> (ssRead <$> n3SymLex <*> maybeURI) + +-- @write name [ ] ; Comment +writeGraph :: N3Parser (SwishStateIO ()) +writeGraph = + do { commandName "@write" + ; n <- n3SymLex + ; let gs = ssGetList n :: SwishStateIO (Either String [RDFGraph]) + ; muri <- maybeURI + ; c <- commentText + ; return $ ssWriteList muri gs c + } + +-- @merge ( name* ) => name +mergeGraphs :: N3Parser (SwishStateIO ()) +mergeGraphs = do + commandName "@merge" + gs <- graphList + isymbol "=>" + n <- n3SymLex + return $ ssMerge n gs + +-- @compare name name +compareGraphs :: N3Parser (SwishStateIO ()) +compareGraphs = + commandName "@compare" *> (ssCompare <$> n3SymLex <*> n3SymLex) + +-- @ name name ; Comment +assertArgs :: (ScopedName -> ScopedName -> String -> SwishStateIO ()) + -> String -> N3Parser (SwishStateIO ()) +assertArgs assertFunc cName = do + commandName $ '@':cName + assertFunc <$> n3SymLex <*> n3SymLex <*> commentText + +-- @asserteq name name ; Comment +assertEquiv :: N3Parser (SwishStateIO ()) +assertEquiv = assertArgs ssAssertEq "asserteq" + +-- @assertin name name ; Comment +assertMember :: N3Parser (SwishStateIO ()) +assertMember = assertArgs ssAssertIn "assertin" + +-- @rule name :- ( name* ) => name [ | ( (name var*)* ) ] +defineRule :: N3Parser (SwishStateIO ()) +defineRule = + do { commandName "@rule" + ; rn <- n3SymLex + ; setTo + ; ags <- graphOrList + ; isymbol "=>" + ; cg <- graphExpr + ; vms <- varModifiers <|> pure [] + ; return $ ssDefineRule rn ags cg vms + } + +-- @ruleset name :- ( name* ) ; ( name* ) +defineRuleset :: N3Parser (SwishStateIO ()) +defineRuleset = + commandName "@ruleset" *> + (ssDefineRuleset <$> n3SymLex <*> (setTo *> nameList) <*> (semicolon *> nameList)) + +-- @constraints pref :- ( name* ) | ( name* ) +defineConstraints :: N3Parser (SwishStateIO ()) +defineConstraints = + commandName "@constraints" *> + (ssDefineConstraints <$> n3SymLex <*> (setTo *> graphOrList) <*> (symbol "|" *> nameOrList)) + +-- @proof name ( name* ) +-- @input name +-- @step name ( name* ) => name # rule-name, antecedents, consequent +-- @result name +checkProofCmd :: N3Parser (SwishStateIO ()) +checkProofCmd = + do { commandName "@proof" + ; pn <- n3SymLex + ; sns <- nameList + ; commandName "@input" + ; igf <- formulaExpr + ; sts <- many checkStep + ; commandName "@result" + ; rgf <- formulaExpr + ; return $ ssCheckProof pn sns igf sts rgf + } + +checkStep :: + N3Parser (Either String [RDFRuleset] + -> SwishStateIO (Either String RDFProofStep)) +checkStep = + commandName "@step" *> + (ssCheckStep <$> n3SymLex <*> formulaList <*> (symbol "=>" *> formulaExpr)) + +-- # ruleset rule (antecedents) => result +-- @fwdchain pref name ( name* ) => name +fwdChain :: N3Parser (SwishStateIO ()) +fwdChain = + do { commandName "@fwdchain" + ; sn <- n3SymLex + ; rn <- n3SymLex + ; ags <- graphOrList + ; isymbol "=>" + ; cn <- n3SymLex + ; s <- stGet + ; let prefs = prefixUris s + ; return $ ssFwdChain sn rn ags cn prefs + } + +-- # ruleset rule consequent <= (antecedent-alts) +-- @bwdchain pref name graph <= name +bwdChain :: N3Parser (SwishStateIO ()) +bwdChain = + do { commandName "@bwdchain" + ; sn <- n3SymLex + ; rn <- n3SymLex + ; cg <- graphExpr + ; isymbol "<=" + ; an <- n3SymLex + ; s <- stGet + ; let prefs = prefixUris s + ; return $ ssBwdChain sn rn cg an prefs + } + +---------------------------------------------------------------------- +-- Syntax clause helpers +---------------------------------------------------------------------- + +-- TODO: is the loss of identLetter a problem? +commandName :: String -> N3Parser () +-- commandName cmd = try (string cmd *> notFollowedBy identLetter *> whiteSpace) +commandName cmd = symbol cmd *> pure () + +restOfLine :: N3Parser String +restOfLine = manyTill (satisfy (const True)) eoln <* whiteSpace + +br :: N3Parser a -> N3Parser a +br = between (symbol "(") (symbol ")") + +nameList :: N3Parser [ScopedName] +nameList = br $ many n3SymLex + +toList :: a -> [a] +toList = (:[]) + +nameOrList :: N3Parser [ScopedName] +nameOrList = + (toList <$> n3SymLex) + <|> nameList + +graphExpr :: N3Parser (SwishStateIO (Either String RDFGraph)) +graphExpr = + graphOnly + <|> + do { f <- formulaExpr + ; return $ liftM (liftM formExpr) f + } + +graphOnly :: N3Parser (SwishStateIO (Either String RDFGraph)) +graphOnly = + do { isymbol "{" + ; b <- newBlankNode + ; g <- subgraph b + ; isymbol "}" + ; s <- stGet + ; let gp = setNamespaces (prefixUris s) g + ; return $ return (Right gp) + } + +graphList :: N3Parser [SwishStateIO (Either String RDFGraph)] +graphList = br (many graphExpr) + +graphOrList :: N3Parser [SwishStateIO (Either String RDFGraph)] +graphOrList = + (toList <$> graphExpr) + <|> graphList + +formulaExpr :: N3Parser (SwishStateIO (Either String RDFFormula)) +formulaExpr = n3SymLex >>= namedGraph + +namedGraph :: ScopedName -> N3Parser (SwishStateIO (Either String RDFFormula)) +namedGraph n = + (ssAddReturnFormula n <$> (setTo *> graphOnly)) + <|> return (ssGetFormula n) + +formulaList :: N3Parser [SwishStateIO (Either String RDFFormula)] +formulaList = between (symbol "(") (symbol ")") (many formulaExpr) + +varModifiers :: N3Parser [(ScopedName,[RDFLabel])] +varModifiers = symbol "|" *> varModList + +varModList :: N3Parser [(ScopedName,[RDFLabel])] +varModList = + br (sepBy varMod comma) + <|> toList <$> lexeme varMod + +varMod :: N3Parser (ScopedName,[RDFLabel]) +varMod = (,) <$> n3SymLex <*> many (lexeme quickVariable) + +---------------------------------------------------------------------- +-- SwishState helper functions +---------------------------------------------------------------------- +-- +-- The functions below operate in the SwishStateIO monad, and are used +-- to assemble an executable version of the parsed script. + +-- | Return a message to the user. At present the message begins with '# ' +-- but this may be removed. +-- +ssReport :: + String -- ^ message contents + -> SwishStateIO () +-- ssReport msg = lift $ putStrLn $ "# " ++ msg +ssReport msg = modify $ setInfo $ "# " ++ msg + +ssReportLabel :: + String -- ^ label for the message + -> String -- ^ message contents + -> SwishStateIO () +ssReportLabel lbl msg = ssReport $ lbl ++ ": " ++ msg + +ssAddReturnFormula :: + ScopedName -> SwishStateIO (Either String RDFGraph) + -> SwishStateIO (Either String RDFFormula) +ssAddReturnFormula nam gf = + do { egr <- gf + ; ssAddGraph nam [return egr] + ; return $ liftM (Formula nam) egr + } + +ssAddGraph :: + ScopedName -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO () +ssAddGraph nam gf = + let errmsg = "Graph/list not added: "++show nam++"; " + in + do { esg <- sequence gf -- [Either String RDFGraph] + ; let egs = sequence esg -- Either String [RDFGraph] + ; let fgs = case egs of + Left er -> setError (errmsg++er) + Right gs -> modGraphs (`mapReplace` NamedGraph nam gs) + ; modify fgs + } + +ssGetGraph :: ScopedName -> SwishStateIO (Either String RDFGraph) +ssGetGraph nam = liftM head <$> ssGetList nam + +ssGetFormula :: ScopedName -> SwishStateIO (Either String RDFFormula) +ssGetFormula nam = gets find + where + find st = case findFormula nam st of + Nothing -> Left ("Formula not present: "++show nam) + Just gr -> Right gr + +ssGetList :: ScopedName -> SwishStateIO (Either String [RDFGraph]) +ssGetList nam = gets find + where + find st = case findGraph nam st of + Nothing -> Left ("Graph or list not present: "++show nam) + Just grs -> Right grs + +ssRead :: ScopedName -> Maybe URI -> SwishStateIO () +ssRead nam muri = ssAddGraph nam [ssReadGraph muri] + +ssReadGraph :: Maybe URI -> SwishStateIO (Either String RDFGraph) +ssReadGraph muri = + let gf inp = case inp of + Left es -> Left es + Right is -> parseN3 is (muri >>= qnameFromURI) + + in gf `liftM` getResourceData muri + +ssWriteList :: + Maybe URI -> SwishStateIO (Either String [RDFGraph]) -> String + -> SwishStateIO () +ssWriteList muri gf comment = do + esgs <- gf + case esgs of + Left er -> modify $ setError ("Cannot write list: "++er) + Right [] -> putResourceData Nothing (B.fromLazyText (L.concat ["# ", L.pack comment, "\n+ Swish: Writing empty list"])) + Right [gr] -> ssWriteGraph muri gr comment + Right grs -> mapM_ writegr (zip [(0::Int)..] grs) + where + writegr (n,gr) = ssWriteGraph (murin muri n) gr + ("["++show n++"] "++comment) + murin Nothing _ = Nothing + murin (Just uri) n = + let rp = reverse $ uriPath uri + (rLastSet, rRest) = break (=='/') rp + (before, after) = break (=='.') $ reverse rLastSet + newPath = reverse rRest ++ "/" ++ before ++ show n ++ after + in case rLastSet of + "" -> error $ "Invalid URI (path ends in /): " ++ show uri + _ -> Just $ uri { uriPath = newPath } + + + +{- +ssWrite :: + Maybe String -> SwishStateIO (Either String RDFGraph) -> String + -> SwishStateIO () +ssWrite muri gf comment = + do { esg <- gf + ; case esg of + Left er -> modify $ setError ("Cannot write graph: "++er) + Right gr -> ssWriteGraph muri gr comment + } +-} + +ssWriteGraph :: Maybe URI -> RDFGraph -> String -> SwishStateIO () +ssWriteGraph muri gr comment = + putResourceData muri (c `mappend` formatGraphAsBuilder gr) + where + c = B.fromLazyText $ L.concat ["# ", L.pack comment, "\n"] + +ssMerge :: + ScopedName -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO () +ssMerge nam gfs = + let errmsg = "Graph merge not defined: "++show nam++"; " + in + do { ssReportLabel "Merge" (show nam) + ; esg <- sequence gfs -- [Either String RDFGraph] + ; let egs = sequence esg -- Either String [RDFGraph] + ; let fgs = case egs of + Left er -> setError (errmsg++er) + Right [] -> setError (errmsg++"No graphs to merge") + Right gs -> modGraphs (`mapReplace` NamedGraph nam [g]) + where g = foldl1 merge gs + ; modify fgs + } + +ssCompare :: ScopedName -> ScopedName -> SwishStateIO () +ssCompare n1 n2 = + do { ssReportLabel "Compare" (show n1 ++ " " ++ show n2) + ; g1 <- ssGetGraph n1 + ; g2 <- ssGetGraph n2 + ; when (g1 /= g2) (modify $ setStatus SwishGraphCompareError) + } + +ssAssertEq :: ScopedName -> ScopedName -> String -> SwishStateIO () +ssAssertEq n1 n2 comment = + let er1 = ":\n Graph or list compare not performed: invalid graph/list." + in + do { ssReportLabel "AssertEq" comment + ; g1 <- ssGetList n1 + ; g2 <- ssGetList n2 + ; case (g1,g2) of + (Left er,_) -> modify $ setError (comment++er1++"\n "++er) + (_,Left er) -> modify $ setError (comment++er1++"\n "++er) + (Right gr1,Right gr2) -> + unless (equiv gr1 gr2) $ modify $ + setError (comment++":\n Graph "++show n1 + ++" differs from "++show n2++".") + } + +ssAssertIn :: ScopedName -> ScopedName -> String -> SwishStateIO () +ssAssertIn n1 n2 comment = + let er1 = ":\n Membership test not performed: invalid graph." + er2 = ":\n Membership test not performed: invalid list." + in + do { ssReportLabel "AssertIn" comment + ; g1 <- ssGetGraph n1 + ; g2 <- ssGetList n2 + ; case (g1,g2) of + (Left er,_) -> modify $ setError (comment++er1++"\n "++er) + (_,Left er) -> modify $ setError (comment++er2++"\n "++er) + (Right gr,Right gs) -> + unless (gr `elem` gs) $ modify $ + setError (comment++":\n Graph "++show n1 + ++" not a member of "++show n2) + } + +-- Note: this is probably incomplete, though it should work in simple cases. +-- A complete solution would have the binding modifiers subject to +-- re-arrangement to suit the actual bound variables encountered. +-- See VarBinding.findCompositions and VarBinding.findComposition +-- +-- This code should be adequate if variable bindings are always used +-- in combinations consisting of a single modifier followed by any number +-- of filters. +-- +ssDefineRule :: + ScopedName + -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO (Either String RDFGraph) + -> [(ScopedName,[RDFLabel])] + -> SwishStateIO () +ssDefineRule rn agfs cgf vmds = + let errmsg1 = "Rule definition error in antecedent graph(s): " + errmsg2 = "Rule definition error in consequent graph: " + errmsg3 = "Rule definition error in variable modifier(s): " + errmsg4 = "Incompatible variable binding modifier sequence" + in + do { aesg <- sequence agfs -- [Either String RDFGraph] + ; let ags = sequence aesg :: Either String [RDFGraph] + ; cg <- cgf -- Either String RDFGraph + ; let vmfs = map ssFindVarModify vmds + ; evms <- sequence vmfs -- [Either String RDFVarBindingModify] + ; let vms = sequence evms :: Either String [RDFVarBindingModify] + ; let frl = case (ags,cg,vms) of + (Left er,_,_) -> setError (errmsg1++er) + (_,Left er,_) -> setError (errmsg2++er) + (_,_,Left er) -> setError (errmsg3++er) + (Right agrs,Right cgr,Right vbms) -> + let + newRule = makeRDFClosureRule rn agrs cgr + in + case composeSequence vbms of + Just vm -> modRules (`mapReplace` newRule vm) + Nothing -> setError errmsg4 + ; modify frl + } + +ssFindVarModify :: + (ScopedName,[RDFLabel]) -> SwishStateIO (Either String RDFVarBindingModify) +ssFindVarModify (nam,lbs) = gets $ \st -> + case findOpenVarModify nam st of + Just ovbm -> Right (ovbm lbs) + Nothing -> Left ("Undefined modifier: "++show nam) + +ssDefineRuleset :: + ScopedName + -> [ScopedName] + -> [ScopedName] + -> SwishStateIO () +ssDefineRuleset sn ans rns = + let errmsg1 = "Error in ruleset axiom(s): " + errmsg2 = "Error in ruleset rule(s): " + in + do { let agfs = mapM ssGetFormula ans + :: SwishStateIO [Either String RDFFormula] + ; aesg <- agfs -- [Either String RDFFormula] + ; let eags = sequence aesg :: Either String [RDFFormula] + ; let erlf = mapM ssFindRule rns + :: SwishStateIO [Either String RDFRule] + ; rles <- erlf -- [Either String RDFRule] + ; let erls = sequence rles :: Either String [RDFRule] + ; let frs = case (eags,erls) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right ags,Right rls) -> + modRulesets (`mapReplace` rs) + where + rs = makeRuleset (getScopeNamespace sn) ags rls + ; modify frs + } + +ssFindRule :: ScopedName -> SwishStateIO (Either String RDFRule) +ssFindRule nam = gets find + where + find st = case findRule nam st of + Nothing -> Left ("Rule not found: "++show nam) + Just rl -> Right rl + +ssDefineConstraints :: + ScopedName + -> [SwishStateIO (Either String RDFGraph)] + -> [ScopedName] + -> SwishStateIO () +ssDefineConstraints sn cgfs dtns = + let errmsg1 = "Error in constraint graph(s): " + errmsg2 = "Error in datatype(s): " + in + do { cges <- sequence cgfs -- [Either String RDFGraph] + ; let ecgs = sequence cges :: Either String [RDFGraph] + ; let ecgr = case ecgs of + Left er -> Left er + Right [] -> Right mempty + Right grs -> Right $ foldl1 merge grs + ; edtf <- mapM ssFindDatatype dtns + -- [Either String RDFDatatype] + ; let edts = sequence edtf :: Either String [RDFDatatype] + ; let frs = case (ecgr,edts) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right cgr,Right dts) -> + modRulesets (`mapReplace` rs) + where + rs = makeRuleset (getScopeNamespace sn) [] rls + rls = concatMap (`typeMkRules` cgr) dts + ; modify frs + } + +ssFindDatatype :: ScopedName -> SwishStateIO (Either String RDFDatatype) +ssFindDatatype nam = gets find + where + find st = case findDatatype nam st of + Nothing -> Left ("Datatype not found: "++show nam) + Just dt -> Right dt + + +ssCheckProof :: + ScopedName -- proof name + -> [ScopedName] -- ruleset names + -> SwishStateIO (Either String RDFFormula) -- input formula + -> [Either String [RDFRuleset] -- proof step from rulesets + -> SwishStateIO (Either String RDFProofStep)] + -> SwishStateIO (Either String RDFFormula) -- result formula + -> SwishStateIO () +ssCheckProof pn sns igf stfs rgf = + let + infmsg1 = "Proof satisfied: " + errmsg1 = "Error in proof ruleset(s): " + errmsg2 = "Error in proof input: " + errmsg3 = "Error in proof step(s): " + errmsg4 = "Error in proof goal: " + errmsg5 = "Proof not satisfied: " + proofname = " (Proof "++show pn++")" + in + do { let rs1 = map ssFindRuleset sns :: [SwishStateIO (Either String RDFRuleset)] + ; rs2 <- sequence rs1 -- [Either String RDFRuleset] + ; let erss = sequence rs2 :: Either String [RDFRuleset] + ; eig <- igf -- Either String RDFFormula + ; let st1 = sequence $ flist stfs erss :: SwishStateIO [Either String RDFProofStep] + ; st2 <- st1 -- [Either String RDFProofStep] + ; let ests = sequence st2 :: Either String [RDFProofStep] + ; erg <- rgf -- Either String RDFFormula + ; let proof = case (erss,eig,ests,erg) of + (Left er,_,_,_) -> Left (errmsg1++er++proofname) + (_,Left er,_,_) -> Left (errmsg2++er++proofname) + (_,_,Left er,_) -> Left (errmsg3++er++proofname) + (_,_,_,Left er) -> Left (errmsg4++er++proofname) + (Right rss, Right ig, Right sts, Right rg) -> + Right (makeRDFProof rss ig rg sts) + ; when False $ case proof of + (Left _) -> return () + (Right pr) -> putResourceData Nothing $ + B.fromLazyText (L.concat ["Proof ", L.pack (show pn), "\n"]) + `mappend` + B.fromString (showsProof "\n" pr "\n") + -- TODO: clean up + ; let checkproof = case proof of + (Left er) -> setError er + (Right pr) -> + case explainProof pr of + Nothing -> setInfo (infmsg1++show pn) + Just ex -> setError (errmsg5++show pn++", "++ex) + {- + if not $ checkProof pr then + setError (errmsg5++show pn) + else + setInfo (infmsg1++show pn) + -} + ; modify checkproof + } + +ssCheckStep :: + ScopedName -- rule name + -> [SwishStateIO (Either String RDFFormula)] -- antecedent graph formulae + -> SwishStateIO (Either String RDFFormula) -- consequent graph formula + -> Either String [RDFRuleset] -- rulesets + -> SwishStateIO (Either String RDFProofStep) -- resulting proof step +ssCheckStep _ _ _ (Left er) = return $ Left er +ssCheckStep rn eagf ecgf (Right rss) = + let + errmsg1 = "Rule not in proof step ruleset(s): " + errmsg2 = "Error in proof step antecedent graph(s): " + errmsg3 = "Error in proof step consequent graph: " + in + do { let mrul = getMaybeContextRule rn rss :: Maybe RDFRule + ; esag <- sequence eagf -- [Either String RDFFormula]] + ; let eags = sequence esag :: Either String [RDFFormula] + ; ecg <- ecgf -- Either String RDFFormula + ; let est = case (mrul,eags,ecg) of + (Nothing,_,_) -> Left (errmsg1++show rn) + (_,Left er,_) -> Left (errmsg2++er) + (_,_,Left er) -> Left (errmsg3++er) + (Just rul,Right ags,Right cg) -> + Right $ makeRDFProofStep rul ags cg + ; return est + } + +ssFwdChain :: + ScopedName -- ruleset name + -> ScopedName -- rule name + -> [SwishStateIO (Either String RDFGraph)] -- antecedent graphs + -> ScopedName -- consequent graph name + -> NamespaceMap -- prefixes for new graph + -> SwishStateIO () +ssFwdChain sn rn agfs cn prefs = + let + errmsg1 = "FwdChain rule error: " + errmsg2 = "FwdChain antecedent error: " + in + do { erl <- ssFindRulesetRule sn rn + ; aesg <- sequence agfs -- [Either String RDFGraph] + ; let eags = sequence aesg :: Either String [RDFGraph] + ; let fcr = case (erl,eags) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right rl,Right ags) -> + modGraphs (`mapReplace` NamedGraph cn [cg]) + where + cg = case fwdApply rl ags of + [] -> mempty + grs -> setNamespaces prefs $ foldl1 addGraphs grs + ; modify fcr + } + +ssFindRulesetRule :: + ScopedName -> ScopedName -> SwishStateIO (Either String RDFRule) +ssFindRulesetRule sn rn = gets find + where + find st = case findRuleset sn st of + Nothing -> Left ("Ruleset not found: "++show sn) + Just rs -> find1 rs + find1 rs = case getRulesetRule rn rs of + Nothing -> Left ("Rule not in ruleset: "++show sn++": "++show rn) + Just rl -> Right rl + +ssFindRuleset :: + ScopedName -> SwishStateIO (Either String RDFRuleset) +ssFindRuleset sn = gets find + where + find st = case findRuleset sn st of + Nothing -> Left ("Ruleset not found: "++show sn) + Just rs -> Right rs + +ssBwdChain :: + ScopedName -- ruleset name + -> ScopedName -- rule name + -> SwishStateIO (Either String RDFGraph) -- consequent graphs + -> ScopedName -- antecedent alts name + -> NamespaceMap -- prefixes for new graphs + -> SwishStateIO () +ssBwdChain sn rn cgf an prefs = + let + errmsg1 = "BwdChain rule error: " + errmsg2 = "BwdChain goal error: " + in + do { erl <- ssFindRulesetRule sn rn + ; ecg <- cgf -- Either String RDFGraph + ; let fcr = case (erl,ecg) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right rl,Right cg) -> + modGraphs (`mapReplace` NamedGraph an ags) + where + ags = map mergegr (bwdApply rl cg) + mergegr grs = case grs of + [] -> mempty + _ -> setNamespaces prefs $ foldl1 addGraphs grs + ; modify fcr + } + +-- Temporary implementation: just read local file WNH +-- (Add logic to separate filenames from URIs, and +-- attempt HTTP GET, or similar.) +getResourceData :: Maybe URI -> SwishStateIO (Either String L.Text) +getResourceData muri = + case muri of + Nothing -> fromStdin + Just uri -> fromUri uri + where + fromStdin = + do { dat <- lift LIO.getContents + ; return $ Right dat + } + fromUri = fromFile + fromFile uri | uriScheme uri == "file:" = Right `fmap` lift (LIO.readFile $ uriPath uri) + | otherwise = error $ "Unsupported file name for read: " ++ show uri + +-- Temporary implementation: just write local file +-- (Need to add logic to separate filenames from URIs, and +-- attempt HTTP PUT, or similar.) +putResourceData :: Maybe URI -> B.Builder -> SwishStateIO () +putResourceData muri gsh = do + ios <- lift . CE.try $ maybe toStdout toUri muri + case ios of + Left ioe -> modify $ setError + ("Error writing graph: "++ + IO.ioeGetErrorString ioe) + Right _ -> return () + + where + toStdout = LIO.putStrLn gstr + toUri uri | uriScheme uri == "file:" = LIO.writeFile (uriPath uri) gstr + | otherwise = error $ "Unsupported scheme for write: " ++ show uri + gstr = B.toLazyText gsh + +{- $syntax + +The script syntax is based loosely on Notation3, and the script parser is an +extension of the Notation3 parser in the module "Swish.RDF.Parser.N3". +The comment character is @#@ and white space is ignored. + +> script := command * +> command := prefixLine | +> nameItem | +> readGraph | +> writeGraph | +> mergeGraphs | +> compareGraphs | +> assertEquiv | +> assertMember | +> defineRule | +> defineRuleset | +> defineConstraints | +> checkProofCmd | +> fwdChain | +> bwdChain + +-} + +{- $prefixLine + +> prefixLine := @prefix []: . + +Define a namespace prefix and URI. + +The prefix thus defined is available for use in any subsequent script +command, and also in any graphs contained within the script file. (So, +prefix declarations do not need to be repeated for each graph +contained within the script.) + +Graphs read from external files must contain their own prefix +declarations. + +Example: + + > @prefix gex: . + > @prefix : . + +-} + +{- $nameItem + +> nameItem := name :- graph | +> name :- ( graph* ) + +Graphs or lists of graphs can be given a name for use in other +statements. A name is a qname (prefix:local) or a URI enclosed in +angle + +Example: + +> @prefix ex1: . +> @prefix ex2: . +> +> ex1:gr1 :- { +> ex2:foo a ex2:Foo . +> ex2:bar a ex2:Bar . +> ex2:Bar rdfs:subClassOf ex2:Foo . +> } + +-} + +{- $readGraph + +> readGraph := @read name [] + +The @\@read@ command reads in the contents of the given URI +- which at present only supports reading local files, so +no HTTP access - and stores it under the given name. + +If no URI is given then the file is read from standard input. + +Example: + + > @prefix ex: . + > @read ex:foo + +-} + +{- $writeGraph + +> writeGraph := @write name [] ; comment + +The @\@write@ command writes out the contents of the given graph +- which at present only supports writing local files, so +no HTTP access. The comment text is written as a comment line +preceeding the graph contents. + +If no URI is given then the file is written to the standard output. + +Example: + + > @prefix ex: . + > @read ex:gr1 + > @read ex:gr2 + > @merge (ex:gr1 ex:gr2) => ex:gr3 + > @write ex:gr3 ; the merged data + > @write ex:gr3 ; merge of graph1.n3 and graph2.n3 + +-} + +{- $mergeGraphs + +> mergeGraphs := @merge ( name* ) => name + +Create a new named graph that is the merge two or more graphs, +renaming bnodes as required to avoid node-merging. + +When the merge command is run, the message + + > # Merge: + +will be created on the standard output channel. + +Example: + + > @prefix gex: . + > @prefix ex: . + > gex:gr1 :- { ex:foo ex:bar _:b1 . } + > gex:gr2 :- { _:b1 ex:foobar 23. } + > @merge (gex:gr1 gex:gr2) => gex:gr3 + > @write gex:gr3 ; merged graphs + +When run in Swish, this creates the following output (along with +several other namespace declarations): + + > # merged graphs + > @prefix ex: . + > ex:foo ex:bar [] . + > [ + > ex:foobar "23"^^xsd:integer + > ] . + +-} + +{- $compareGraphs + +> compareGraphs := @compare name name + +Compare two graphs for isomorphism, setting the Swish exit status to +reflect the result. + +When the compare command is run, the message + + > # Compare: + +will be created on the standard output channel. + +Example: + + > @prefix gex: . + > @read gex:gr1 + > @read gex:gr2 + > @compare gex:gr1 gex:gr2 + +-} + +{- $assertEquiv + +> assertEquiv := @asserteq name name ; comment + +Test two graphs or lists of graphs for isomorphism, reporting if they +differ. The comment text is included with any report generated. + +When the command is run, the message + + > # AssertEq: + +will be created on the standard output channel. + +Example: + + > @prefix ex: . + > + > # Set up the graphs for the rules + > ex:Rule01Ant :- { ?p ex:son ?o . } + > ex:Rule01Con :- { ?o a ex:Male ; ex:parent ?p . } + > + > # Create a rule and a ruleset + > @rule ex:Rule01 :- ( ex:Rule01Ant ) => ex:Rule01Con + > @ruleset ex:rules :- (ex:TomSonDick ex:TomSonHarry) ; (ex:Rule01) + > + > # Apply the rule + > @fwdchain ex:rules ex:Rule01 { :Tom ex:son :Charles . } => ex:Rule01fwd + > + > # Compare the results to the expected value + > ex:ExpectedRule01fwd :- { :Charles a ex:Male ; ex:parent :Tom . } + > @asserteq ex:Rule01fwd ex:ExpectedRule01fwd + > ; Infer that Charles is male and has parent Tom + +-} + +{- $assertMember + +> assertMember := @assertin name name ; comment + +Test if a graph is isomorphic to a member of a list of graphs, +reporting if no match is found. The comment text is included with any +report generated. + +Example: + +> @bwdchain pv:rules :PassengerVehicle ex:Test01Inp <= :t1b +> +> @assertin ex:Test01Bwd0 :t1b ; Backward chain component test (0) +> @assertin ex:Test01Bwd1 :t1b ; Backward chain component test (1) + +-} + +{- $defineRule + +> defineRule := @rule name :- ( name* ) => name +> defineRule := @rule name :- ( name* ) => name +> | ( (name var*)* ) + +Define a named Horn-style rule. + +The list of names preceding and following @=>@ are the antecedent and consequent +graphs, respectivelu. Both sets may contain variable nodes of the form +@?var@. + +The optional part, after the @|@ separator, is a list of variable +binding modifiers, each of which consists of a name and a list of +variables (@?var@) to which the modifier is applied. Variable binding +modifiers are built in to Swish, and are used to incorporate datatype +value inferences into a rule. + +-} + +{- $defineRuleset + +> defineRuleset := @ruleset name :- ( name* ) ; ( name* ) + +Define a named ruleset (a collection of axioms and rules). The first +list of names are the axioms that are part of the ruleset, and the +second list are the rules. + +-} + +{- $defineConstraints + +> defineConstraints := @constraints pref :- ( name* ) | [ name | ( name* ) ] + +Define a named ruleset containing class-restriction rules based on a +datatype value constraint. The first list of +names is a list of graphs that together comprise the class-restriction +definitions (rule names are the names of the corresponding restriction +classes). The second list of names is a list of datatypes whose +datatype relations are referenced by the class restriction +definitions. + +-} + +{- $fwdChain + +> fwdChain := @fwdchain pref name ( name* ) => name + +Define a new graph obtained by forward-chaining a rule. The first name +is the ruleset to be used. The second name is the rule name. The list +of names are the antecedent graphs to which the rule is applied. The +name following the @=>@ names a new graph that is the result of formward +chaining from the given antecedents using the indicated rule. + +-} + +{- $bwdChain + +> bwdChain := @bwdchain pref name graph <= name + +Define a new list of alternative graphs obtained by backward-chaining +a rule. The first name is the ruleset to be used. The second name is +the rule name. The third name (before the @<=@) is the name of a goal graph +from which to backward chain. The final name (after the @<=@) names a new +list of graphs, each of which is an alternative antecedent from which +the given goal can be deduced using the indicated rule. + + +-} + +{- $proof + +> checkProofCmd := proofLine nl +> inputLine nl +> (stepLine nl)* +> resultLine +> proofLine := @proof name ( name* ) + +Check a proof, reporting the step that fails, if any. + +The @\@proof@ line names the proof and specifies a list rulesets +(proof context) used. The remaining lines specify the input +expression (@\@input@), proof steps (@\@step@) and the final result +(@\@result@) that is demonstrated by the proof. + +> inputLine := @input name + +In a proof, indicates an input expression upon which the proof is +based. Exactly one of these immediately follows the @\@proof@ command. + +> stepLine := @step name ( name* ) => name + +This defines a step of the proof; any number of these immediately +follow the @\@input@ command. + +It indicates the name of the rule applied for this step, a list of +antecedent graphs, and a named graph that is deduced by this step. +For convenience, the deduced graph may introduce a new named graph +using an expression of the form: + + > name :- { statements } + +> resultLine := @result name + +This defines the goal of the proof, and completes a proof +definition. Exactly one of these immediately follows the @\@step@ +commands. For convenience, the result statement may introduce a new +named graph using an expression of the form: + + > name :- { statements } + +-} + +{- $exampleScript + +This is the example script taken from + +with the proof step adjusted so that it passes. + +> # -- Example Swish script -- +> # +> # Comment lines start with a '#' +> # +> # The script syntax is loosely based on Notation3, but it is a quite +> # different language, except that embedded graphs (enclosed in {...}) +> # are encoded using Notation3 syntax. +> # +> # -- Prefix declarations -- +> # +> # As well as being used for all labels defined and used by the script +> # itself, these are applied to all graph expressions within the script +> # file, and to graphs created by scripted inferences, +> # but are not applied to any graphs read in from an external source. +> +> @prefix ex: . +> @prefix pv: . +> @prefix xsd: . +> @prefix xsd_integer: . +> @prefix rs_rdf: . +> @prefix rs_rdfs: . +> @prefix : . +> +> # Additionally, prefix declarations are provided automatically for: +> # @prefix rdf: . +> # @prefix rdfs: . +> # @prefix rdfd: . +> # @prefix rdfo: . +> # @prefix owl: . +> +> # -- Simple named graph declarations -- +> +> ex:Rule01Ant :- { ?p ex:son ?o . } +> +> ex:Rule01Con :- { ?o a ex:Male ; ex:parent ?p . } +> +> ex:TomSonDick :- { :Tom ex:son :Dick . } +> ex:TomSonHarry :- { :Tom ex:son :Harry . } +> +> # -- Named rule definition -- +> +> @rule ex:Rule01 :- ( ex:Rule01Ant ) => ex:Rule01Con +> +> # -- Named ruleset definition -- +> # +> # A 'ruleset' is a collection of axioms and rules. +> # +> # Currently, the ruleset is identified using the namespace alone; +> # i.e. the 'rules' in 'ex:rules' below is not used. +> # This is under review. +> +> @ruleset ex:rules :- (ex:TomSonDick ex:TomSonHarry) ; (ex:Rule01) +> +> # -- Forward application of rule -- +> # +> # The rule is identified here by ruleset and a name within the ruleset. +> +> @fwdchain ex:rules ex:Rule01 { :Tom ex:son :Charles . } => ex:Rule01fwd +> +> # -- Compare graphs -- +> # +> # Compare result of inference with expected result. +> # This is a graph isomorphism test rather than strict equality, +> # to allow for bnode renaming. +> # If the graphs are not equal, a message is generated, which +> # includes the comment (';' to end of line) +> +> ex:ExpectedRule01fwd :- { :Charles a ex:Male ; ex:parent :Tom . } +> +> @asserteq ex:Rule01fwd ex:ExpectedRule01fwd +> ; Infer that Charles is male and has parent Tom +> +> # -- Display graph (to screen and a file) -- +> # +> # The comment is included in the output. +> +> @write ex:Rule01fwd ; Charles is male and has parent Tom +> @write ex:Rule01fwd ; Charles is male and has parent Tom +> +> # -- Read graph from file -- +> # +> # Creates a new named graph in the Swish environment. +> +> @read ex:Rule01inp +> +> # -- Proof check -- +> # +> # This proof uses the built-in RDF and RDFS rulesets, +> # which are the RDF- and RDFS- entailment rules described in the RDF +> # formal semantics document. +> # +> # To prove: +> # ex:foo ex:prop "a" . +> # RDFS-entails +> # ex:foo ex:prop _:x . +> # _:x rdf:type rdfs:Resource . +> # +> # If the proof is not valid according to the axioms and rules of the +> # ruleset(s) used and antecedents given, then an error is reported +> # indicating the failed proof step. +> +> ex:Input :- { ex:foo ex:prop "a" . } +> ex:Result :- { ex:foo ex:prop _:a . _:a rdf:type rdfs:Resource . } +> +> @proof ex:Proof ( rs_rdf:rules rs_rdfs:rules ) +> @input ex:Input +> @step rs_rdfs:r3 ( rs_rdfs:a10 rs_rdfs:a39 ) +> => ex:Stepa :- { rdfs:Literal rdf:type rdfs:Class . } +> @step rs_rdfs:r8 ( ex:Stepa ) +> => ex:Stepb :- { rdfs:Literal rdfs:subClassOf rdfs:Resource . } +> @step rs_rdf:lg ( ex:Input ) +> => ex:Stepc :- { ex:foo ex:prop _:a . _:a rdf:_allocatedTo "a" . } +> @step rs_rdfs:r1 ( ex:Stepc ) +> => ex:Stepd :- { _:a rdf:type rdfs:Literal . } +> @step rs_rdfs:r9 ( ex:Stepb ex:Stepd ) +> => ex:Stepe :- { _:a rdf:type rdfs:Resource . } +> @step rs_rdf:se ( ex:Stepc ex:Stepd ex:Stepe ) +> => ex:Result +> @result ex:Result +> +> # -- Restriction based datatype inferencing -- +> # +> # Datatype inferencing based on a general class restriction and +> # a predefined relation (per idea noted by Pan and Horrocks). +> +> ex:VehicleRule :- +> { :PassengerVehicle a rdfd:GeneralRestriction ; +> rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; +> rdfd:constraint xsd_integer:sum ; +> rdfd:maxCardinality "1"^^xsd:nonNegativeInteger . } +> +> # Define a new ruleset based on a declaration of a constraint class +> # and reference to built-in datatype. +> # The datatype constraint xsd_integer:sum is part of the definition +> # of datatype xsd:integer that is cited in the constraint ruleset +> # declaration. It relates named properties of a class instance. +> +> @constraints pv:rules :- ( ex:VehicleRule ) | xsd:integer +> +> # Input data for test cases: +> +> ex:Test01Inp :- +> { _:a1 a :PassengerVehicle ; +> :seatedCapacity "30"^^xsd:integer ; +> :standingCapacity "20"^^xsd:integer . } +> +> # Forward chaining test case: +> +> ex:Test01Fwd :- { _:a1 :totalCapacity "50"^^xsd:integer . } +> +> @fwdchain pv:rules :PassengerVehicle ex:Test01Inp => :t1f +> @asserteq :t1f ex:Test01Fwd ; Forward chain test +> +> # Backward chaining test case: +> # +> # Note that the result of backward chaining is a list of alternatives, +> # any one of which is sufficient to derive the given conclusion. +> +> ex:Test01Bwd0 :- +> { _:a1 a :PassengerVehicle . +> _:a1 :totalCapacity "50"^^xsd:integer . +> _:a1 :seatedCapacity "30"^^xsd:integer . } +> +> ex:Test01Bwd1 :- +> { _:a1 a :PassengerVehicle . +> _:a1 :totalCapacity "50"^^xsd:integer . +> _:a1 :standingCapacity "20"^^xsd:integer . } +> +> # Declare list of graphs: +> +> ex:Test01Bwd :- ( ex:Test01Bwd0 ex:Test01Bwd1 ) +> +> @bwdchain pv:rules :PassengerVehicle ex:Test01Inp <= :t1b +> @asserteq :t1b ex:Test01Bwd ; Backward chain test +> +> # Can test for graph membership in a list +> +> @assertin ex:Test01Bwd0 :t1b ; Backward chain component test (0) +> @assertin ex:Test01Bwd1 :t1b ; Backward chain component test (1) +> +> # -- Merge graphs -- +> # +> # Merging renames bnodes to avoid collisions. +> +> @merge ( ex:Test01Bwd0 ex:Test01Bwd1 ) => ex:Merged +> +> # This form of comparison sets the Swish exit status based on the result. +> +> ex:ExpectedMerged :- +> { _:a1 a :PassengerVehicle . +> _:a1 :totalCapacity "50"^^xsd:integer . +> _:a1 :seatedCapacity "30"^^xsd:integer . +> _:a2 a :PassengerVehicle . +> _:a2 :totalCapacity "50"^^xsd:integer . +> _:a2 :standingCapacity "20"^^xsd:integer . } +> +> @compare ex:Merged ex:ExpectedMerged +> +> # End of example script + +If saved in the file example.ss, then it can be evaluated by saying +either of: + +> % Swish -s=example.ss + +or, from @ghci@: + +> Prelude> :set prompt "Swish> " +> Swish> :m + Swish +> Swish> runSwish "-s=example.ss" + +and the output is + +> # AssertEq: Infer that Charles is male and has parent Tom +> # Charles is male and has parent Tom +> @prefix rdf: . +> @prefix rdfs: . +> @prefix rdfd: . +> @prefix owl: . +> @prefix log: . +> @prefix : . +> @prefix ex: . +> @prefix pv: . +> @prefix xsd: . +> @prefix xsd_integer: . +> @prefix rs_rdf: . +> @prefix rs_rdfs: . +> :Charles ex:parent :Tom ; +> a ex:Male . +> +> Proof satisfied: ex:Proof +> # AssertEq: Forward chain test +> # AssertEq: Backward chain test +> # AssertIn: Backward chain component test (0) +> # AssertIn: Backward chain component test (1) +> # Merge: ex:Merged +> # Compare: ex:Merged ex:ExpectedMerged + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/ListHelpers.hs b/src/Swish/Utils/ListHelpers.hs --- a/src/Swish/Utils/ListHelpers.hs +++ b/src/Swish/Utils/ListHelpers.hs @@ -3,86 +3,29 @@ -------------------------------------------------------------------------------- -- | -- Module : ListHelpers --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- --- This module defines some generic list and related helper functions. +-- This module defines some generic list and related helper functions. The plan +-- is to move to using functionality from other modules (e.g. containers) where +-- possible. -- -------------------------------------------------------------------------------- -{- -TODO: - -The plan is to use modules such as Data.Set where appropriate. - --} - module Swish.Utils.ListHelpers - ( -- list of Swish.RDF.xxx modules the routine is used in - select -- GraphMatch - , deleteIndex -- Datatype - , subset -- Proof, RDFProof, VarBinding [also defined in Utils.PartOrderedCollection] - , equiv -- GraphMatch, RDFRuleset, SwishScript, VarBinding, Utils.LookupMap - , addSetElem -- RDFGraph - , headOrNothing -- VarBinding - , pairUngroup -- GraphMatch - , pairSort -- GraphMatch - , pairGroup -- GraphMatch - , breakAll -- SwishMain - , powerSet -- ClassRestrictionRule, RDFProof - , permutations -- VarBinding - , listProduct -- RDFQuery - , powerSequencesLen -- RDFProof - , flist -- Datatype, RDFProof, RDFRuleset, SwishScript, VarBinding - , allp -- RDFQuery - , anyp -- RDFQuery + ( -- list of modules the routine is used in + subset -- Proof, RDF.Proof, VarBinding [also defined in Data.Ord.Partial] + , equiv -- GraphMatch, RDF.Ruleset, Script, VarBinding, Data.LookupMap + , flist -- Datatype, RDF.Proof, RDF.Ruleset, Script, VarBinding, ... ) where - -import Data.Ord (comparing) -import Data.List (sortBy, groupBy) ------------------------------------------------------------ --- Generic helpers ------------------------------------------------------------- - --- |Select is like filter, except that it tests one list to select --- elements from a second list. -select :: ( a -> Bool ) -> [a] -> [b] -> [b] -select _ [] [] = [] -select f (e1:l1) (e2:l2) - | f e1 = e2 : select f l1 l2 - | otherwise = select f l1 l2 -select _ _ _ = error "select supplied with different length lists" - --- |Delete the n'th element of a list, returning the result --- --- If the list doesn't have an n'th element, return the list unchanged. --- -deleteIndex :: [a] -> Int -> [a] -deleteIndex [] _ = [] -deleteIndex xxs@(x:xs) n - | n < 0 = xxs - | n == 0 = xs - | otherwise = x:deleteIndex xs (n-1) - -{- -testdi1 = deleteIndex [1,2,3,4] 0 == [2,3,4] -testdi2 = deleteIndex [1,2,3,4] 1 == [1,3,4] -testdi3 = deleteIndex [1,2,3,4] 2 == [1,2,4] -testdi4 = deleteIndex [1,2,3,4] 3 == [1,2,3] -testdi5 = deleteIndex [1,2,3,4] 4 == [1,2,3,4] -testdi6 = deleteIndex [1,2,3,4] (-1) == [1,2,3,4] -testdi = and - [ testdi1, testdi2, testdi3, testdi4, testdi5, testdi6 ] --} - ------------------------------------------------------------- -- Set functions -- -- NOTE: to change to Data.Set then Eq a constraint will @@ -99,182 +42,7 @@ equiv :: (Eq a) => [a] -> [a] -> Bool a `equiv` b = a `subset` b && b `subset` a --- |Add element to set - -addSetElem :: (Eq a) => a -> [a] -> [a] -addSetElem e es = if e `elem` es then es else e:es - ------------------------------------------------------------ --- Lists and Maybes ------------------------------------------------------------- - --- |Return head of a list of @Maybe@'s, or @Nothing@ if list is empty --- --- Use with @filter isJust@ to select a non-Nothing value from a --- list when such a value is present. --- -headOrNothing :: [Maybe a] -> Maybe a -headOrNothing [] = Nothing -headOrNothing (a:_) = a - ------------------------------------------------------------- --- Filter, ungroup, sort and group pairs by first member ------------------------------------------------------------- - -{- -pairSelect :: ((a,b) -> Bool) -> ((a,b) -> c) -> [(a,b)] -> [c] -pairSelect p f as = map f (filter p as) --} - -pairUngroup :: (a,[b]) -> [(a,b)] -pairUngroup (a,bs) = [ (a,b) | b <- bs ] - -pairSort :: (Ord a) => [(a,b)] -> [(a,b)] -pairSort = sortBy (comparing fst) - -pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])] -pairGroup = map (factor . unzip) . groupBy eqFirst . pairSort - where - -- as is not [] by construction, but would be nice to have - -- this enforced by the types - factor (as, bs) = (head as,bs) - eqFirst a b = fst a == fst b - ------------------------------------------------------------- --- Separate list into sublists ------------------------------------------------------------- - --- |Break list into a list of sublists, separated by element --- satisfying supplied condition. -breakAll :: (a -> Bool) -> [a] -> [[a]] -breakAll _ [] = [] -breakAll p s = let (h,s') = break p s - in h : breakAll p (drop 1 s') - ------------------------------------------------------------- --- Powerset ------------------------------------------------------------- - --- [[[TBD... there's a much better implementation in my email, --- from Christopher Hendrie. This is the raw code.]]] -{- ->ranked_powerset :: [a] -> [[[a]]] ->ranked_powerset = takeWhile (not . null) . foldr next_powerset ([[]] : -repeat []) -> ->next_powerset :: a -> [[[a]]] -> [[[a]]] ->next_powerset x r = zipWith (++) ([] : map (map (x:)) r) r -> ->powerset :: [a] -> [[a]] ->powerset = tail . concat . ranked_powerset --} - --- |Powerset of a list, in ascending order of size. --- Assumes the supplied list has no duplicate elements. -powerSet :: [a] -> [[a]] -powerSet as = - concatMap (`combinations` as) [1..length as] - --- |Combinations of n elements from a list, each being returned in the --- order that they appear in the list. -combinations :: Int -> [a] -> [[a]] -combinations _ [] = [] -- Don't include empty combinations -combinations n as@(ah:at) - | n <= 0 = [[]] - | n > length as = [] - | n == length as = [as] - | otherwise = map (ah:) (combinations (n-1) at) ++ - combinations n at - -{- --- |Return list of integers from lo to hi. -intRange :: Int -> Int -> [Int] -intRange lo hi = take (hi-lo+1) (iterate (+1) 1) --} - -{- --- Tests -testcomb0 = combinations 0 "abcd" -- [] -testcomb1 = combinations 1 "abcd" -- ["a","b","c","d"] -testcomb2 = combinations 2 "abcd" -- ["ab","ac","ad","bc","bd","cd"] -testcomb3 = combinations 3 "abcd" -- ["abc","abd","acd","bcd"] -testcomb4 = combinations 4 "abcd" -- ["abcd"] -testcomb5 = combinations 5 "abcd" -- [] -testpower = powerSet "abc" -- ["a","b","c","ab","ac","bc","abc"] --} - ------------------------------------------------------------- --- Permutations of a list ------------------------------------------------------------- - --- This algorithm is copied from an email by S.D.Mechveliani --- http://www.dcs.gla.ac.uk/mail-www/haskell/msg01936.html -permutations :: [a] -> [[a]] -permutations [] = [[]] -permutations (j:js) = addOne $ permutations js - where - addOne = foldr ((++) . ao) [] - - ao [] = [[j]] - ao (k:ks) = (j:k:ks) : map (k:) (ao ks) - -{- -testperm = permutations [1,2,3] == - [[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]] --} - ------------------------------------------------------------- --- List product ------------------------------------------------------------- - --- |Given a list of lists, construct a new list of lists where --- each member of the new list is the same length as the original --- list, and each member corresponds to a different choice of --- one element from each of the original members in the --- corresponding position. Thus: --- --- > listProduct [[a1,a2],[b1],[c1,c2]] = --- > [ [a1,b1,c1], [a1,b1,c2], [a2,b1,c1], [a2,b1,c2] ] --- --- Note: The length of the resulting list is the prodicty of --- lengths of the components of the original list. Thus, if --- any member of the original list is empty then so is the --- resulting list: --- --- > listProduct [[a1,a2],[],[c1,c2]] = [] --- --- NOTE: this is subsumed by 'sequence' --- -listProduct :: [[a]] -> [[a]] -listProduct [] = [[]] -listProduct (as:ass) = concat [ map (a:) (listProduct ass) | a <- as ] - -{- -test1 = listProduct [["a1","a2"],["b1"],["c1","c2"]] -test2 = listProduct [["a1","a2"],[],["c1","c2"]] - -lp [] = [[]] -lp (as:ass) = concatMap (\a -> (map (a:) (lp ass))) as --} - ------------------------------------------------------------- --- Powersequence (?) -- all sequences from some base values ------------------------------------------------------------- - --- |Construct list of lists of sequences of increasing length -powerSeqBylen :: [a] -> [[a]] -> [[[a]]] -powerSeqBylen rs ps = ps : powerSeqBylen rs (powerSeqNext rs ps) - --- |Return sequences of length n+1 given original sequence --- and list of all sequences of length n -powerSeqNext :: [a] -> [[a]] -> [[a]] -powerSeqNext rs rss = [ h:t | t <- rss, h <- rs ] - --- |Return all powersequences of a given length -powerSequencesLen :: Int -> [a] -> [[a]] -powerSequencesLen len rs = powerSeqBylen rs [[]] !! len - ------------------------------------------------------------- -- Functions, lists and monads ------------------------------------------------------------ @@ -307,36 +75,10 @@ fmonadtest = fmonad [(1*),(2*),(3*)] 3 -- [3,6,9] -} --- |Test if a value satisfies all predicates in a list --- -allp :: [a->Bool] -> a -> Bool -allp ps a = and (flist ps a) - -{- -allptest0 = allp [(>=1),(>=2),(>=3)] 0 -- False -allptest1 = allp [(>=1),(>=2),(>=3)] 1 -- False -allptest2 = allp [(>=1),(>=2),(>=3)] 2 -- False -allptest3 = allp [(>=1),(>=2),(>=3)] 3 -- True -allptest = and [not allptest0,not allptest1,not allptest2,allptest3] --} - --- |Test if a value satisfies any predicate in a list --- -anyp :: [a->Bool] -> a -> Bool -anyp ps a = or (flist ps a) - -{- -anyptest0 = anyp [(>=1),(>=2),(>=3)] 0 -- False -anyptest1 = anyp [(>=1),(>=2),(>=3)] 1 -- True -anyptest2 = anyp [(>=1),(>=2),(>=3)] 2 -- True -anyptest3 = anyp [(>=1),(>=2),(>=3)] 3 -- True -anyptest = and [not anyptest0,anyptest1,anyptest2,anyptest3] --} - - -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/src/Swish/Utils/LookupMap.hs b/src/Swish/Utils/LookupMap.hs deleted file mode 100644 --- a/src/Swish/Utils/LookupMap.hs +++ /dev/null @@ -1,454 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} -{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} -{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : LookupMap --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : A lot of LANGUAGE extensions... --- --- This module defines a lookup table format and associated functions --- used by the graph matching code. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Generic list-of-pairs lookup functions ------------------------------------------------------------- - -module Swish.Utils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap, makeLookupMap, listLookupMap - , reverseLookupMap - , keyOrder - , mapFind, mapFindMaybe, mapContains - , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap - , mapAdd, mapAddIfNew - , mapDelete, mapDeleteAll - , mapApplyToAll, mapTranslate - , mapEq, mapKeys, mapVals - , mapSelect, mapMerge - , mapTranslateKeys, mapTranslateVals - , mapTranslateEntries, mapTranslateEntriesM - - ) - where - -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import qualified Data.List as L - -import Control.Arrow (first, second) - -import Data.Ord (comparing) - -import Swish.Utils.ListHelpers (equiv) - --- this is in Data.Tuple in base 4.3 -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) - ------------------------------------------------------------- --- Class for lookup map entries ------------------------------------------------------------- - --- |@LookupEntryClass@ defines essential functions of any datatype --- that can be used to make a 'LookupMap'. --- --- Minimal definition: @newEntry@ and @keyVal@ --- -class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v - where - newEntry :: (k,v) -> a - keyVal :: a -> (k,v) - - entryKey :: a -> k - entryKey = fst . keyVal - - entryVal :: a -> v - entryVal = snd . keyVal - - entryEq :: (Eq v) => a -> a -> Bool - entryEq e1 e2 = keyVal e1 == keyVal e2 - - entryShow :: (Show v) => a -> String - entryShow e = show k ++ ":" ++ show v where (k,v) = keyVal e - - kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2 - kmap f = newEntry . first f . keyVal - - vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2 - vmap f = newEntry . second f . keyVal - --- |Predefine a pair of appropriate values as a valid lookup table entry --- (i.e. an instance of LookupEntryClass). --- -instance (Eq k, Show k) => LookupEntryClass (k,v) k v where - newEntry = id - keyVal = id - --- |Define a lookup map based on a list of values. --- --- Note: the class constraint that a is an instance of 'LookupEntryClass' --- is not defined here, for good reasons (which I forget right now, but --- something to do with the method dictionary being superfluous on --- an algebraic data type). --- -data LookupMap a = LookupMap [a] - deriving (Functor, F.Foldable, T.Traversable) - -{- -TODO: could add - -instance Monoid (LookupMap a) where - mempty = LookupMap [] - mappend = mapMerge - -but may need constraints on a, do not -want to add instances at this time, and is -it really useful? - --} - -gLM :: LookupMap a -> [a] -gLM (LookupMap es) = es - --- TODO: See also 'mapEq' --- (why not just use that for the Eq instance? I don't know: it's probably historic.) --- - --- |Define equality of 'LookupMap' values based on equality of entries. --- --- (This is possibly a poor definition, as it is dependent on ordering --- of list members. But it passes all current test cases, and is used --- only for testing.) --- -instance (Eq a) => Eq (LookupMap a) where - LookupMap es1 == LookupMap es2 = es1 == es2 - --- |Define Show instance for LookupMap based on Showing the --- list of entries. --- -instance (Show a ) => Show (LookupMap a) where - show (LookupMap es) = "LookupMap " ++ show es - -{- -TODO: should the LookupEntryClass constraint be removed from -emptyLookupMap and makeLookupMap? - -I guess not since LookupMap is exported, so users can use -that if they do not need the constraint. --} - --- |Empty lookup map of arbitrary (i.e. polymorphic) type. --- -emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a -emptyLookupMap = LookupMap [] - --- |Function to create a `LookupMap` from a list of entries. --- --- Currently, this is trivial but future versions could be --- more substantial. --- -makeLookupMap :: (LookupEntryClass a k v) => [a] -> LookupMap a -makeLookupMap = LookupMap - --- |Return list of lookup map entries. --- --- Currently, this is trivial but future versions could be --- more substantial. --- -listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a] -listLookupMap = gLM - --- |Given a lookup map entry, return a new entry that can be used --- in the reverse direction of lookup. This is used to construct --- a reverse LookupMap. --- -reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k) - => a1 -> a2 -reverseEntry = newEntry . swap . keyVal - --- |Given a lookup map, return a new map that can be used --- in the opposite direction of lookup. --- -reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b) - => LookupMap a1 -> LookupMap a2 -reverseLookupMap = fmap reverseEntry - --- |Given a pair of lookup entry values, return the ordering of their --- key values. --- -keyOrder :: (LookupEntryClass a k v, Ord k) - => a -> a -> Ordering -keyOrder = comparing entryKey - --- Local helper function to build a new LookupMap from --- a new entry and an exiting map. --- -mapCons :: a -> LookupMap a -> LookupMap a -mapCons e (LookupMap es) = LookupMap (e:es) - --- |Find key in lookup map and return corresponding value, --- otherwise return default supplied. --- -mapFind :: (LookupEntryClass a k v) => v -> k -> LookupMap a -> v -mapFind def key (LookupMap es) = foldr match def es where - match ent alt - | key == entryKey ent = entryVal ent - | otherwise = alt - --- |Find key in lookup map and return Just the corresponding value, --- otherwise return Nothing. --- -mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v -mapFindMaybe key (LookupMap es) = foldr match Nothing es where - match ent alt - | key == entryKey ent = Just (entryVal ent) - | otherwise = alt - --- |Test to see if key is present in the supplied map --- -mapContains :: (LookupEntryClass a k v) => - LookupMap a -> k -> Bool -mapContains (LookupMap es) key = any match es where - match ent = key == entryKey ent - --- |Replace an existing occurrence of a key a with a new key-value pair. --- --- The resulting lookup map has the same form as the original in all --- other respects. Assumes exactly one occurrence of the supplied key. --- -mapReplace :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplace (LookupMap (e:es)) newe - | entryKey e == entryKey newe = LookupMap (newe:es) - | otherwise = mapAdd more e where - more = mapReplace (LookupMap es) newe -mapReplace _ newe = - error ("mapReplace: Key value not found in lookup table: "++ - Prelude.show (entryKey newe)) - --- |Replace an existing occurrence of a key a with a new key-value pair, --- or add a new key-value pair if the supplied key is not already present. --- -mapReplaceOrAdd :: (LookupEntryClass a k v) => - a -> LookupMap a -> LookupMap a -mapReplaceOrAdd newe (LookupMap (e:es)) - | entryKey e == entryKey newe = LookupMap (newe:es) - | otherwise = mapCons e more where - more = mapReplaceOrAdd newe (LookupMap es) -mapReplaceOrAdd newe (LookupMap []) = LookupMap [newe] - --- |Replace any occurrence of a key a with a new key-value pair. --- --- The resulting lookup map has the same form as the original in all --- other respects. --- -mapReplaceAll :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplaceAll (LookupMap (e:es)) newe = mapCons e' more where - more = mapReplaceAll (LookupMap es) newe - e' = if entryKey e == entryKey newe then newe else e -mapReplaceAll (LookupMap []) _ = LookupMap [] - --- |Replace any occurrence of a key in the first argument with a --- corresponding key-value pair from the second argument, if present. --- --- This could be implemented by multiple applications of 'mapReplaceAll', --- but is arranged differently so that only one new @LookupMap@ value is --- created. --- --- Note: keys in the new map that are not present in the old map --- are not included in the result map --- -mapReplaceMap :: (LookupEntryClass a k v) => - LookupMap a -> LookupMap a -> LookupMap a -mapReplaceMap (LookupMap (e:es)) newmap = mapCons e' more where - more = mapReplaceMap (LookupMap es) newmap - e' = newEntry (k, mapFind v k newmap) - (k,v) = keyVal e -mapReplaceMap (LookupMap []) _ = LookupMap [] - --- |Add supplied key-value pair to the lookup map. --- --- This is effectively an optimized case of 'mapReplaceOrAdd' or 'mapAddIfNew', --- where the caller guarantees to avoid duplicate key values. --- -mapAdd :: LookupMap a -> a -> LookupMap a -mapAdd emap e = mapCons e emap - --- |Add supplied key-value pair to the lookup map, --- only if the key value is not already present. --- -mapAddIfNew :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapAddIfNew emap e = if mapContains emap (entryKey e) - then emap - else mapCons e emap - --- |Delete supplied key value from the lookup map. --- --- This function assumes exactly one occurrence. --- -mapDelete :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDelete (LookupMap (e:es)) k - | k == entryKey e = LookupMap es - | otherwise = mapCons e more where - more = mapDelete (LookupMap es) k -mapDelete _ k = - error ("mapDelete: Key value not found in lookup table: " ++ Prelude.show k) - --- |Delete any occurrence of a supplied key value from the lookup map. --- -mapDeleteAll :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDeleteAll (LookupMap (e:es)) k = - if entryKey e == k then more else mapCons e more where - more = mapDeleteAll (LookupMap es) k -mapDeleteAll (LookupMap []) _ = LookupMap [] - --- |Return a list of values obtained by applying a function to each key --- in the map. Creates an alternative set of values that can be --- retrieved using mapTranslate. --- -mapApplyToAll :: (LookupEntryClass a k v) => - LookupMap a -> (k -> w) -> [w] -mapApplyToAll es f = gLM $ fmap (f . entryKey) es - --- |Find a node in a lookup map list, and returns the --- corresponding value from a supplied list. The appropriate ordering --- of the list is not specified here, but an appropriately ordered list --- may be obtained by 'mapApplyToAll'. --- -mapTranslate :: (LookupEntryClass a k v) => - LookupMap a -> [w] -> k -> w -> w -mapTranslate (LookupMap (e:es)) (w:ws) k def - | k == entryKey e = w - | otherwise = mapTranslate (LookupMap es) ws k def -mapTranslate _ _ _ def = def - --- |Compare two lookup maps for equality. --- --- Two maps are equal if they have the same set of keys, and if --- each key maps to an equivalent value. --- -mapEq :: (LookupEntryClass a k v, Eq v) => - LookupMap a -> LookupMap a -> Bool -mapEq es1 es2 = - ks1 `equiv` ks2 && - and [ mapFindMaybe k es1 == mapFindMaybe k es2 | k <- ks1 ] - where - ks1 = mapKeys es1 - ks2 = mapKeys es2 - --- |Return the list of keys in a supplied LookupMap --- -mapKeys :: (LookupEntryClass a k v) => - LookupMap a -> [k] -mapKeys (LookupMap es) = L.nub $ map entryKey es - --- |Return list of distinct values in a supplied LookupMap --- -mapVals :: (Eq v, LookupEntryClass a k v) => - LookupMap a -> [v] -mapVals (LookupMap es) = L.nub $ map entryVal es - --- |Select portion of a lookup map that corresponds to --- a supplied list of keys --- -mapSelect :: (LookupEntryClass a k v) => - LookupMap a -> [k] -> LookupMap a -mapSelect (LookupMap es) ks = - LookupMap $ filter (keyIn ks) es - where - keyIn iks e = entryKey e `elem` iks - --- |Merge two lookup maps, ensuring that if the same key appears --- in both maps it is associated with the same value. --- -mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) => - LookupMap a -> LookupMap a -> LookupMap a -mapMerge (LookupMap s1) (LookupMap s2) = - LookupMap $ merge (L.sortBy keyOrder s1) (L.sortBy keyOrder s2) - where - merge es1 [] = es1 - merge [] es2 = es2 - merge es1@(e1:et1) es2@(e2:et2) = - case keyOrder e1 e2 of - LT -> e1 : merge et1 es2 - GT -> e2 : merge es1 et2 - EQ -> if e1 /= e2 - then error ("mapMerge key conflict: " ++ show e1 - ++ " with " ++ show e2) - else e1 : merge et1 et2 - --- |An fmap-like function that returns a new lookup map that is a --- copy of the supplied map with entry keys replaced according to --- a supplied function. --- -mapTranslateKeys :: (LookupEntryClass a1 k1 v, LookupEntryClass a2 k2 v) => - (k1 -> k2) -> LookupMap a1 -> LookupMap a2 -mapTranslateKeys f = fmap (kmap f) - --- |An fmap-like function that returns a new lookup map that is a --- copy of the supplied map with entry values replaced according to --- a supplied function. --- -mapTranslateVals :: (LookupEntryClass a1 k v1, LookupEntryClass a2 k v2) => - (v1 -> v2) -> LookupMap a1 -> LookupMap a2 -mapTranslateVals f = fmap (vmap f) - --- |A function that returns a new lookup map that is a copy of the --- supplied map with complete entries replaced according to --- a supplied function. --- -mapTranslateEntries :: (a1 -> a2) -> LookupMap a1 -> LookupMap a2 -mapTranslateEntries = fmap - --- |A monadic form of `mapTranslateEntries` which is --- the same as `Data.Traversable.mapM`. --- --- Since `LookupMap` now has a `Data.Traversable.Traversable` instance --- this is just `T.mapM`. --- -mapTranslateEntriesM :: (Monad m) - => (a1 -> m a2) -> LookupMap a1 -> m (LookupMap a2) -mapTranslateEntriesM = T.mapM -{- -mapTranslateEntriesM f (LookupMap es) = - do { m2 <- mapM f es - ; return $ LookupMap m2 - } --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/MiscHelpers.hs b/src/Swish/Utils/MiscHelpers.hs deleted file mode 100644 --- a/src/Swish/Utils/MiscHelpers.hs +++ /dev/null @@ -1,69 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : MiscHelpers --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module defines a random set of helper functions --- used by the graph handling code. --- --- This module is *deprecated* and will be removed at the next possible --- release. --- --------------------------------------------------------------------------------- - -module Swish.Utils.MiscHelpers - ( hash - , hashModulus - ) -where - ------------------------------------------------------------- --- Hash function and values ------------------------------------------------------------- --- --- Simple hash function based on Sedgewick, Algorithms in C, p 233 --- (choose mx*cm+255 < maxBound) --- 'seed' is an additional parameter that allows the function --- to be varied for re-hashing. - -hashModulus :: Int -hashModulus = 16000001 - -hash :: Int -> String -> Int -hash seed = hash1 seed (64+seed) hashModulus - -hash1 :: Int -> Int -> Int -> String -> Int -hash1 sofar cm mx (c:str) = hash1 (( sofar*cm + fromEnum c ) `rem` mx) cm mx str -hash1 sofar _ _ [] = sofar - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/Namespace.hs b/src/Swish/Utils/Namespace.hs deleted file mode 100644 --- a/src/Swish/Utils/Namespace.hs +++ /dev/null @@ -1,222 +0,0 @@ -{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Namespace --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : TypeSynonymInstances, MultiParamTypeClasses, FlexibleInstances, OverloadedStrings --- --- This module defines algebraic datatypes for namespaces and scoped names. --- --- For these purposes, a namespace is a prefix and URI used to identify --- a namespace (cf. XML namespaces), and a scoped name is a name that --- is scoped by a specified namespace. --- --------------------------------------------------------------------------------- - -module Swish.Utils.Namespace - ( Namespace - , makeNamespace, makeNamespaceQName - , getNamespacePrefix, getNamespaceURI, getNamespaceTuple - -- , nullNamespace - , ScopedName - , getScopeNamespace, getScopeLocal - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - , matchName - , makeScopedName - , makeQNameScopedName - , makeURIScopedName - , makeNSScopedName - , nullScopedName - , namespaceToBuilder - ) - where - -import Swish.Utils.QName (QName, newQName, getQNameURI, getNamespace, getLocalName) -import Swish.Utils.LookupMap (LookupEntryClass(..)) - -import Data.Monoid (Monoid(..)) -import Data.String (IsString(..)) -import Data.Maybe (fromMaybe) - -import Network.URI (URI(..), parseURIReference, nullURI) - -import qualified Data.Text as T -import qualified Data.Text.Lazy.Builder as B - ------------------------------------------------------------- --- Namespace, having a prefix and a URI ------------------------------------------------------------- - --- |A NameSpace value consists of an optional prefix and a corresponding URI. --- - -data Namespace = Namespace (Maybe T.Text) URI --- data Namespace = Namespace (Maybe T.Text) !URI - -{- - { - nsPrefix :: Maybe T.Text - , nsURI :: URI - } --} - -getNamespacePrefix :: Namespace -> Maybe T.Text -getNamespacePrefix (Namespace p _) = p - -getNamespaceURI :: Namespace -> URI -getNamespaceURI (Namespace _ u) = u - -getNamespaceTuple :: Namespace -> (Maybe T.Text, URI) -getNamespaceTuple (Namespace p u) = (p, u) - --- | Equality is defined by the URI, not by the prefix --- (so the same URI with different prefixes will be --- considered to be equal). -instance Eq Namespace where - (Namespace _ u1) == (Namespace _ u2) = u1 == u2 - -instance Show Namespace where - show (Namespace (Just p) u) = show p ++ ":<" ++ show u ++ ">" - show (Namespace _ u) = "<" ++ show u ++ ">" - -instance LookupEntryClass Namespace (Maybe T.Text) URI where - keyVal (Namespace pre uri) = (pre,uri) - newEntry (pre,uri) = Namespace pre uri - -makeNamespace :: Maybe T.Text -> URI -> Namespace -makeNamespace = Namespace - -makeNamespaceQName :: Namespace -> T.Text -> QName -makeNamespaceQName (Namespace _ uri) = newQName uri - -{- -nullNamespace :: Namespace -nullNamespace = Namespace Nothing "" --} - --- | Utility routine to create a \@prefix line (matching N3/Turtle) --- grammar for this namespace. --- -namespaceToBuilder :: Namespace -> B.Builder -namespaceToBuilder (Namespace pre uri) = - mconcat $ map B.fromText - [ "@prefix ", fromMaybe "" pre, ": <", T.pack (show uri), "> .\n"] - ------------------------------------------------------------- --- ScopedName, made from a namespace and a local name ------------------------------------------------------------- - --- | A full ScopedName value has a QName prefix, namespace URI --- and a local part. ScopedName values may omit the prefix --- (see 'Namespace') or the local part. --- --- Some applications may handle null namespace URIs as meaning --- the local part is relative to some base URI. --- -data ScopedName = ScopedName !QName Namespace T.Text - --- | Returns the local part. -getScopeLocal :: ScopedName -> T.Text -getScopeLocal (ScopedName _ _ l) = l - --- | Returns the namespace. -getScopeNamespace :: ScopedName -> Namespace -getScopeNamespace (ScopedName _ ns _) = ns - --- | Returns the prefix of the namespace, if set. -getScopePrefix :: ScopedName -> Maybe T.Text -getScopePrefix = getNamespacePrefix . getScopeNamespace - --- | Returns the URI of the namespace. -getScopeURI :: ScopedName -> URI -getScopeURI = getNamespaceURI . getScopeNamespace - --- | This is not total since it will fail if the input string is not a valid URI. -instance IsString ScopedName where - fromString s = - maybe (error ("Unable to convert " ++ s ++ " into a ScopedName")) - makeURIScopedName (parseURIReference s) - --- | Scoped names are equal if their corresponding QNames are equal -instance Eq ScopedName where - (ScopedName qn1 _ _) == (ScopedName qn2 _ _) = qn1 == qn2 - --- | Scoped names are ordered by their QNames -instance Ord ScopedName where - (ScopedName qn1 _ _) <= (ScopedName qn2 _ _) = qn1 <= qn2 - --- | If there is a namespace associated then the Show instance --- uses @prefix:local@, otherwise @@. -instance Show ScopedName where - show (ScopedName qn n l) = case getNamespacePrefix n of - Just pre -> T.unpack $ mconcat [pre, ":", l] - _ -> show qn -- "<" ++ show (getNamespaceURI n) ++ T.unpack l ++ ">" - --- |Get the QName corresponding to a scoped name. -getQName :: ScopedName -> QName -getQName (ScopedName qn _ _) = qn - --- |Get URI corresponding to a scoped name (using RDF conventions). -getScopedNameURI :: ScopedName -> URI -getScopedNameURI = getQNameURI . getQName - --- for the moment leave matchName using String rather than Text - --- |Test if supplied string matches the display form of a --- scoped name. -matchName :: String -> ScopedName -> Bool -matchName str nam = str == show nam - --- |Construct a ScopedName from prefix, URI and local name -makeScopedName :: Maybe T.Text -> URI -> T.Text -> ScopedName -makeScopedName pre nsuri local = - ScopedName (newQName nsuri local) (Namespace pre nsuri) local - --- |Construct a ScopedName from a QName. -makeQNameScopedName :: Maybe T.Text -> QName -> ScopedName -makeQNameScopedName pre qn = ScopedName qn (Namespace pre (getNamespace qn)) (getLocalName qn) - --- | Construct a ScopedName for a bare URI (the label is set to \"\"). -makeURIScopedName :: URI -> ScopedName -makeURIScopedName uri = makeScopedName Nothing uri "" - --- | Construct a ScopedName from a Namespace and local component -makeNSScopedName :: Namespace -> T.Text -> ScopedName -makeNSScopedName ns local = ScopedName (newQName (getNamespaceURI ns) local) ns local - --- | This should never appear as a valid name -nullScopedName :: ScopedName -nullScopedName = makeURIScopedName nullURI - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/PartOrderedCollection.hs b/src/Swish/Utils/PartOrderedCollection.hs deleted file mode 100644 --- a/src/Swish/Utils/PartOrderedCollection.hs +++ /dev/null @@ -1,386 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : PartOrderedCollection --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module provides methods to support operations on partially ordered --- collections. The partial ordering relationship is represented by --- `Maybe Ordering`. --- --- Thanks to members of the haskell-cafe mailing list - --- Robert (rvollmert-lists\@gmx.net) and --- Tom Pledger (Tom.Pledger\@peace.com) - --- who suggested key ideas on which some of the code in this module is based. --- --------------------------------------------------------------------------------- - --- at present the only user of this module is Swish.RDF.ClassRestrictionRule - -module Swish.Utils.PartOrderedCollection - ( PartCompare - , minima - , maxima - , partCompareEq - , partComparePair - , partCompareListMaybe - , partCompareListSubset - , partCompareListPartOrd - , partCompareMaybe - - -- the following are currently unused - , partCompareOrd - , partCompareListOrd - ) - where - -import Data.List (foldl') - ------------------------------------------------------------- --- Type of partial compare function ------------------------------------------------------------- - -type PartCompare a = a -> a -> Maybe Ordering - ------------------------------------------------------------- --- Functions for minima and maxima of a part-ordered list ------------------------------------------------------------- - --- |This function finds the maxima in a list of partially --- ordered values, preserving the sequence of retained --- values from the supplied list. --- --- It returns all those values in the supplied list --- for which there is no larger element in the list. --- -maxima :: PartCompare a -> [a] -> [a] -maxima cmp = foldl' add [] - where - add [] e = [e] - add ms@(m:mr) e = case cmp m e of - Nothing -> m : add mr e - Just GT -> ms - Just EQ -> ms - Just LT -> add mr e - --- |This function finds the minima in a list of partially --- ordered values, preserving the sequence of retained --- values from the supplied list. --- --- It returns all those values in the supplied list --- for which there is no smaller element in the list. --- -minima :: PartCompare a -> [a] -> [a] -minima cmp = maxima (flip cmp) - ------------------------------------------------------------- --- Partial ordering comparison functions ------------------------------------------------------------- - --- |Partial ordering for Eq values -partCompareEq :: (Eq a) => a -> a -> Maybe Ordering -partCompareEq a1 a2 = if a1 == a2 then Just EQ else Nothing - --- |Partial ordering for Ord values -partCompareOrd :: (Ord a) => a -> a -> Maybe Ordering -partCompareOrd a1 a2 = Just $ compare a1 a2 - --- |Part-ordering comparison on pairs of values, --- where each has a part-ordering relationship -partComparePair :: - (a->a->Maybe Ordering) -> (b->b->Maybe Ordering) -> (a,b) -> (a,b) - -> Maybe Ordering -partComparePair cmpa cmpb (a1,b1) (a2,b2) = case (cmpa a1 a2,cmpb b1 b2) of - (_,Nothing) -> Nothing - (jc1,Just EQ) -> jc1 - (Nothing,_) -> Nothing - (Just EQ,jc2) -> jc2 - (Just c1,Just c2) -> if c1 == c2 then Just c1 else Nothing - --- |Part-ordering comparison on lists of partially ordered values, where: --- --- [@as==bs@] if members of as are all equal to corresponding members of bs --- --- [@as<=bs@] if members of as are all less than or equal to corresponding --- members of bs --- --- [@as>=bs@] if members of as are all greater than or equal to corresponding --- members of bs --- --- [otherwise] as and bs are unrelated --- --- The comparison is restricted to the common elements in the two lists. --- -partCompareListPartOrd :: PartCompare a -> [a] -> [a] -> Maybe Ordering -partCompareListPartOrd cmp a1s b1s = pcomp a1s b1s EQ - where - pcomp (a:as) (b:bs) ordp = case cmp a b of - Just rel -> pcomp1 as bs rel ordp - _ -> Nothing - pcomp _ _ ordp = Just ordp - -- pcomp [] [] ordp = Just ordp - - pcomp1 as bs ordn EQ = pcomp as bs ordn - pcomp1 as bs EQ ordp = pcomp as bs ordp - pcomp1 as bs ordn ordp = - if ordn == ordp then pcomp as bs ordp else Nothing - --- |Part-ordering comparison on lists of Ord values, where: --- --- [@as==bs@] if members of as are all equal to corresponding members of bs --- --- [@as<=bs@] if members of as are all less than or equal to corresponding --- members of bs --- --- [@as>=bs@] if members of as are all greater than or equal to corresponding --- members of bs --- --- [otherwise] as and bs are unrelated --- -partCompareListOrd :: (Ord a) => [a] -> [a] -> Maybe Ordering -partCompareListOrd = partCompareListPartOrd (Just `c2` compare) - where c2 = (.) . (.) - --- |Part-ordering comparison for Maybe values. -partCompareMaybe :: (Eq a) => Maybe a -> Maybe a -> Maybe Ordering -partCompareMaybe Nothing Nothing = Just EQ -partCompareMaybe (Just _) Nothing = Just GT -partCompareMaybe Nothing (Just _) = Just LT -partCompareMaybe (Just a) (Just b) = if a == b then Just EQ else Nothing - --- |Part-ordering comparison on lists of Maybe values. -partCompareListMaybe :: (Eq a) => [Maybe a] -> [Maybe a] -> Maybe Ordering -partCompareListMaybe = partCompareListPartOrd partCompareMaybe - --- |Part-ordering comparison on lists based on subset relationship -partCompareListSubset :: (Eq a) => [a] -> [a] -> Maybe Ordering -partCompareListSubset a b - | aeqvb = Just EQ - | asubb = Just LT - | bsuba = Just GT - | otherwise = Nothing - where - asubb = a `subset` b - bsuba = b `subset` a - aeqvb = asubb && bsuba - x `subset` y = and [ ma `elem` y | ma <- x ] - ------------------------------------------------------------- --- Test cases ------------------------------------------------------------- - -{- - -notTrueFalse = Nothing :: Maybe Bool - --- partCompareListOrd -test01 = partCompareListOrd [1,2,3] [1,2,3] == Just EQ -test02 = partCompareListOrd [1,2,3] [2,3,4] == Just LT -test03 = partCompareListOrd [1,2,4] [1,2,3] == Just GT -test04 = partCompareListOrd [1,2,3] [2,1,3] == Nothing - --- partCompareMaybe -test11 = partCompareMaybe (Just True) (Just True) == Just EQ -test12 = partCompareMaybe (Just True) (Just False) == Nothing -test13 = partCompareMaybe notTrueFalse (Just False) == Just LT -test14 = partCompareMaybe (Just True) notTrueFalse == Just GT -test15 = partCompareMaybe notTrueFalse notTrueFalse == Just EQ - --- partCompareListMaybe -test21 = partCompareListMaybe [Just True,Just False] - [Just True,Just False] - == Just EQ -test22 = partCompareListMaybe [Just True,Just False] - [Just True,Just True] - == Nothing -test23 = partCompareListMaybe [Just False,Just True] - [Just False,Just True] - == Just EQ -test24 = partCompareListMaybe [Nothing, Just True] - [Just False,Just True] - == Just LT -test25 = partCompareListMaybe [Just False,Just True] - [Just False,Nothing] - == Just GT -test26 = partCompareListMaybe [Nothing, Just True] - [Just False,Nothing] - == Nothing -test27 = partCompareListMaybe [Nothing,Just True] - [Nothing,Nothing] - == Just GT -test28 = partCompareListMaybe [notTrueFalse,notTrueFalse] - [notTrueFalse,notTrueFalse] - == Just EQ - --- minima, maxima -test31a = maxima partCompareListMaybe ds1a == ds1b -test31b = minima partCompareListMaybe ds1a == ds1c -ds1a = - [ [Just 'a',Just 'b',Just 'c'] - , [Just 'a',Just 'b',Nothing ] - , [Just 'a',Nothing ,Just 'c'] - , [Just 'a',Nothing ,Nothing ] - , [Nothing ,Just 'b',Just 'c'] - , [Nothing ,Just 'b',Nothing ] - , [Nothing ,Nothing ,Just 'c'] - , [Nothing ,Nothing ,Nothing ] - ] -ds1b = - [ [Just 'a',Just 'b',Just 'c'] - ] -ds1c = - [ [Nothing ,Nothing ,Nothing ] - ] - -test32a = maxima partCompareListMaybe ds2a == ds2b -test32b = minima partCompareListMaybe ds2a == ds2c -ds2a = - [ [Just 'a',Just 'b',Nothing ] - , [Just 'a',Nothing ,Just 'c'] - , [Just 'a',Nothing ,Nothing ] - , [Nothing ,Just 'b',Just 'c'] - , [Nothing ,Just 'b',Nothing ] - , [Nothing ,Nothing ,Just 'c'] - ] -ds2b = - [ [Just 'a',Just 'b',Nothing ] - , [Just 'a',Nothing ,Just 'c'] - , [Nothing ,Just 'b',Just 'c'] - ] -ds2c = - [ [Just 'a',Nothing ,Nothing ] - , [Nothing ,Just 'b',Nothing ] - , [Nothing ,Nothing ,Just 'c'] - ] - -test33a = maxima partCompareListMaybe ds3a == ds3b -test33b = minima partCompareListMaybe ds3a == ds3c -ds3a = - [ [Just "a1",Just "b1",Just "c1"] - , [Just "a2",Just "b2",Nothing ] - , [Just "a3",Nothing ,Just "c3"] - , [Just "a4",Nothing ,Nothing ] - , [Nothing ,Just "b5",Just "c5"] - , [Nothing ,Just "b6",Nothing ] - , [Nothing ,Nothing ,Just "c7"] - ] -ds3b = - [ [Just "a1",Just "b1",Just "c1"] - , [Just "a2",Just "b2",Nothing ] - , [Just "a3",Nothing ,Just "c3"] - , [Just "a4",Nothing ,Nothing ] - , [Nothing ,Just "b5",Just "c5"] - , [Nothing ,Just "b6",Nothing ] - , [Nothing ,Nothing ,Just "c7"] - ] -ds3c = - [ [Just "a1",Just "b1",Just "c1"] - , [Just "a2",Just "b2",Nothing ] - , [Just "a3",Nothing ,Just "c3"] - , [Just "a4",Nothing ,Nothing ] - , [Nothing ,Just "b5",Just "c5"] - , [Nothing ,Just "b6",Nothing ] - , [Nothing ,Nothing ,Just "c7"] - ] - - -test34a = maxima partCompareListMaybe ds4a == ds4b -test34b = minima partCompareListMaybe ds4a == ds4c -ds4a = - [ [Just 1, Just 1 ] - , [Just 2, Nothing] - , [Nothing,Just 3 ] - , [Nothing,Nothing] - ] -ds4b = - [ [Just 1, Just 1 ] - , [Just 2, Nothing] - , [Nothing,Just 3 ] - ] -ds4c = - [ [Nothing,Nothing] - ] - --- Check handling of equal values -test35a = maxima partCompareListMaybe ds5a == ds5b -test35b = minima partCompareListMaybe ds5a == ds5c -ds5a = - [ [Just 1, Just 1 ] - , [Just 2, Nothing] - , [Nothing,Just 3 ] - , [Nothing,Nothing] - , [Just 1, Just 1 ] - , [Just 2, Nothing] - , [Nothing,Just 3 ] - , [Nothing,Nothing] - ] -ds5b = - [ [Just 1, Just 1 ] - , [Just 2, Nothing] - , [Nothing,Just 3 ] - ] -ds5c = - [ [Nothing,Nothing] - ] - --- test case 32 with different ordering of values -test36a = maxima partCompareListMaybe ds6a == ds6b -test36b = minima partCompareListMaybe ds6a == ds6c -ds6a = - [ [Just 'a',Just 'b',Nothing ] - , [Nothing ,Nothing ,Just 'c'] - , [Nothing ,Just 'b',Nothing ] - , [Nothing ,Just 'b',Just 'c'] - , [Just 'a',Nothing ,Nothing ] - , [Just 'a',Nothing ,Just 'c'] - ] -ds6b = - [ [Just 'a',Just 'b',Nothing ] - , [Nothing ,Just 'b',Just 'c'] - , [Just 'a',Nothing ,Just 'c'] - ] -ds6c = - [ [Nothing ,Nothing ,Just 'c'] - , [Nothing ,Just 'b',Nothing ] - , [Just 'a',Nothing ,Nothing ] - ] - -test = and - [ test01, test02, test03, test04 - , test11, test12, test13, test14, test15 - , test21, test22, test23, test24, test25, test26, test27, test28 - , test31a, test31b, test32a, test32b, test33a, test33b - , test34a, test34b, test35a, test35b, test36a, test36b - ] - --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/QName.hs b/src/Swish/Utils/QName.hs deleted file mode 100644 --- a/src/Swish/Utils/QName.hs +++ /dev/null @@ -1,277 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : QName --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : OverloadedStrings --- --- This module defines an algebraic datatype for qualified names (QNames). --- --------------------------------------------------------------------------------- - --- At present we support using URI references rather than forcing an absolute --- URI. This is partly to support the existing tests (too lazy to resolve whether --- the tests really should be using relative URIs in this case). - -module Swish.Utils.QName - ( QName - , newQName - , qnameFromURI - , getNamespace - , getLocalName - , getQNameURI - , qnameFromFilePath - ) - where - -import System.Directory (canonicalizePath) - -import Network.URI (URI(..), URIAuth(..) - , parseURIReference) - -import Data.String (IsString(..)) -import Data.Maybe (fromMaybe) - -import Data.Interned (intern, unintern) -import Data.Interned.URI (InternedURI) - -import qualified Data.Text as T - ------------------------------------------------------------- --- Qualified name ------------------------------------------------------------- --- --- cf. http://www.w3.org/TR/REC-xml-names/ - -{-| - -A qualified name, consisting of a namespace URI -and the local part of the identifier. - --} - -{- -For now I have added in storing the actual URI -as well as the namespace component. This may or -may not be a good idea (space vs time saving). --} - -data QName = QName !InternedURI URI T.Text - --- | This is not total since it will fail if the input string is not a valid URI. -instance IsString QName where - fromString = qnameFromString - --- | Equality is determined by a case sensitive comparison of the --- URI. -instance Eq QName where - -- see qnEq comments below - (QName u1 _ _) == (QName u2 _ _) = u1 == u2 - --- ugly, use show instance OR switch to the ordering of InternedURI - -instance Ord QName where - {- - (QName u1 l1) <= (QName u2 l2) = - if up1 /= up2 then up1 <= up2 else (ur1++l1) <= (ur2++l2) - where - n = min (length u1) (length u2) - (up1,ur1) = splitAt n u1 - (up2,ur2) = splitAt n u2 - -} - - -- TODO: which is faster? - -- Now we have changed to InternedURI, we could use the - -- Ord instance of it, but it is unclear to me what the - -- ordering means in that case, and whether the semantics - -- matter here? - (QName u1 _ _) <= (QName u2 _ _) = show u1 <= show u2 - - {- - (QName _ uri1 l1) <= (QName _ uri2 l2) = - if up1 /= up2 then up1 <= up2 else (ur1 ++ T.unpack l1) <= (ur2 ++ T.unpack l2) - where - u1 = show uri1 - u2 = show uri2 - - n = min (length u1) (length u2) - (up1,ur1) = splitAt n u1 - (up2,ur2) = splitAt n u2 - -} - --- | The format used to display the URI is @@. -instance Show QName where - show (QName u _ _) = "<" ++ show u ++ ">" - -{- -Should this be clever and ensure that local doesn't -contain /, say? - -We could also me more clever, and safer, when constructing -the overall uri. --} -newQName :: URI -> T.Text -> QName -newQName ns local = - let l = T.unpack local - uristr = show ns ++ l - uri = fromMaybe (error ("Unable to parse URI from: '" ++ show ns ++ "' + '" ++ l ++ "'")) (parseURIReference uristr) - - {- the following does not work since the semantics of relativeTo do not match the required - behavior here. It may well be better to do something like the following, writing a replacement for - relativeTo, but leave that for a later date. - - let l = T.unpack local - luri = fromMaybe (error ("Unable to parse local name as a URI reference: '" ++ l ++ "'")) (parseRelativeReference l) - uri = fromMaybe (error ("Unable to combine " ++ show ns ++ " with " ++ l)) $ luri `relativeTo` ns - -} - - in QName (intern uri) ns local - -{- - -old behavior - - splitQname "http://example.org/aaa#bbb" = ("http://example.org/aaa#","bbb") - splitQname "http://example.org/aaa/bbb" = ("http://example.org/aaa/","bbb") - splitQname "http://example.org/aaa/" = ("http://example.org/aaa/","") - -Should "urn:foo:bar" have a local name of "" or "foo:bar"? For now go -with the first option. - --} - -qnameFromURI :: URI -> QName -qnameFromURI uri = - let uf = uriFragment uri - up = uriPath uri - q0 = QName iuri uri "" - iuri = intern uri - in case uf of - "#" -> q0 - '#':xs -> QName iuri (uri { uriFragment = "#" }) (T.pack xs) - "" -> case break (=='/') (reverse up) of - ("",_) -> q0 -- path ends in / or is empty - (_,"") -> q0 -- path contains no / - (rlname,rpath) -> QName iuri (uri {uriPath = reverse rpath}) (T.pack (reverse rlname)) - - e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" - -qnameFromString :: String -> QName -qnameFromString s = - maybe (error ("Unable to convert '" ++ s ++ "' into a QName")) - qnameFromURI (parseURIReference s) - --- | Return the URI of the namespace stored in the QName. --- This does not contain the local component. --- -getNamespace :: QName -> URI -getNamespace (QName _ ns _) = ns - --- | Return the local component of the QName. -getLocalName :: QName -> T.Text -getLocalName (QName _ _ l) = l - --- | Returns the full URI of the QName (ie the combination of the --- namespace and local components). -getQNameURI :: QName -> URI -getQNameURI (QName u _ _) = unintern u - -{- -Original used comparison of concatenated strings, -but that was very inefficient. The longer version below -does the comparison without constructing new values but is -no longer valid with the namespace being stored as a URI, -so for now just compare the overall URIs and we can -optimize this at a later date if needed. -qnEq :: QName -> QName -> Bool -qnEq (QName u1 _ _) (QName u2 _ _) = u1 == u2 - -qnEq (QName _ n1 l1) (QName _ n2 l2) = qnEq1 n1 n2 l1 l2 - where - qnEq1 (c1:ns1) (c2:ns2) ln1 ln2 = c1==c2 && qnEq1 ns1 ns2 ln1 ln2 - qnEq1 [] ns2 ln1@(_:_) ln2 = qnEq1 ln1 ns2 [] ln2 - qnEq1 ns1 [] ln1 ln2@(_:_) = qnEq1 ns1 ln2 ln1 [] - qnEq1 [] [] [] [] = True - qnEq1 _ _ _ _ = False --} - -{-| -Convert a filepath to a file: URI stored in a QName. If the -input file path is relative then the working directory is used -to convert it into an absolute path. - -If the input represents a directory then it *must* end in -the directory separator - so for Posix systems use -@\"\/foo\/bar\/\"@ rather than -@\"\/foo\/bar\"@. - -This has not been tested on Windows. --} - -{- -NOTE: not sure what I say directories should end in the path -seperator since - -ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text" -"/Users/dburke/haskell/swish-text" -ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text/" -"/Users/dburke/haskell/swish-text" - --} - --- since we build up the URI manually we could --- create the QName directly, but leave that --- for now. - -qnameFromFilePath :: FilePath -> IO QName -qnameFromFilePath = fmap qnameFromURI . filePathToURI - -emptyAuth :: Maybe URIAuth -emptyAuth = Just $ URIAuth "" "" "" - -filePathToURI :: FilePath -> IO URI -filePathToURI fname = do - ipath <- canonicalizePath fname - - {- - let paths = splitDirectories ipath - txt = intercalate "/" $ case paths of - "/":rs -> rs - _ -> paths - -} - - -- Is manually creating the URI sensible? - -- return $ fromJust $ parseURI $ "file:///" ++ txt - -- return $ URI "file:" emptyAuth txt "" "" - return $ URI "file:" emptyAuth ipath "" "" - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/Utils/ShowM.hs b/src/Swish/Utils/ShowM.hs deleted file mode 100644 --- a/src/Swish/Utils/ShowM.hs +++ /dev/null @@ -1,75 +0,0 @@ --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ShowM --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : H98 --- --- This module defines an extension of the Show class for displaying --- multi-line values. It serves the following purposes: --- --- (1) provides a method with greater layout control of multiline values, --- --- (2) provides a possibility to override the default Show behaviour --- for programs that use the extended ShowM interface, and --- --- (3) uses a ShowS intermediate value to avoid unnecessary --- concatenation of long strings. --- --------------------------------------------------------------------------------- - -module Swish.Utils.ShowM (ShowM(..)) where - ------------------------------------------------------------- --- ShowM framework ------------------------------------------------------------- - --- |ShowM is a type class for values that may be formatted in --- multi-line displays. -class (Show sh) => ShowM sh where - -- |Multi-line value display method - -- Create a multiline displayable form of a value, returned - -- as a 'ShowS' value. The default implementation behaves just - -- like a normal instance of 'Show'. - -- - -- This function is intended to allow the calling function some control - -- of multiline displays by providing: - -- - -- (1) the first line of the value is not preceded by any text, so - -- it may be appended to some preceding text on the same line, - -- - -- (2) the supplied line break string is used to separate lines of the - -- formatted text, and may include any desired indentation, and - -- - -- (3) no newline is output following the final line of text. - showms :: String -> sh -> ShowS - showms _ = shows - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Swish/VarBinding.hs b/src/Swish/VarBinding.hs new file mode 100644 --- /dev/null +++ b/src/Swish/VarBinding.hs @@ -0,0 +1,544 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : VarBinding +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TypeSynonymInstances +-- +-- This module defines functions for representing and manipulating query +-- binding variable sets. This is the key data that mediates between +-- query and back substitution when performing inferences. A framework +-- of query variable modifiers is provided that can be used to +-- implement richer inferences, such as filtering of query results, +-- or replacing values based on known relationships. +-- +-------------------------------------------------------------------------------- + +module Swish.VarBinding + ( VarBinding(..), nullVarBinding + , boundVars, subBinding, makeVarBinding + , applyVarBinding, joinVarBindings, addVarBinding + , VarBindingModify(..), OpenVarBindingModify + , vbmCompatibility, vbmCompose + , composeSequence, findCompositions, findComposition + , VarBindingFilter(..) + , makeVarFilterModify + , makeVarTestFilter, makeVarCompareFilter + , varBindingId, nullVarBindingModify + , varFilterDisjunction, varFilterConjunction + , varFilterEQ, varFilterNE + ) +where + +import Swish.Namespace (ScopedName, getScopeLocal) +import Swish.QName (newLName, getLName) + +import Swish.RDF.Vocabulary (swishName) + +import Swish.Utils.ListHelpers (equiv, subset, flist) + +import Data.List (find, intersect, union, (\\), foldl', permutations) +import Data.LookupMap (LookupEntryClass(..), makeLookupMap, mapFindMaybe) +import Data.Maybe (mapMaybe, fromMaybe, isJust, fromJust, listToMaybe) +import Data.Monoid (mconcat) + +------------------------------------------------------------ +-- Query variable bindings +------------------------------------------------------------ + +-- TODO: is it worth making a Monoid instance of VarBinding? + +-- |VarBinding is the type of an arbitrary variable bindings +-- value, where the type of the bound values is not specified. +-- +data VarBinding a b = VarBinding + { vbMap :: a -> Maybe b + , vbEnum :: [(a,b)] + , vbNull :: Bool + } + +-- |VarBinding is an instance of class Eq, so that variable +-- bindings can be compared for equivalence +-- +instance (Eq a, Eq b) => Eq (VarBinding a b) where + vb1 == vb2 = vbEnum vb1 `equiv` vbEnum vb2 + +-- |VarBinding is an instance of class Show, so that variable +-- bindings can be displayed +-- +instance (Show a, Show b) => Show (VarBinding a b) where + show = show . vbEnum + +-- | maps no query variables. +-- +nullVarBinding :: VarBinding a b +nullVarBinding = VarBinding + { vbMap = const Nothing + , vbEnum = [] + , vbNull = True + } + +-- |Return a list of the variables bound by a supplied variable binding +-- +boundVars :: VarBinding a b -> [a] +boundVars = map fst . vbEnum + +-- |VarBinding subset function, tests to see if one query binding +-- is a subset of another; i.e. every query variable mapping defined +-- by one is also defined by the other. +-- +subBinding :: (Eq a, Eq b) => VarBinding a b -> VarBinding a b -> Bool +subBinding vb1 vb2 = vbEnum vb1 `subset` vbEnum vb2 + +-- |Function to make a variable binding from a list of +-- pairs of variable and corresponding assigned value. +-- +makeVarBinding :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> VarBinding a b +makeVarBinding [] = nullVarBinding +makeVarBinding vrbs = + let selectFrom = flip mapFindMaybe . makeLookupMap + in VarBinding + { vbMap = selectFrom vrbs + , vbEnum = vrbs + , vbNull = False + } + +-- |Apply query binding to a supplied value, returning the value +-- unchanged if no binding is defined +-- +applyVarBinding :: VarBinding a a -> a -> a +applyVarBinding vbind v = fromMaybe v (vbMap vbind v) + +-- |Join a pair of query bindings, returning a new binding that +-- maps all variables recognized by either of the input bindings. +-- If the bindings should overlap, such overlap is not detected and +-- the value from the first binding provided is used arbitrarily. +-- +joinVarBindings :: (Eq a) => VarBinding a b -> VarBinding a b -> VarBinding a b +joinVarBindings vb1 vb2 + | vbNull vb1 = vb2 + | vbNull vb2 = vb1 + | otherwise = VarBinding + { vbMap = mv12 + , vbEnum = map (\v -> (v,fromJust (mv12 v))) bv12 + , vbNull = False + } + where + mv12 = headOrNothing . filter isJust . flist [ vbMap vb1, vbMap vb2 ] + bv12 = boundVars vb1 `union` boundVars vb2 + +-- |Return head of a list of @Maybe@'s, or @Nothing@ if list is empty +-- +-- Use with @filter isJust@ to select a non-Nothing value from a +-- list when such a value is present. +-- +headOrNothing :: [Maybe a] -> Maybe a +headOrNothing [] = Nothing +headOrNothing (a:_) = a + +-- |Add a single new value to a variable binding and return the resulting +-- new variable binding. +-- +addVarBinding :: (Eq a, Show a, Eq b, Show b) => a -> b -> VarBinding a b + -> VarBinding a b +addVarBinding lb val vbind = joinVarBindings vbind $ makeVarBinding [(lb,val)] + +------------------------------------------------------------ +-- Datatypes for variable binding modifiers +------------------------------------------------------------ + +-- |Define the type of a function to modify variable bindings in +-- forward chaining based on rule antecedent matches. This +-- function is used to implement the \"allocated to\" logic described +-- in Appendix B of the RDF semantics document, in which a specific +-- blank node is associated with all matches of some specific value +-- by applications of the rule on a given graph. +-- Use 'id' if no modification of the variable bindings is required. +-- +-- This datatype consists of the modifier function itself, which +-- operates on a list of variable bindings rather than a single +-- variable binding (because some modifications share context across +-- a set of bindings), and some additional descriptive information +-- that allows possible usage patterns to be analyzed. +-- +-- Some usage patterns (see 'vbmUsage' for more details): +-- +-- [filter] all variables are input variables, and the effect +-- of the modifier function is to drop variable bindings that +-- don't satisfy some criterion. +-- Identifiable by an empty element in @vbmUsage@. +-- +-- [source] all variables are output variables: a raw query +-- could be viewed as a source of variable bindings. +-- Identifiable by an element of @vbmUsage@ equal to @vbmVocab@. +-- +-- [modifier] for each supplied variable binding, one or more +-- new variable bindings may be created that contain the +-- input variables bound as supplied plus some additional variables. +-- Identifiable by an element of @vbmUsage@ some subset of @vbmVocab@. +-- +-- A variety of variable usage patterns may be supported by a given +-- modifier: a modifier may be used to define new variable bindings +-- from existing bindings in a number of ways, or simply to check that +-- some required relationship between bindings is satisfied. +-- (Example, for @a + b = c@, any one variable can be deduced from the +-- other two, or all three may be supplied to check that the relationship +-- does indeed hold.) +-- +data VarBindingModify a b = VarBindingModify + { vbmName :: ScopedName + -- ^Name used to identify this variable binding + -- modifier when building inference rules. + , vbmApply :: [VarBinding a b] -> [VarBinding a b] + -- ^Apply variable binding modifier to a + -- list of variable bindings, returning a + -- new list. The result list is not + -- necessarily the same length as the + -- supplied list. + , vbmVocab :: [a] -- ^List of variables used by this modifier. + -- All results of applying this modifier contain + -- bindings for these variables. + , vbmUsage :: [[a]] -- ^List of binding modifier usage patterns + -- supported. Each pattern is characterized as + -- a list of variables for which new bindings + -- may be created by some application of this + -- modifier, assuming that bindings for all other + -- variables in @vbmVocab@ are supplied. + } + +-- |Allow a VarBindingModify value to be accessed using a 'LookupMap'. +-- +instance LookupEntryClass + (VarBindingModify a b) ScopedName (VarBindingModify a b) + where + keyVal vbm = (vbmName vbm,vbm) + newEntry (_,vbm) = vbm + +-- |Type for variable binding modifier that has yet to be instantiated +-- with respect to the variables that it operates upon. +-- +type OpenVarBindingModify lb vn = [lb] -> VarBindingModify lb vn + +-- |Extract variable binding name from @OpenVarBindingModify@ value +-- +-- (Because only the name is required, the application to an undefined +-- list of variable labels should never be evaluated, as long as the +-- name is not dependent on the variable names in any way.) +-- +-- NOT QUITE... some of the functions that create @OpenVarBindingModify@ +-- instances also pattern-match the number of labels provided, forcing +-- evaluation of the labels parameter, even though it's not used. +-- +openVbmName :: OpenVarBindingModify lb vn -> ScopedName +openVbmName ovbm = vbmName (ovbm (error "Undefined labels in variable binding")) + +-- |Allow an @OpenVarBindingModify@ value to be accessed using a @LookupMap@. +-- +instance LookupEntryClass + (OpenVarBindingModify a b) ScopedName (OpenVarBindingModify a b) + where + keyVal ovbm = (openVbmName ovbm,ovbm) + newEntry (_,ovbm) = ovbm + +-- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. +-- +instance Show (OpenVarBindingModify a b) + where + show = show . openVbmName + +-- |Variable binding modifier compatibility test. +-- +-- Given a list of bound variables and a variable binding modifier, return +-- a list of new variables that may be bound, or @Nothing@. +-- +-- Note: if the usage pattern component is well-formed (i.e. all +-- elements different) then at most one element can be compatible with +-- a given input variable set. +-- +vbmCompatibility :: (Eq a) => VarBindingModify a b -> [a] -> Maybe [a] +vbmCompatibility vbm vars = find compat (vbmUsage vbm) + where + compat = vbmCompatibleVars vars (vbmVocab vbm) + +-- |Variable binding usage compatibility test. +-- +-- Returns @True@ if the supplied variable bindings can be compatibly +-- processed by a variable binding usage with supplied vocabulary and +-- usage pattern. +-- +vbmCompatibleVars :: + (Eq a) + => [a] -- ^ variables supplied with bindings + -> [a] -- ^ variables returned with bindings by a modifier + -> [a] -- ^ variables assigned new bindings by a modifier + -> Bool +vbmCompatibleVars bvars vocab ovars = + null (ivars `intersect` ovars) && -- ivars and ovars don't overlap + null ((vocab \\ ovars) \\ ivars) -- ovars and ivars cover vocab + where + ivars = bvars `intersect` vocab + +-- |Compose variable binding modifiers. +-- +-- Returns @Just a@ new variable binding modifier that corresponds to +-- applying the first supplied modifier and then applying the second +-- one, or @Nothing@ if the two modifiers cannot be compatibly composed. +-- +-- NOTE: this function does not, in general, commute. +-- +-- NOTE: if there are different ways to achieve the same usage, that +-- usage is currently repeated in the result returned. +-- +vbmCompose :: (Eq a) => VarBindingModify a b -> VarBindingModify a b + -> Maybe (VarBindingModify a b) +vbmCompose + (VarBindingModify nam1 app1 voc1 use1) + (VarBindingModify nam2 app2 voc2 use2) + | not (null use12) = Just VarBindingModify + { vbmName = name + , vbmApply = app2 . app1 + , vbmVocab = voc1 `union` voc2 + , vbmUsage = use12 + } + | otherwise = Nothing + where + use12 = compatibleUsage voc1 use1 use2 + getName = getLName . getScopeLocal + -- since _ is a valid LName component then we know the mconcat output + -- is a valid LName and so can use fromJust + name = swishName $ fromJust $ newLName $ mconcat ["_", getName nam1, "_", getName nam2, "_"] + +-- |Determine compatible ways in which variable binding modifiers may +-- be combined. +-- +-- The total vocabulary of a modifier is the complete set of variables +-- that are used or bound by the modifier. After the modifier has been +-- applied, bindings must exist for all of these variables. +-- +-- A usage pattern of a modifier is a set of variables for which new +-- bindings may be generated by the modifier. +-- +-- The only way in which two variable binding modifiers can be incompatible +-- with each other is when they both attempt to create a new binding for +-- the same variable. (Note that this does not mean the composition will +-- be compatible with all inputs: see @vbmCompatibleVars@.) +-- +-- NOTE: if there are different ways to achieve the same usage, that +-- usage is currently repeated in the result returned. +-- +compatibleUsage :: + (Eq a) + => [a] -- ^ the total vocabulary of the first modifier to be applied + -> [[a]] -- ^ usage patterns for the first modifier + -> [[a]] -- ^ usage patterns for the second modifier + -> [[a]] -- ^ a list of possible usage patterns for the composition of + -- the first modifier with the second modifier, or an empty list if + -- the modifiers are incompatible. +compatibleUsage voc1 use1 use2 = + [ u1++u2 | u2 <- use2, null (voc1 `intersect` u2), u1 <- use1 ] + +-- |Find all compatible compositions of a list of variable binding +-- modifiers for a given set of supplied bound variables. +findCompositions :: + (Eq a) => [VarBindingModify a b] + -> [a] + -> [VarBindingModify a b] +findCompositions vbms vars = + mapMaybe (composeCheckSequence vars) (permutations vbms) + +-- |Compose sequence of variable binding modifiers, and check +-- that the result can be used compatibly with a supplied list +-- of bound variables, returning @Just (composed modifier)@, +-- or @Nothing@. +-- +composeCheckSequence :: (Eq a) => [a] -> [VarBindingModify a b] + -> Maybe (VarBindingModify a b) +composeCheckSequence vars vbms = useWith vars $ composeSequence vbms + where + -- Check that a Maybe modifier is compatible for use with an + -- indicated set of bound variables, and return (Just modifier) + -- or Nothing. + useWith _ Nothing = Nothing + useWith vs v@(Just vbm) + | isJust $ vbmCompatibility vbm vs = v + | otherwise = Nothing + +-- |Compose sequence of variable binding modifiers. +-- +composeSequence :: (Eq a) => [VarBindingModify a b] + -> Maybe (VarBindingModify a b) +composeSequence [] = Just varBindingId +composeSequence (vbm:vbms) = foldl' composePair (Just vbm) vbms + +-- |Compose a pair of variable binding modifiers, returning +-- @Just (composed modifier)@, or @Nothing@. +-- +composePair :: (Eq a) => Maybe (VarBindingModify a b) -> VarBindingModify a b + -> Maybe (VarBindingModify a b) +composePair Nothing _ = Nothing +composePair (Just vbm1) vbm2 = vbmCompose vbm1 vbm2 + +-- |Return @Just a@ compatible composition of variable binding modifiers +-- for a given set of supplied bound variables, or @Nothing@ if there +-- is no compatible composition +-- +findComposition :: (Eq a) => [VarBindingModify a b] -> [a] + -> Maybe (VarBindingModify a b) +findComposition = listToMaybe `c2` findCompositions + where + c2 = (.) . (.) -- compose with function of two arguments + +-- |Variable binding modifier that returns exactly those +-- variable bindings presented. +-- +varBindingId :: VarBindingModify a b +varBindingId = VarBindingModify + { vbmName = swishName "varBindingId" + , vbmApply = id + , vbmVocab = [] + , vbmUsage = [[]] + } + +-- |Null variable binding modifier +-- +-- This is like 'varBindingId' except parameterized by some labels. +-- I think this is redundant, and should be eliminated. +-- +nullVarBindingModify :: OpenVarBindingModify a b +nullVarBindingModify lbs = VarBindingModify + { vbmName = swishName "nullVarBindingModify" + , vbmApply = id + , vbmVocab = lbs + , vbmUsage = [[]] + } + +------------------------------------------------------------ +-- Query binding filters +------------------------------------------------------------ + +-- |VarBindingFilter is a function type that tests to see if +-- a query binding satisfies some criterion. +-- +-- Queries often want to apply some kind of filter or condition +-- to the variable bindings that are processed. In inference rules, +-- it sometimes seems desirable to stipulate additional conditions on +-- the things that are matched. +-- +-- This function type is used to perform such tests. +-- A number of simple implementations are included below. +data VarBindingFilter a b = VarBindingFilter + { vbfName :: ScopedName + , vbfVocab :: [a] + , vbfTest :: VarBinding a b -> Bool + } + +-- |Make a variable binding modifier from a variable binding filter value. +makeVarFilterModify :: VarBindingFilter a b -> VarBindingModify a b +makeVarFilterModify vbf = VarBindingModify + { vbmName = vbfName vbf + , vbmApply = filter (vbfTest vbf) + , vbmVocab = vbfVocab vbf + , vbmUsage = [[]] + } + +-- |Make a variable test filter for a named variable using a +-- supplied value testing function. +makeVarTestFilter :: + ScopedName -> (b -> Bool) -> a -> VarBindingFilter a b +makeVarTestFilter nam vtest var = VarBindingFilter + { vbfName = nam + , vbfVocab = [var] + , vbfTest = \vb -> case vbMap vb var of + Just val -> vtest val + _ -> False + } + +-- |Make a variable comparison filter for named variables using +-- a supplied value comparison function. +makeVarCompareFilter :: + ScopedName -> (b -> b -> Bool) -> a -> a -> VarBindingFilter a b +makeVarCompareFilter nam vcomp v1 v2 = VarBindingFilter + { vbfName = nam + , vbfVocab = [v1,v2] + , vbfTest = \vb -> case (vbMap vb v1,vbMap vb v2) of + (Just val1, Just val2) -> vcomp val1 val2 + _ -> False + } + +------------------------------------------------------------ +-- Declare some generally useful query binding filters +------------------------------------------------------------ + +-- |This function generates a query binding filter that ensures that +-- two indicated query variables are mapped to the same value. +varFilterEQ :: (Eq b) => a -> a -> VarBindingFilter a b +varFilterEQ = + makeVarCompareFilter (swishName "varFilterEQ") (==) + +-- |This function generates a query binding filter that ensures that +-- two indicated query variables are mapped to different values. +varFilterNE :: (Eq b) => a -> a -> VarBindingFilter a b +varFilterNE = + makeVarCompareFilter (swishName "varFilterNE") (/=) + +-- |This function composes a number of query binding filters +-- into a composite filter that accepts any query binding that +-- satisfies at least one of the component values. +varFilterDisjunction :: (Eq a) => [VarBindingFilter a b] + -> VarBindingFilter a b +varFilterDisjunction vbfs = VarBindingFilter + { vbfName = swishName "varFilterDisjunction" + , vbfVocab = foldl1 union (map vbfVocab vbfs) + , vbfTest = or . flist (map vbfTest vbfs) + } + +-- |This function composes a number of query binding filters +-- into a composite filter that accepts any query binding that +-- satisfies all of the component values. +-- +-- The same function could be achieved by composing the component +-- filter-based modifiers, but this function is more convenient +-- as it avoids the need to check for modifier compatibility. +-- +varFilterConjunction :: (Eq a) => [VarBindingFilter a b] + -> VarBindingFilter a b +varFilterConjunction vbfs = VarBindingFilter + { vbfName = swishName "varFilterConjunction" + , vbfVocab = foldl1 union (map vbfVocab vbfs) + , vbfTest = and . flist (map vbfTest vbfs) + } + +-------------------------------------------------------------------------------- +-- +-- (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/swish.cabal b/swish.cabal --- a/swish.cabal +++ b/swish.cabal @@ -1,5 +1,5 @@ Name: swish -Version: 0.6.5.2 +Version: 0.7.0.0 Stability: experimental License: LGPL License-file: LICENSE @@ -9,7 +9,7 @@ Category: Semantic Web Synopsis: A semantic web toolkit. -Tested-With: GHC==7.0.4 +Tested-With: GHC==7.4.2 Cabal-Version: >= 1.9.2 Homepage: https://bitbucket.org/doug_burke/swish/wiki/Home Bug-reports: https://bitbucket.org/doug_burke/swish/issues @@ -44,139 +44,78 @@ . * Complete, ready-to-run, command-line and script-driven programs. . - Changes: - . - [Version 0.6.5.2] Update cabal to allow @polyparse@ version @1.8@ - and hopefully to build with ghc 7.4. The tests and application now - build against the library rather than re-compiling (internal - change only, thanks to a hint seen on haskell-cafe a while back). - . - [Version 0.6.5.1] Haddock fixes for @0.6.5.0@. - . - [Version 0.6.5.0] Export "Swish.RDF.TurtleFormatter.parseText". - Updated @filepath@ dependency and removed unused @array@ one. - . - [Version 0.6.4.0] Added support for xsd:decimal with "Swish.RDF.RDFDatatypeXsdDecimal" - and "Swish.RDF.MapXsdDecimal" thanks to William Waites . - Added "Swish.RDF.Vocabulary.Provenance". - . - [Version 0.6.3.0] Added "Swish.RDF.Vocabulary.SIOC". - . - [Version 0.6.2.1] Hackage did not want to upload @0.6.2.0@, so re-try by - disabling the @hpc@ and @developer@ flags for the tests to - work around what appears to be . - . - [Version 0.6.2.0] Updated "Swish.RDF.Vocabulary" and "Swish.RDF.RDFGraph" to - include more common RDF terms. Added "Swish.RDF.Vocabulary.DublinCore", - "Swish.RDF.Vocabulary.FOAF", and "Swish.RDF.Vocabulary.Geo" modules, - "Swish.RDF.Vocabulary.OWL", "Swish.RDF.Vocabulary.RDF", and - "Swish.RDF.Vocabulary.XSD" modules (re-exported from "Swish.RDF.Vocabulary" - as necessary). The test suite has been updated to take advantage of the - support in recent Cabal versions which means that the @tests@ flag has been - removed and the minimum Cabal version increased to @1.9.2@. A change was - made to the internal labelling of the RDFS container-property axioms in - "Swish.RDF.RDFProofContext". + Changes in version @0.7.0.0@: . - [Version 0.6.1.2] Corrected minimum mtl constraint from 1 to 2 and updated - the maximum time version to 1.4 from 1.3. + For code that uses the Swish script language, the main change is to import @Swish@ rather + than @Swish.RDF.SwishMain@, and to note that the other @Swish.RDF.Swish*@ modules are + now called @Swish.*@. . - [Version 0.6.1.1] Minor improvement to the error message produced by the - Turtle, Ntriples, and N3 parsers: a fragment of the remaining text is - included to provide some context (still lacking compared to the information - provided in version 0.3.2.1). + For code that uses the graph library, the main changes are that @Swish.RDF.RDFGraph@ + is now called @Swish.RDF.Graph@, the @Lit@ constructor of the @RDFLabel@ has been split + into three (@Lit@, @LangLit@, and @TypedLit@) and a new @LanguageTag@ type introduced, + local names now use the @LName@ type (previously they were just @Text@ values), and the + parsers and formatters have renamed to + @Swish.RDF.Parser.*@ and @Swish.RDF.Formatter.*@. . - [Version 0.6.1.0] Added support for Turtle format (added the - "Swish.RDF.TurtleFormatter" and "Swish.RDF.TurtleParser" modules). + * Moved a number of modules around: generic code directly into @Swish@ + and the @Swish.RDF.RDF*@ forms renamed to @Swish.RDF.*@. Some modules + have been moved out of the @Swish.Utils.*@ namespace. Generic modules + have been placed into the @Data.*@ namespace. The @Swish.RDF.Swish*@ + modules have been moved to @Swish.*@ and @Swish.RDF.SwishMain@ has + been removed; use @Swish@ instead. . - [Version 0.6.0.2] Minor internal changes. + * Parsing modules are now in the @Swish.RDF.Parser@ hierarchy and + @Swish.RDF.RDFParser@ has been renamed to @Swish.RDF.Parser.Utils@. . - [Version 0.6.0.1] Moved to using hashing routine using the @Data.Hashable@ - interface rather than "Swish.Utils.MiscHelpers", which is deprecated. + * Formatting modules are now in the @Swish.RDF.Formatter@ hierarchy. . - [Version 0.6.0.0] Add "Data.Interned.URI" and use it to speed up the 'QName' - equality check. + * RDF literals are now stored using the @Lit@, @LangLit@, or @TypedLit@ constructors + (@RDFLabel@) rather than using just @Lit@. Language codes are now represented + by @Swish.RDF.Vocabulary.LanguageTag@ rather than as a @ScopedName@. . - [Version 0.5.0.3] Didn't get all the required @FlexibleInstances@. + * Local names are now represented by the @Swish.QName.LName@ type + rather than as a @Text@ value. A few routines now return a @Maybe@ value + rather than error-ing out on invalid input. . - [Version 0.5.0.2] HUnit constraint is only added when the @tests@ flag - is used. Removed random and bytestring constraints. Add @FlexibleInstances@ - pragma for ghc 7.2 compatability. + * Make use of @Data.List.NonEmpty@ in a few cases. . - [Version 0.5.0.1] Update bounds on package constraints to try and get a - successful build on ghc 7.2; removed parallel constraint as not used. + * Removed @mkTypedLit@ from @Swish.RDF.RDFParser@; use + @Swish.RDF.RDFDatatype.makeDataTypedLiteral@ instead. . - [Version 0.5.0.0] The constructors for @ScopedName@ and @QName@ have been - removed to hide some experimental optimisations (partly added in 0.4.0.0); - @Namespace@ has seen a similar change but no optimisation. Output speed - should be improved but no systematic analysis has been performed. + * Removed @asubj@, @apred@ and @aobj@ from @Swish.RDF.GraphClass@ and + @Swish.RDF.RDFGraph@; use @arcSubj@, @arcPred@ or @arcObj@ instead. . - [Version 0.4.0.0] Moving to using polyparse for parsing and @Text@ rather than - @String@ where appropriate. Use of @URI@ and @Maybe Text@ rather than @String@ in the @Namespace@ - type. Removed the Swish.Utils.DateTime and Swish.Utils.TraceHelpers - modules. Symbols have been removed from the export lists of the following modules: - Swish.Utils.LookupMap, Swish.Utils.ListHelpers, Swish.Utils.MiscHelpers, - Swish.Utils.ShowM. Some significant improvements to parsing speed, but no - concerted effort or checks made yet. + * Removed un-used @containedIn@ element of the @LDGraph@ type class. + The arguments to @setArcs@ have been flipped, @replaceArcs@ removed, + @add@ renamed to @addGraphs@, and @emptyGraph@ added. . - [Version 0.3.2.1] Marked a number of routines from the Swish.Utils modules - as deprecated. Use foldl' rather than foldl. + * Removed un-used exports from @Swish.Utils.PartOrderedCollection@: + @partCompareOrd@, @partCompareMaybe@, @partCompareListOrd@, and + @partCompareListPartOrd@. . - [Version 0.3.2.0] The N3 parser no longer assumes a set of pre-defined namespaces. - There is no API change worthy of a bump to the minor version number, but it - is a large-enough change in behaviour that I felt the need for the update. + * Removed the @Swish.Utils.MiscHelpers@ module and moved single-use functionality + out of @Swish.Utils.ListHelpers@. . - [Version 0.3.1.2] 'Swish.RDF.RDFGraph.toRDFGraph' now sets up the - namespace map of the graph based on the input labels (previously it - left the map empty). + * Removed various exported symbols from a range of modules as they were + unused. . - [Version 0.3.1.1] Bug fixes for N3 format: strings ending in a - double quote character are now written out correctly and - @xsd:double@ values are not written using XSD canonical form/capital - @E@ but with a lower-case @e@. On input of N3, - literals that match @xsd:double@ are converted to XSD canonical form - (as stored in 'RDFLabel'), which can make simple textual comparison - of literals fail. The 'Eq' instance of 'RDFLabel' now ignores the - case of the language tag for literals and the 'Show' instance - uses XSD canonical form for @xsd:boolean@, @xsd:integer@, - @xsd:decimal@ and @xsd:double@ literals. - Noted that the 'ToRDFLable' and 'FromRDFLabel' classes replicate - existing functionality in the "Swish.RDF.RDFDatatype" module. + * Use @Word32@ rather than @Int@ for label indexes (@Swish.GraphMatch.LabelIndex@) + and in the bnode counts when formatting to N3/Turtle. . - [Version 0.3.1.0] Added the `Swish.RDF.RDFGraph.ToRDFLabel` and - `Swish.RDF.RDFGraph.FromRDFLabel` classes and the - `Swish.RDF.RDFGraph.toRDFTriple` and `Swish.RDF.RDFGraph.fromRDFTriple` - functions. - Added instances: @IsString RDFLabel@, @IsString QName@, @IsString ScopedName@ - and @Monoid NSGraph@. - The modules "Swish" and "Swish.RDF" have been introduced to provide - documentation. The module "Swish.Utils.DateTime" is deprecated and - will be removed in a later release. - The N3 formatter now writes out literals with @xsd:boolean@, @xsd:integer@, - @xsd:decimal@ and @xsd:double@ types as literals rather than as a typed string. + * Minor clean up of the @LookupMap@ module: @mergeReplaceOrAdd@ and @mergeReplace@ + are now combined into @mergeReplace@; @mapSelect@, @mapApplyToAll@, and + @mapTranslate*@ have been removed; documentation slightly improved; + and a few minor internal clean ups. . - [Version 0.3.0.3] Changed @scripts/SwishExample.ss@ script so that the - proof succeeds. Some documentation improvements, including a discussion - of the Swish script format (see "Swish.RDF.SwishScript"). Very minor - changes to behavior of Swish in several edge cases. + * Clarified that @Swish.RDF.RDFDatatypeXsdDecimal@ is for @xsd:decimal@ rather + than @xsd:double@. . - [Version 0.3.0.2] Bugfix: stop losing triples with a bnode subject when - using the N3Formatter; this also makes the @scripts/SwishTest.ss@ test - pass again. Several commands in Swish scripts now create screen - output (mainly to check what it is doing). Added the @developer@ - flag for building. + * Support using versions 0.8 or 0.9 of the @intern@ package and version 0.5 of + @containers@. . - [Version 0.3.0.1] updates the Swish script parser to work with the - changes in 0.3.0.0 (reported by Rick Murphy). - Several example scripts are installed in the - @scripts/@ directory, although only @VehicleCapacity.ss@ works - with this release. + * Switch to @Control.Exception.try@ to avoid deprecation warnings from @System.IO.Error.try@. . - [Version 0.3.0.0] is an attempt to update - version 0.2.1 () - to build against - a recent ghc install, with some clean ups - including support for - the current N3 specification - and the addition of the - NTriples format. It has not been tested against ghc7. + Changes in previous versions can be found at . . References: . @@ -207,64 +146,65 @@ Build-Depends: base >=3 && < 5, binary == 0.5.*, - containers >= 0.3 && < 0.5, + containers >= 0.3 && < 0.6, directory >= 1.0 && < 1.2, filepath >= 1.1 && < 1.4, hashable == 1.1.*, - -- intern == 0.8, mtl >= 2 && < 3, network >= 2.2 && < 2.4, old-locale == 1.0.*, polyparse >= 1.6 && < 1.9, + semigroups >= 0.5 && < 0.9, text == 0.11.*, time >= 1.1 && < 1.5 if impl(ghc < 7.4.0) Build-Depends: intern == 0.8 if impl(ghc >= 7.4.0) - Build-Depends: intern == 0.8.* + Build-Depends: intern >= 0.8 && < 1.0 Hs-Source-Dirs: src/ Exposed-Modules: + Data.Interned.URI + Data.LookupMap + Data.Ord.Partial + Data.String.ShowLines Swish + Swish.Commands + Swish.Datatype + Swish.GraphClass + Swish.GraphMatch + Swish.GraphMem + Swish.GraphPartition + Swish.Monad + Swish.Namespace + Swish.Proof + Swish.QName Swish.RDF - Swish.RDF.BuiltInDatatypes - Swish.RDF.BuiltInMap - Swish.RDF.BuiltInRules + Swish.RDF.BuiltIn + Swish.RDF.BuiltIn.Datatypes + Swish.RDF.BuiltIn.Rules Swish.RDF.ClassRestrictionRule Swish.RDF.Datatype - Swish.RDF.GraphClass - Swish.RDF.GraphMatch - Swish.RDF.GraphMem - Swish.RDF.GraphPartition - Swish.RDF.MapXsdDecimal - Swish.RDF.MapXsdInteger - Swish.RDF.NTFormatter - Swish.RDF.NTParser - Swish.RDF.N3Formatter - Swish.RDF.N3Parser + Swish.RDF.Datatype.XSD.Decimal + Swish.RDF.Datatype.XSD.Integer + Swish.RDF.Datatype.XSD.MapDecimal + Swish.RDF.Datatype.XSD.MapInteger + Swish.RDF.Datatype.XSD.String + Swish.RDF.Formatter.NTriples + Swish.RDF.Formatter.N3 + Swish.RDF.Formatter.Turtle + Swish.RDF.Graph + Swish.RDF.GraphShowLines + Swish.RDF.Parser.NTriples + Swish.RDF.Parser.N3 + Swish.RDF.Parser.Turtle + Swish.RDF.Parser.Utils Swish.RDF.Proof - Swish.RDF.RDFDatatype - Swish.RDF.RDFDatatypeXsdDecimal - Swish.RDF.RDFDatatypeXsdInteger - Swish.RDF.RDFDatatypeXsdString - Swish.RDF.RDFGraph - Swish.RDF.RDFGraphShowM - Swish.RDF.RDFParser - Swish.RDF.RDFProof - Swish.RDF.RDFProofContext - Swish.RDF.RDFQuery - Swish.RDF.RDFRuleset - Swish.RDF.RDFVarBinding - Swish.RDF.Rule + Swish.RDF.ProofContext + Swish.RDF.Query Swish.RDF.Ruleset - Swish.RDF.SwishCommands - Swish.RDF.SwishMain - Swish.RDF.SwishMonad - Swish.RDF.SwishScript - Swish.RDF.TurtleFormatter - Swish.RDF.TurtleParser Swish.RDF.VarBinding Swish.RDF.Vocabulary Swish.RDF.Vocabulary.DublinCore @@ -275,14 +215,11 @@ Swish.RDF.Vocabulary.RDF Swish.RDF.Vocabulary.SIOC Swish.RDF.Vocabulary.XSD + Swish.Rule + Swish.Ruleset + Swish.Script Swish.Utils.ListHelpers - Swish.Utils.LookupMap - Swish.Utils.MiscHelpers - Swish.Utils.Namespace - Swish.Utils.PartOrderedCollection - Swish.Utils.QName - Swish.Utils.ShowM - Data.Interned.URI + Swish.VarBinding ghc-options: -Wall -fno-warn-orphans @@ -317,6 +254,7 @@ Build-Depends: base >=3 && < 5, HUnit == 1.2.*, + semigroups >= 0.5 && < 0.9, swish Test-Suite test-graph diff --git a/tests/BuiltInMapTest.hs b/tests/BuiltInMapTest.hs --- a/tests/BuiltInMapTest.hs +++ b/tests/BuiltInMapTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : BuiltInMapTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -19,23 +19,17 @@ module Main where -import Swish.RDF.BuiltInMap +import Swish.Namespace (makeNSScopedName) +import Swish.Ruleset (getMaybeContextAxiom, getMaybeContextRule) + +import Swish.RDF.BuiltIn ( findRDFOpenVarBindingModifier , findRDFDatatype , rdfRulesetMap , allRulesets ) -import Swish.RDF.RDFDatatypeXsdInteger - ( typeNameXsdInteger, namespaceXsdInteger - ) - -import Swish.RDF.Ruleset - ( getMaybeContextAxiom - , getMaybeContextRule - ) - -import Swish.Utils.Namespace (makeNSScopedName) +import Swish.RDF.Datatype.XSD.Integer (typeNameXsdInteger, namespaceXsdInteger) import Swish.RDF.Vocabulary ( swishName @@ -45,7 +39,7 @@ , namespaceXsdType ) -import Swish.Utils.LookupMap (mapFindMaybe) +import Data.LookupMap (mapFindMaybe) import Test.HUnit ( Test(TestCase,TestList) @@ -261,7 +255,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/GraphPartitionTest.hs b/tests/GraphPartitionTest.hs --- a/tests/GraphPartitionTest.hs +++ b/tests/GraphPartitionTest.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : GraphPartitionTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -16,18 +16,19 @@ module Main where -import Swish.RDF.GraphPartition +import Swish.GraphPartition ( PartitionedGraph(..), getArcs , GraphPartition(..), node , partitionGraph, comparePartitions ) -import Swish.RDF.GraphClass (Arc(..)) - -import Swish.RDF.GraphMem (LabelMem(..)) +import Swish.GraphClass (Arc(..)) +import Swish.GraphMem (LabelMem(..)) import Swish.Utils.ListHelpers (equiv) +import Data.List.NonEmpty (fromList) + import Test.HUnit (Test(TestCase, TestList), assertEqual, assertBool) @@ -89,24 +90,36 @@ gp4 = PartitionedGraph [ p11, p14 ] gp5 = PartitionedGraph [ p11, p12, p15 ] +toPF :: + String + -> [(LabelMem, GraphPartition LabelMem)] + -> GraphPartition LabelMem +toPF l xs = PartSub (LF l) (fromList xs) + +toPV :: + String + -> [(LabelMem, GraphPartition LabelMem)] + -> GraphPartition LabelMem +toPV l xs = PartSub (LV l) (fromList xs) + p11, p12, p13, p14, p15 :: GraphPartition LabelMem -p11 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] -p12 = PartSub (LF "s2") [ (LF "p21",PartObj (LF "o21")) - , (LF "p22",PartObj (LF "o22")) - ] -p13 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p32",p12) - , (LF "p33",PartObj (LF "s3")) - ] -p14 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "s3")) - , (LF "p32",p12) - ] -p15 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p32",PartObj (LF "s2")) - , (LF "p33",PartObj (LF "s3")) - ] +p11 = toPF "s1" [ (LF "p11",PartObj (LF "o11")) ] +p12 = toPF "s2" [ (LF "p21",PartObj (LF "o21")) + , (LF "p22",PartObj (LF "o22")) + ] +p13 = toPF "s3" [ (LF "p31",PartObj (LF "o31")) + , (LF "p32",p12) + , (LF "p33",PartObj (LF "s3")) + ] +p14 = toPF "s3" [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "s3")) + , (LF "p32",p12) + ] +p15 = toPF "s3" [ (LF "p31",PartObj (LF "o31")) + , (LF "p32",PartObj (LF "s2")) + , (LF "p33",PartObj (LF "s3")) + ] ga1, ga2, ga3, ga4, ga5 :: [Arc LabelMem] @@ -327,77 +340,77 @@ ps1, ps2f, ps2r, pb3f, pb3r, pb3af, pb3ar, pb4af, pb4ar :: GraphPartition LabelMem -ps1 = PartSub (LF "s1") [ (LF "p",PartObj (LF "o11")) ] -ps2f = PartSub (LF "s2") [ (LF "p1",PartObj (LF "o21")) - , (LF "p2",PartObj (LF "o22")) - ] -ps2r = PartSub (LF "s2") [ (LF "p2",PartObj (LF "o22")) - , (LF "p1",PartObj (LF "o21")) - ] -pb3f = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - ] -pb3r = PartSub (LV "b3") [ (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] +ps1 = toPF "s1" [ (LF "p",PartObj (LF "o11")) ] +ps2f = toPF "s2" [ (LF "p1",PartObj (LF "o21")) + , (LF "p2",PartObj (LF "o22")) + ] +ps2r = toPF "s2" [ (LF "p2",PartObj (LF "o22")) + , (LF "p1",PartObj (LF "o21")) + ] +pb3f = toPV "b3" [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + ] +pb3r = toPV "b3" [ (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] -pb3af = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",pb4af) - ] -pb3ar = PartSub (LV "b3") [ (LF "p",pb4ar) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] -pb4af = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - ] -pb4ar = PartSub (LV "b4") [ (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - ] +pb3af = toPV "b3" [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",pb4af) + ] +pb3ar = toPV "b3" [ (LF "p",pb4ar) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] +pb4af = toPV "b4" [ (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + ] +pb4ar = toPV "b4" [ (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + ] pb5a1, pb5b1, pb5c1 :: GraphPartition LabelMem -pb5a1 = PartSub (LV "b5a") [ (LF "p",pb5b1) ] -pb5b1 = PartSub (LV "b5b") [ (LF "p",pb5c1) ] -pb5c1 = PartSub (LV "b5c") [ (LF "p",PartObj (LV "b5a")) ] +pb5a1 = toPV "b5a" [ (LF "p",pb5b1) ] +pb5b1 = toPV "b5b" [ (LF "p",pb5c1) ] +pb5c1 = toPV "b5c" [ (LF "p",PartObj (LV "b5a")) ] pb3bf, pb3br, pb4bf, pb4br :: GraphPartition LabelMem -pb3bf = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",pb4bf) - ] -pb3br = PartSub (LV "b3") [ (LF "p",pb4br) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] -pb4bf = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LV "b5b")) - ] -pb4br = PartSub (LV "b4") [ (LF "p",PartObj (LV "b5b")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - ] +pb3bf = toPV "b3" [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",pb4bf) + ] +pb3br = toPV "b3" [ (LF "p",pb4br) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] +pb4bf = toPV "b4" [ (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LV "b5b")) + ] +pb4br = toPV "b4" [ (LF "p",PartObj (LV "b5b")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + ] pb5a2, pb5b2, pb5c2 :: GraphPartition LabelMem -pb5a2 = PartSub (LV "b5a") [ (LF "p",PartObj (LV "b5b")) ] -pb5b2 = PartSub (LV "b5b") [ (LF "p",pb5c2) ] -pb5c2 = PartSub (LV "b5c") [ (LF "p",pb5a2) ] +pb5a2 = toPV "b5a" [ (LF "p",PartObj (LV "b5b")) ] +pb5b2 = toPV "b5b" [ (LF "p",pb5c2) ] +pb5c2 = toPV "b5c" [ (LF "p",pb5a2) ] pb5a3, pb5b3, pb5c3 :: GraphPartition LabelMem -pb5a3 = PartSub (LV "b5a") [ (LF "p",pb5b3) ] -pb5b3 = PartSub (LV "b5b") [ (LF "p",PartObj (LV "b5c")) ] -pb5c3 = PartSub (LV "b5c") [ (LF "p",pb5a3) ] +pb5a3 = toPV "b5a" [ (LF "p",pb5b3) ] +pb5b3 = toPV "b5b" [ (LF "p",PartObj (LV "b5c")) ] +pb5c3 = toPV "b5c" [ (LF "p",pb5a3) ] testPartition11, testPartition12, testPartition13, testPartition14, testPartition15, testPartition16 :: Test @@ -449,13 +462,13 @@ testPartition55 = testEqv "testPartition55" [] (comparePartitions pp5f pp5r) testPartition56 = testEqv "testPartition56" [] (comparePartitions pp6f pp6r) testPartition57 = testEqv "testPartition57" - [(Nothing,Just $ PartSub (LV "b3") [(LF "p",pb4af)])] + [(Nothing,Just $ toPV "b3" [(LF "p",pb4af)])] (comparePartitions pp3f pp4f) testPartition58 = testEqv "testPartition58" [(Nothing,Just pb5a1)] (comparePartitions pp4f pp5f) testPartition59 = testEqv "testPartition59" - [(Nothing,Just $ PartSub (LV "b4") [(LF "p",PartObj (LV "b5b"))])] + [(Nothing,Just $ toPV "b4" [(LF "p",PartObj (LV "b5b"))])] (comparePartitions pp5f pp6f) testPartitionSuite :: Test @@ -507,19 +520,19 @@ c11, c12a, c12b, c13a, c13b :: GraphPartition LabelMem -c11 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] -c12a = PartSub (LF "s2") [ (LF "p21",c13a) +c11 = toPF "s1" [ (LF "p11",PartObj (LF "o11")) ] +c12a = toPF "s2" [ (LF "p21",c13a) , (LF "p22",PartObj (LF "o22")) ] -c12b = PartSub (LF "s2") [ (LF "p22",PartObj (LF "o22")) +c12b = toPF "s2" [ (LF "p22",PartObj (LF "o22")) , (LF "p21",c13b) ] -c13a = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "o33a")) - ] -c13b = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "o33b")) - ] +c13a = toPV "b3" [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "o33a")) + ] +c13b = toPV "b3" [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "o33b")) + ] testCompare01 :: Test testCompare01 = testEqv "testCompare01" @@ -556,7 +569,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/GraphTest.hs b/tests/GraphTest.hs --- a/tests/GraphTest.hs +++ b/tests/GraphTest.hs @@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | -- Module : GraphTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -29,28 +29,31 @@ ( Test(TestCase,TestList,TestLabel), assertEqual, assertBool ) -import Data.List (sort, elemIndex) -import Data.Maybe (fromJust) -import Data.Ord (comparing) - -import Swish.Utils.ListHelpers -import Swish.RDF.GraphClass (Arc(..), LDGraph(..), - Label(..), arc, - arcFromTriple,arcToTriple) -import Swish.RDF.GraphMem -import Swish.RDF.GraphMatch +import Swish.GraphClass (Arc(..), LDGraph(..), Label(..)) +import Swish.GraphClass (arc, arcFromTriple, arcToTriple) +import Swish.GraphMem +import Swish.GraphMatch ( LabelMap, GenLabelMap(..), LabelEntry, EquivalenceClass, ScopedLabel(..), makeScopedLabel, makeScopedArc, LabelIndex, nullLabelVal, emptyMap, mapLabelIndex, {-mapLabelList,-} setLabelHash, newLabelMap, - graphLabels, assignLabelMap, newGenerationMap, - graphMatch1, equivalenceClasses + graphLabels, assignLabelMap, newGenerationMap + -- graphMatch1 only used with pairSort + , equivalenceClasses ) -import Swish.Utils.LookupMap (LookupEntryClass(..), makeLookupMap) +import Swish.Utils.ListHelpers (subset) + +import Data.LookupMap (LookupEntryClass(..), makeLookupMap) + import TestHelpers (runTestSuite, testEq, testEqv) +import Data.List (sort, elemIndex) +import Data.Maybe (fromJust) +import Data.Ord (comparing) +import Data.Word (Word32) + default ( Int ) ------------------------------------------------------------ @@ -72,7 +75,7 @@ setArcsT :: (LDGraph lg lb) => [(lb, lb, lb)] -> lg lb -> lg lb -setArcsT a = setArcs $ map arcFromTriple a +setArcsT a g = setArcs g $ map arcFromTriple a getArcsT :: (LDGraph lg lb) => lg lb -> [(lb, lb, lb)] @@ -100,7 +103,7 @@ -- Label map and entry creation helpers ------------------------------------------------------------ -tstLabelMap :: (Label lb) => Int -> [(lb,LabelIndex)] -> LabelMap lb +tstLabelMap :: (Label lb) => Word32 -> [(lb,LabelIndex)] -> LabelMap lb tstLabelMap gen lvs = LabelMap gen (makeLookupMap $ makeEntries lvs) makeEntries :: (Label lb) => [(lb,LabelIndex)] -> [LabelEntry lb] @@ -110,8 +113,11 @@ -- Graph helper function tests ------------------------------------------------------------ --- select +{- +-- select; no longer exported so need to check that +-- other tests still test this routine + testSelect :: String -> String -> String -> Test testSelect lab = testeq ("Select"++lab ) @@ -136,6 +142,8 @@ testSelect01, testSelect02, testSelect03, testSelect04 ] +-} + -- subset testSubset :: String -> Bool -> [Int] -> [Int] -> Test @@ -263,12 +271,12 @@ gr1a = setArcsT ga1 gr1 gr2a = setArcsT ga2 gr2 gr3a = setArcsT ga3 gr3 -gr4a = add gr2a gr3a -gr4b = add gr3a gr2a +gr4a = addGraphs gr2a gr3a +gr4b = addGraphs gr3a gr2a gr4c = delete gr2a gr4a gr4d = delete gr3a gr4a gr4e = extract gs4 gr4a -gr4g = add gr2a gr4a +gr4g = addGraphs gr2a gr4a gl4f :: [LabelMem] gl4f = labels gr4a @@ -665,30 +673,30 @@ (b3,(1,262143)),(b4,(1,262143))] -} -bhash :: Int +bhash :: Word32 bhash = 23 -l1hash, l4hash, l10hash :: Int +l1hash, l4hash, l10hash :: Word32 l1hash = 2524 l4hash = -1302210307 l10hash = 10836024 -l1hash2, l4hash2, l10hash2 :: Int +l1hash2, l4hash2, l10hash2 :: Word32 l1hash2 = 2524 l4hash2 = -1302210307 l10hash2 = 10836024 -o1hash, o2hash, o3hash :: Int +o1hash, o2hash, o3hash :: Word32 o1hash = 2623 o2hash = 2620 o3hash = 2621 -p1hash, p2hash, p3hash :: Int +p1hash, p2hash, p3hash :: Word32 p1hash = 2624 p2hash = 2627 p3hash = 2626 -s1hash, s2hash, s3hash :: Int +s1hash, s2hash, s3hash :: Word32 s1hash = 2723 s2hash = 2720 s3hash = 2721 @@ -1082,7 +1090,7 @@ testEqAssignMap32 = testeq "EqAssignMap32" eq3ltst eq3lmap type EquivClass = EquivalenceClass (ScopedLabel LabelMem) -type EquivArgs = ((Int, Int), [ScopedLabel LabelMem]) +type EquivArgs = ((Word32, Word32), [ScopedLabel LabelMem]) ec31 :: [EquivClass] ec31 = equivalenceClasses eq3lmap (graphLabels as11) @@ -1099,9 +1107,7 @@ ec32test :: [EquivArgs] ec32test = - [ - ((1,-1302210307),[l4_2]) - , ((1,2524),[l1_2]) + [ ((1,2524),[l1_2]) , ((1,2620),[o2_2]) , ((1,2621),[o3_2]) , ((1,2623),[o1_2]) @@ -1110,18 +1116,23 @@ , ((1,2721),[s3_2]) , ((1,2723),[s1_2]) , ((1,10836024),[l10_2]) + , ((1,2992756989),[l4_2]) ] testEquivClass33_1, testEquivClass33_2 :: Test testEquivClass33_1 = testeq "EquivClass33_1" ec31test ec31 testEquivClass33_2 = testeq "EquivClass33_2" ec32test ec32 +{- as pairSOrt is no-longer exported need to check this code gets tested + -- This value is nonsense for this test, -- but a parameter is needed for graphMatch1 (below) ec3pairs :: [(EquivClass, EquivClass)] ec3pairs = zip (pairSort ec31) (pairSort ec32) +-} + {- This is a pointless test in this case ec3test :: [(EquivClass, EquivClass)] @@ -1134,9 +1145,13 @@ testEquivClass33_3 = testeq "EquivClass33_3" ec3test ec3pairs -} +{- pairSort is no longer exported + eq3lmap1 :: (Bool, LabelMap (ScopedLabel LabelMem)) eq3lmap1 = graphMatch1 False matchable eq3hs1 eq3hs2 eq3lmap ec3pairs +-} + eq3ltst1 :: LabelMap (ScopedLabel LabelMem) eq3ltst1 = tstLabelMap 2 [ (o1_1,(1,142321)) @@ -1156,8 +1171,10 @@ -- testEqAssignMap34 = testeq "EqAssignMap34" (Just eq3ltst1) eq3lmap1 -- testEqAssignMap34 = testeq "EqAssignMap34" Nothing eq3lmap1 +{- pairSort is not exported testEqAssignMap34 :: Test testEqAssignMap34 = testeq "EqAssignMap34" False (fst eq3lmap1) +-} {- eq3rc1 = reclassify eq3hs1 eq3lmap @@ -1184,7 +1201,7 @@ , testEqGraphMap31_1, testEqGraphMap31_2 , testEqAssignMap32 , testEquivClass33_1, testEquivClass33_2 -- , testEquivClass33_3 - , testEqAssignMap34 + -- , testEqAssignMap34 pairSort is not exported -- , testEqReclassify35_1, testEqReclassify35_2 ] @@ -1839,8 +1856,8 @@ allTests :: Test allTests = TestList - [ testSelectSuite - , testSubsetSuite + [ -- testSelectSuite + testSubsetSuite , testLabSuite , testGraphSuite , testLabelEqSuite @@ -1879,7 +1896,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/LookupMapTest.hs b/tests/LookupMapTest.hs --- a/tests/LookupMapTest.hs +++ b/tests/LookupMapTest.hs @@ -17,19 +17,16 @@ module Main where -import Swish.Utils.LookupMap +import Data.LookupMap ( LookupEntryClass(..), LookupMap(..) , makeLookupMap , reverseLookupMap , mapFind, mapContains - , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap + , mapReplace, mapReplaceAll, mapReplaceMap , mapAdd, mapAddIfNew , mapDelete, mapDeleteAll - , mapApplyToAll, mapTranslate , mapEq, mapKeys, mapVals - , mapSelect, mapMerge - , mapTranslateKeys, mapTranslateVals - , mapTranslateEntries, mapTranslateEntriesM + , mapMerge ) import Data.List ( sort ) @@ -109,23 +106,14 @@ lm08 = mapDelete lm07 3 lm09 = mapDeleteAll lm08 2 -la10 :: [String] -la10 = mapApplyToAll lm03 (`replicate` '*') - -lt11, lt12, lt13, lt14 :: String -lt11 = mapTranslate lm03 la10 1 "****" -lt12 = mapTranslate lm03 la10 2 "****" -lt13 = mapTranslate lm03 la10 3 "****" -lt14 = mapTranslate lm03 la10 4 "****" - lm20, lm21, lm22, lm33, lm34, lm35, lm36 :: TestMap lm20 = mapReplaceMap lm05 $ newMap [(2,"bbb20"),(3,"ccc20")] lm21 = mapReplaceMap lm05 $ newMap [] lm22 = mapReplaceMap lm05 $ newMap [(9,"zzz22"),(1,"aaa22")] lm33 = mapAddIfNew lm22 $ newEntry (1,"aaa33") lm34 = mapAddIfNew lm22 $ newEntry (4,"ddd34") -lm35 = mapReplaceOrAdd (newEntry (1,"aaa35")) lm22 -lm36 = mapReplaceOrAdd (newEntry (4,"ddd36")) lm22 +lm35 = mapReplace lm22 (newEntry (1,"aaa35")) +lm36 = mapReplace lm22 (newEntry (4,"ddd36")) testLookupMapSuite :: Test testLookupMapSuite = @@ -151,11 +139,6 @@ , testLookupMapFind "08" lm08 2 "bbb" , testLookupMap "09" lm09 [(1,"aaa")] , testLookupMapFind "09" lm09 2 "" - , testeq "LookupMapApplyToAll10" ["***","**","*"] la10 - , testeq "LookupMapTranslate11" "*" lt11 - , testeq "LookupMapTranslate12" "**" lt12 - , testeq "LookupMapTranslate13" "***" lt13 - , testeq "LookupMapTranslate14" "****" lt14 , testLookupMap "20" lm20 [(2,"bbb20"),(3,"ccc20"),(2,"bbb20"),(1,"aaa")] , testLookupMapFind "20" lm20 2 "bbb20" , testLookupMap "21" lm21 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] @@ -347,19 +330,16 @@ lm101, lm102, lm103, lm104 :: TestMap lm101 = mapAdd lm03 $ newEntry (4,"ddd") +{- lm102 = mapSelect lm101 [1,3] lm103 = mapSelect lm101 [2,4] lm104 = mapSelect lm101 [2,3] +-} -mapSelectSuite :: Test -mapSelectSuite = - TestList - [ testLookupMap "101" lm101 [(4,"ddd"),(3,"ccc"),(2,"bbb"),(1,"aaa")] - , testLookupMap "102" lm102 [(3,"ccc"),(1,"aaa")] - , testLookupMap "103" lm103 [(4,"ddd"),(2,"bbb")] - , testLookupMap "104" lm104 [(3,"ccc"),(2,"bbb")] - ] - +lm102 = mapAdd (mapAdd (newMap []) (newEntry (1,"aaa"))) $ newEntry (3,"ccc") +lm103 = mapAdd (mapAdd (newMap []) (newEntry (2,"bbb"))) $ newEntry (4,"ddd") +lm104 = mapAdd (mapAdd (newMap []) (newEntry (2,"bbb"))) $ newEntry (3,"ccc") + lm105, lm106, lm107, lm108 :: TestMap lm105 = mapMerge lm102 lm103 lm106 = mapMerge lm102 lm104 @@ -369,82 +349,14 @@ mapMergeSuite :: Test mapMergeSuite = TestList - [ testLookupMap "105" lm105 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] + [ testLookupMap "101" lm101 [(4,"ddd"),(3,"ccc"),(2,"bbb"),(1,"aaa")] + , testLookupMap "105" lm105 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] , testLookupMap "106" lm106 [(1,"aaa"),(2,"bbb"),(3,"ccc")] , testLookupMap "107" lm107 [(2,"bbb"),(3,"ccc"),(4,"ddd")] , testLookupMap "108" lm108 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] ] ------------------------------------------------------------ --- Tranlation tests ------------------------------------------------------------- - --- Rather late in the day, generic versions of the testing functions used earlier -type TestMapG a b = LookupMap (GenMapEntry a b) - -newMapG :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> TestMapG a b -newMapG es = makeLookupMap (map newEntry es) - -testLookupMapG :: (Eq a, Show a, Eq b, Show b) => String -> TestMapG a b -> [(a,b)] -> Test -testLookupMapG lab m1 m2 = testeq ("LookupMapG"++lab ) (newMapG m2) m1 -testLookupMapM :: - (Eq a, Show a, Eq b, Show b, Monad m, - Eq (m (TestMapG a b)), Show (m (TestMapG a b))) - => String -> m (TestMapG a b) -> m (TestMapG a b) -> Test -testLookupMapM lab m1 m2 = testeq ("LookupMapM"++lab ) m2 m1 - -tm101 :: TestMap -tm101 = newMap [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] - -tf102 :: Int -> String -tf102 = flip replicate '*' - -tm102 :: StrTestMap -tm102 = mapTranslateKeys tf102 tm101 - -tm103 :: RevTestMap -tm103 = mapTranslateVals length tm102 - -tf104 :: (LookupEntryClass a Int [b], - LookupEntryClass c String Int) => - a -> c -tf104 e = newEntry (replicate k '#', 5 - length v) where (k,v) = keyVal e - -tm104 :: RevTestMap -tm104 = mapTranslateEntries tf104 tm101 - --- Test monadic translation, using Maybe monad --- (Note that if Nothing is generated at any step, --- it propagates to the result) --- -tf105 :: (LookupEntryClass a Int [b], - LookupEntryClass c String Int) => - a -> Maybe c -tf105 e = Just $ tf104 e - -tm105 :: MayTestMap -tm105 = mapTranslateEntriesM tf105 tm101 - -tf106 :: (LookupEntryClass a Int [b], - LookupEntryClass c String Int) => - a -> Maybe c -tf106 e = if k == 2 then Nothing else tf105 e where (k,_) = keyVal e - -tm106 :: MayTestMap -tm106 = mapTranslateEntriesM tf106 tm101 - -mapTranslateSuite :: Test -mapTranslateSuite = - TestList - [ testLookupMapG "tm101" tm101 [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] - , testLookupMapG "tm102" tm102 [("*","a"),("**","bb"),("***","ccc"),("****","dddd")] - , testLookupMapG "tm103" tm103 [("*",1),("**",2),("***",3),("****",4)] - , testLookupMapG "tm104" tm104 [("#",4),("##",3),("###",2),("####",1)] - , testLookupMapM "tm105" tm105 (Just tm104) - , testLookupMapM "tm106" tm106 Nothing - ] - ------------------------------------------------------------- -- All tests ------------------------------------------------------------ @@ -455,9 +367,7 @@ , testMapKeysSuite , testMapValsSuite , testMapEqSuite - , mapSelectSuite , mapMergeSuite - , mapTranslateSuite ] main :: IO () diff --git a/tests/N3FormatterTest.hs b/tests/N3FormatterTest.hs --- a/tests/N3FormatterTest.hs +++ b/tests/N3FormatterTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : N3FormatterTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -18,13 +18,14 @@ module Main where -import Swish.RDF.N3Formatter - ( formatGraphAsLazyText - , formatGraphDiag ) +import Swish.GraphClass (Arc, arc) +import Swish.Namespace (Namespace, makeNamespace, makeNSScopedName, namespaceToBuilder) +import Swish.QName (LName) -import Swish.RDF.N3Parser (parseN3) +import Swish.RDF.Formatter.N3 (formatGraphAsLazyText, formatGraphDiag) +import Swish.RDF.Parser.N3 (parseN3) -import Swish.RDF.RDFGraph +import Swish.RDF.Graph ( RDFGraph, RDFTriple , RDFLabel(..), ToRDFLabel , NSGraph(..) @@ -35,16 +36,9 @@ , resOwlSameAs ) -import Swish.Utils.Namespace (Namespace, makeNamespace, makeNSScopedName, namespaceToBuilder) - -import Swish.Utils.LookupMap - ( LookupMap(..) - , emptyLookupMap - , makeLookupMap) - -import Swish.RDF.GraphClass (Arc, arc) +import Data.LookupMap (LookupMap(..), emptyLookupMap, makeLookupMap) -import Swish.RDF.Vocabulary (langName, namespaceRDF, namespaceXSD) +import Swish.RDF.Vocabulary (toLangTag, namespaceRDF, namespaceXSD) import Network.URI (URI, parseURI) @@ -81,7 +75,7 @@ toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . toURI -toRes :: Namespace -> T.Text -> RDFLabel +toRes :: Namespace -> LName -> RDFLabel toRes ns = Res . makeNSScopedName ns base1, base2, base3, base4, basef, baseu, basem :: Namespace @@ -150,7 +144,7 @@ l14txt = "lx14" toL :: B.Builder -> RDFLabel -toL = flip Lit Nothing . L.toStrict . B.toLazyText +toL = Lit . L.toStrict . B.toLazyText l1, l2, l3, l11, l12, l13, l14 :: RDFLabel l1 = toL l1txt @@ -162,8 +156,8 @@ l14 = toL l14txt lfr, lfoobar :: RDFLabel -lfr = Lit "chat et chien" (Just (langName "fr")) -lfoobar = Lit "foo bar" (Just (makeNSScopedName base1 "o1")) +lfr = LangLit "chat et chien" (fromJust $ toLangTag "fr") +lfoobar = TypedLit "foo bar" (makeNSScopedName base1 "o1") f1, f2 :: RDFLabel f1 = Res $ makeNSScopedName base1 "f1" @@ -694,7 +688,7 @@ in toRDFGraph arcs graph_l4 = toGraph [ toRDFTriple s1 p1 ("A string with \"quotes\"" :: RDFLabel) - , toRDFTriple s2 p2 (Lit "A typed string with \"quotes\"" (Just (fromString "urn:a#b"))) + , toRDFTriple s2 p2 (TypedLit "A typed string with \"quotes\"" (fromString "urn:a#b")) ] ------------------------------------------------------------ @@ -1493,7 +1487,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/N3ParserTest.hs b/tests/N3ParserTest.hs --- a/tests/N3ParserTest.hs +++ b/tests/N3ParserTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : N3ParserTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -18,7 +18,19 @@ module Main where -import Swish.RDF.N3Parser +import Swish.GraphClass (Arc, arc) +import Swish.Namespace ( + Namespace, makeNamespace, getNamespaceURI + , ScopedName + , makeScopedName + , makeNSScopedName + , nullScopedName + -- , makeUriScopedName + , namespaceToBuilder + ) +import Swish.QName (QName, qnameFromURI) + +import Swish.RDF.Parser.N3 ( parseN3 , parseTextFromText, parseAltFromText , parseNameFromText -- , parsePrefixFromText @@ -26,7 +38,7 @@ , parseURIref2FromText ) -import Swish.RDF.RDFGraph +import Swish.RDF.Graph ( RDFGraph, RDFLabel(..), NSGraph(..) , LookupFormula(..) , emptyRDFGraph, toRDFGraph @@ -34,19 +46,9 @@ , resOwlSameAs, resLogImplies ) -import Swish.Utils.Namespace ( - Namespace, makeNamespace, getNamespaceURI - , ScopedName - , makeScopedName - , makeNSScopedName - , nullScopedName - -- , makeUriScopedName - , namespaceToBuilder - ) - import Swish.RDF.Vocabulary ( namespaceRDF - , langName + , toLangTag , rdfXMLLiteral , xsdBoolean , xsdInteger @@ -54,17 +56,14 @@ , xsdDouble ) -import Swish.RDF.GraphClass (Arc, arc) - -import Swish.Utils.QName (QName, qnameFromURI) -import Swish.Utils.LookupMap (LookupMap(..)) +import Data.LookupMap (LookupMap(..)) import Test.HUnit (Test(TestCase,TestList), assertEqual) import Network.URI (URI, nullURI, parseURIReference) import Data.Monoid (Monoid(..)) -import Data.Maybe (fromMaybe) +import Data.Maybe (fromJust, fromMaybe) import Data.List (intercalate) import qualified Data.Text as T @@ -242,7 +241,7 @@ baseFile = "file:///dev/null" dqn :: QName -dqn = (qnameFromURI . toURI) baseFile +dqn = (fromJust . qnameFromURI . toURI) baseFile toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . toURI @@ -313,18 +312,18 @@ oa = Res $ makeNSScopedName basea "c" l1, l2, l3 :: RDFLabel -l1 = Lit "l1" Nothing -l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" Nothing -l3 = Lit "l3--\r\"'\\--\x0020\&--\x00A0\&--" Nothing +l1 = Lit "l1" +l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" +l3 = Lit "l3--\r\"'\\--\x0020\&--\x00A0\&--" lfr, lxml, lfrxml :: RDFLabel -lfr = Lit "chat" $ Just $ langName "fr" -lxml = Lit "
" $ Just rdfXMLLiteral -lfrxml = Lit "chat" $ Just rdfXMLLiteral +lfr = LangLit "chat" $ fromJust $ toLangTag "fr" +lxml = TypedLit "
" rdfXMLLiteral +lfrxml = TypedLit "chat" rdfXMLLiteral bTrue, bFalse :: RDFLabel -bTrue = Lit "true" $ Just xsdBoolean -bFalse = Lit "false" $ Just xsdBoolean +bTrue = TypedLit "true" xsdBoolean +bFalse = TypedLit "false" xsdBoolean f1, f2 :: RDFLabel f1 = Res $ makeNSScopedName base1 "f1" @@ -1258,10 +1257,10 @@ lit_g2 = lit_g1 { namespaces = xnslist } bOne, b20, b221, b23e4 :: RDFLabel -bOne = Lit "1" $ Just xsdInteger -b20 = Lit "2.0" $ Just xsdDecimal -b221 = Lit "-2.21" $ Just xsdDecimal -b23e4 = Lit "-2.3E-4" $ Just xsdDouble +bOne = TypedLit "1" xsdInteger +b20 = TypedLit "2.0" xsdDecimal +b221 = TypedLit "-2.21" xsdDecimal +b23e4 = TypedLit "-2.3E-4" xsdDouble lit_g4 :: RDFGraph lit_g4 = mempty { @@ -1506,7 +1505,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/NTTest.hs b/tests/NTTest.hs --- a/tests/NTTest.hs +++ b/tests/NTTest.hs @@ -5,34 +5,31 @@ -------------------------------------------------------------------------------- -- | -- Module : NTTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedString -- --- This Module contains test cases for the NTriples modules: --- "NTParser" and "NTFormatter". +-- This Module contains test cases for the NTriples parsing and formatting modules. -- -------------------------------------------------------------------------------- module Main where -import Swish.RDF.NTParser (parseNT) -import Swish.RDF.NTFormatter (formatGraphAsLazyText) +import Swish.GraphClass (arc) -import Swish.RDF.RDFGraph +import Swish.RDF.Parser.NTriples (parseNT) +import Swish.RDF.Formatter.NTriples (formatGraphAsLazyText) + +import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) , emptyRDFGraph , toRDFGraph ) --- import Swish.Utils.Namespace (makeURIScopedName) - -import Swish.RDF.Vocabulary (langName, rdfXMLLiteral) - -import Swish.RDF.GraphClass (arc) +import Swish.RDF.Vocabulary (toLangTag, rdfXMLLiteral) import Test.HUnit ( Test(TestCase,TestList) @@ -40,6 +37,7 @@ import qualified Data.Text.Lazy as T +import Data.Maybe (fromJust) import TestHelpers (runTestSuite) ------------------------------------------------------------ @@ -114,17 +112,17 @@ -} l0, l1, l2, l3, l4 :: RDFLabel -l0 = Lit "" Nothing -l1 = Lit "l1" Nothing -l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" Nothing -l3 = Lit "l3--\r\"'\\--\x20&--\x17A&--" Nothing -l4 = Lit "l4 \\" Nothing +l0 = Lit "" +l1 = Lit "l1" +l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" +l3 = Lit "l3--\r\"'\\--\x20&--\x17A&--" +l4 = Lit "l4 \\" lfr, lgben, lxml1, lxml2 :: RDFLabel -lfr = Lit "chat" (Just $ langName "fr") -lgben = Lit "football" (Just $ langName "en-gb") -lxml1 = Lit "
" (Just rdfXMLLiteral) -lxml2 = Lit "chat" (Just rdfXMLLiteral) +lfr = LangLit "chat" $ fromJust $ toLangTag "fr" +lgben = LangLit "football" $ fromJust $ toLangTag "en-gb" +lxml1 = TypedLit "
" rdfXMLLiteral +lxml2 = TypedLit "chat" rdfXMLLiteral b1 , b2 :: RDFLabel b1 = Blank "x1" @@ -262,7 +260,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/QNameTest.hs b/tests/QNameTest.hs --- a/tests/QNameTest.hs +++ b/tests/QNameTest.hs @@ -19,16 +19,18 @@ module Main where -import Swish.Utils.QName +import Swish.Namespace (makeQNameScopedName, getQName, getScopedNameURI) +import Swish.QName ( QName + , LName , newQName , qnameFromURI , getNamespace , getLocalName , getQNameURI + , getLName ) -import Swish.Utils.Namespace (makeQNameScopedName, getQName, getScopedNameURI) import Test.HUnit (Test(TestList)) import Network.URI (URI, parseURIReference) @@ -120,9 +122,12 @@ nq1 = newQName base1 "s1" nq2 = newQName base1 "s2" +toQN :: String -> QName +toQN = fromJust . qnameFromURI . toURI + qu1, qu2, qu3, qu4, qu5, qu6, qu7 :: QName -qu1 = qnameFromURI (toURI "http://id.ninebynine.org/wip/2003/test/graph1/node#s1") -qu2 = qnameFromURI (toURI "http://id.ninebynine.org/wip/2003/test/graph2/node/s2") +qu1 = toQN "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" +qu2 = toQN "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" qu3 = "http://id.ninebynine.org/wip/2003/test/graph3/node" qu4 = "http://id.ninebynine.org/wip/2003/test/graph5/" qu5 = "http://id.ninebynine.org/wip/2003/test/graph5/s5" @@ -172,13 +177,13 @@ "http://id.ninebynine.org/wip/2003/test/graph3/node" (getNamespace qb3) , testTextEq "testGetLocalName01" - "s1" (getLocalName qb1s1) + "s1" (getLName (getLocalName qb1s1)) , testTextEq "testGetLocalName02" - "s2" (getLocalName qb2s2) + "s2" (getLName (getLocalName qb2s2)) , testTextEq "testGetLocalName03" - "s3" (getLocalName qb3s3) + "s3" (getLName (getLocalName qb3s3)) , testTextEq "testGetLocalName04" - "" (getLocalName qb3) + "" (getLName (getLocalName qb3)) , testURIEq "testGetQNameURI01" "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" (getQNameURI qb1s1) @@ -277,12 +282,12 @@ URI combination done by newQName (may be tested elsewhere). -} -testSplitURI :: String -> String -> (String,T.Text) -> Test +testSplitURI :: String -> String -> (String, LName) -> Test testSplitURI lbl input (a,b) = let qn = newQName (toURI a) b in TestList - [ testCompare lbl ":split" qn ((qnameFromURI . toURI) input) + [ testCompare lbl ":split" qn ((fromJust . qnameFromURI . toURI) input) , testCompare lbl ":show" input (show (getQNameURI qn)) ] @@ -334,7 +339,7 @@ testSQRoundTrip :: String -> String -> Test testSQRoundTrip lbl uri = let u = (fromJust . parseURIReference) uri - qn = qnameFromURI u + qn = (fromJust . qnameFromURI) u sn = makeQNameScopedName Nothing qn in TestList [ testCompare "SQ:URI" lbl u (getScopedNameURI sn) diff --git a/tests/RDFDatatypeXsdIntegerTest.hs b/tests/RDFDatatypeXsdIntegerTest.hs --- a/tests/RDFDatatypeXsdIntegerTest.hs +++ b/tests/RDFDatatypeXsdIntegerTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDFDatatypeXsdIntegerTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -19,26 +19,7 @@ module Main where -import Swish.RDF.RDFDatatypeXsdInteger - ( rdfDatatypeXsdInteger - , rdfDatatypeValXsdInteger - , typeNameXsdInteger, namespaceXsdInteger - , axiomsXsdInteger, rulesXsdInteger - , prefixXsdInteger - ) - -import Swish.RDF.RDFVarBinding (RDFVarBinding) - -import Swish.RDF.RDFRuleset - ( RDFRule - , makeRDFGraphFromN3Builder - ) - -import Swish.RDF.RDFDatatype (RDFDatatypeMod, applyRDFDatatypeMod) -import Swish.RDF.RDFGraph (RDFLabel(..), RDFGraph) -import Swish.RDF.ClassRestrictionRule (falseGraphStr) - -import Swish.RDF.Datatype +import Swish.Datatype ( typeName, typeRules, typeMkRules , getTypeAxiom, getTypeRule , DatatypeVal(..) @@ -47,14 +28,31 @@ , DatatypeMod(..) , nullDatatypeMod ) +import Swish.Namespace (ScopedName, getNamespaceURI, makeScopedName, makeNSScopedName, namespaceToBuilder) +import Swish.QName (LName) +import Swish.Rule (Formula(..), Rule(..), nullFormula, nullRule) +import Swish.Ruleset (Ruleset(..), getRulesetRule) +import Swish.VarBinding (makeVarBinding) -import Swish.RDF.Ruleset (Ruleset(..), getRulesetRule) -import Swish.RDF.Rule (Formula(..), Rule(..), nullFormula, nullRule) -import Swish.RDF.VarBinding (makeVarBinding) -import Swish.Utils.Namespace (getNamespaceURI, ScopedName, makeScopedName, makeNSScopedName) -import Swish.RDF.Vocabulary (namespaceDefault) -import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe) +import Swish.RDF.ClassRestrictionRule (falseGraphStr) +import Swish.RDF.Datatype (RDFDatatypeMod, applyRDFDatatypeMod) +import Swish.RDF.Datatype.XSD.Integer + ( rdfDatatypeXsdInteger + , rdfDatatypeValXsdInteger + , typeNameXsdInteger, namespaceXsdInteger + , axiomsXsdInteger, rulesXsdInteger + ) + +import Swish.RDF.VarBinding (RDFVarBinding) + +import Swish.RDF.Ruleset (RDFRule, makeRDFGraphFromN3Builder) +import Swish.RDF.Graph (RDFLabel(..), RDFGraph) + +import Swish.RDF.Vocabulary (namespaceDefault, namespaceRDF, namespaceRDFD, namespaceXSD) + +import Data.LookupMap (LookupMap(..), mapFindMaybe) + import Test.HUnit ( Test(TestCase,TestList) , assertFailure @@ -79,7 +77,7 @@ toURI :: String -> URI toURI = fromJust . parseURI -xsdIntName :: T.Text -> ScopedName +xsdIntName :: LName -> ScopedName xsdIntName = makeNSScopedName namespaceXsdInteger axiomXsdIntegerDT :: ScopedName @@ -221,10 +219,10 @@ rdfVB (v,b) = (Var v,Blank b) -- (Variable,Blank) rdfVL :: (String, String) -> (RDFLabel, RDFLabel) -rdfVL (v,l) = (Var v,Lit (T.pack l) Nothing) -- (Variable,Untyped literal) +rdfVL (v,l) = (Var v, Lit (T.pack l)) -- (Variable,Untyped literal) rdfVI :: (String, String) -> (RDFLabel, RDFLabel) -rdfVI (v,l) = (Var v,Lit (T.pack l) (Just typeNameXsdInteger)) +rdfVI (v,l) = (Var v, TypedLit (T.pack l) typeNameXsdInteger) -- (Variable,Integer literal) makeBVR :: [(String,ScopedName)] -> RDFVarBinding @@ -744,11 +742,19 @@ -- Test rules defined for datatype ------------------------------------------------------------ +prefixes :: B.Builder +prefixes = mconcat $ map namespaceToBuilder + [ namespaceRDF + , namespaceRDFD + , namespaceXSD + , namespaceXsdInteger + ] + mkGraph :: B.Builder -> RDFGraph mkGraph gr = let base = "@prefix : <" `mappend` (ns `mappend` "> . \n") ns = B.fromString $ show $ getNamespaceURI namespaceDefault - in makeRDFGraphFromN3Builder (prefixXsdInteger `mappend` (base `mappend` gr)) + in makeRDFGraphFromN3Builder (prefixes `mappend` (base `mappend` gr)) testRuleFwd :: String -> Maybe (Rule RDFGraph) -> B.Builder -> [B.Builder] -> Test testRuleFwd lab (Just rule) antstr constrs = @@ -1352,7 +1358,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/RDFGraphTest.hs b/tests/RDFGraphTest.hs --- a/tests/RDFGraphTest.hs +++ b/tests/RDFGraphTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDFGraphTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -18,18 +18,16 @@ module Main where -import Swish.Utils.LookupMap - ( LookupMap(..), LookupEntryClass(..) - , mapFindMaybe ) +import Swish.Namespace (Namespace, makeNamespace, getNamespaceURI, ScopedName, makeNSScopedName, nullScopedName) +import Swish.QName (QName, qnameFromURI) -import Swish.Utils.ListHelpers (equiv) +import Data.LookupMap (LookupMap(..), LookupEntryClass(..), mapFindMaybe) -import Swish.RDF.GraphClass (Label(..), arc) +import Swish.Utils.ListHelpers (equiv) -import Swish.Utils.Namespace (Namespace, makeNamespace, getNamespaceURI, ScopedName, makeNSScopedName, nullScopedName) -import Swish.Utils.QName (QName, qnameFromURI) +import Swish.GraphClass (Label(..), arc) -import Swish.RDF.RDFGraph +import Swish.RDF.Graph ( RDFTriple, toRDFTriple, fromRDFTriple , RDFGraph , RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..) @@ -46,7 +44,8 @@ import Swish.RDF.Vocabulary ( namespaceRDF - , langName + , LanguageTag + , toLangTag , rdfXMLLiteral , xsdBoolean , xsdInteger @@ -84,19 +83,22 @@ -- Test language tag comparisons ------------------------------------------------------------ -type Lang = Maybe ScopedName +type Lang = Maybe LanguageTag +toLT :: T.Text -> LanguageTag +toLT = fromJust . toLangTag + lt0, lt1, lt2, lt3, lt4, lt5, lt6, lt7, lt8 :: Lang lt0 = Nothing -lt1 = Just (langName "en") -lt2 = Just (langName "EN") -lt3 = Just (langName "fr") -lt4 = Just (langName "FR") -lt5 = Just (langName "en-us") -lt6 = Just (langName "en-US") -lt7 = Just (langName "EN-us") -lt8 = Just (langName "EN-US") +lt1 = Just (toLT "en") +lt2 = Just (toLT "EN") +lt3 = Just (toLT "fr") +lt4 = Just (toLT "FR") +lt5 = Just (toLT "en-us") +lt6 = Just (toLT "en-US") +lt7 = Just (toLT "EN-us") +lt8 = Just (toLT "EN-US") langlist :: [(String, Lang)] langlist = @@ -156,7 +158,7 @@ base4 = toNS "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" qn1s1 :: QName -qn1s1 = qnameFromURI $ toURI $ base1Str ++ "s1" +qn1s1 = fromJust $ qnameFromURI $ toURI $ base1Str ++ "s1" qu1s1 :: URI qu1s1 = toURI $ base1Str ++ "s1" @@ -242,30 +244,30 @@ l1, l2, l2gb, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12 :: RDFLabel l1 = "l1" -- use IsString instance -l2 = Lit "l2" (Just (langName "en")) -l2gb = Lit "l2" (Just (langName "en-gb")) -l3 = Lit "l2" (Just (langName "fr")) -l4 = Lit "l4" (Just qb1t1) -l5 = Lit "l4" (Just qb1t1) -l6 = Lit "l4" (Just qb1t1) -l7 = Lit "l4" (Just qb1t2) -l8 = Lit "l4" (Just qb1t2) -l9 = Lit "l4" (Just qb1t2) -l10 = Lit "l10" (Just rdfXMLLiteral) --- l11 = Lit "l11" (Just rdfXMLLiteral) --- l12 = Lit "l12" (Just rdfXMLLiteral) -l11 = Lit "l10" (Just rdfXMLLiteral) -- are these meant to both be l10? -l12 = Lit "l10" (Just rdfXMLLiteral) -- if you change them some tests fail +l2 = LangLit "l2" (toLT "en") +l2gb = LangLit "l2" (toLT "en-gb") +l3 = LangLit "l2" (toLT "fr") +l4 = TypedLit "l4" qb1t1 +l5 = TypedLit "l4" qb1t1 +l6 = TypedLit "l4" qb1t1 +l7 = TypedLit "l4" qb1t2 +l8 = TypedLit "l4" qb1t2 +l9 = TypedLit "l4" qb1t2 +l10 = TypedLit "l10" rdfXMLLiteral +-- l11 = TypedLit "l11" (Just rdfXMLLiteral) +-- l12 = TypedLit "l12" (Just rdfXMLLiteral) +l11 = TypedLit "l10" rdfXMLLiteral -- are these meant to both be l10? +l12 = TypedLit "l10" rdfXMLLiteral -- if you change them some tests fail nanF, infF, ninfF :: RDFLabel -nanF = Lit "NaN" (Just xsdFloat) -infF = Lit "INF" (Just xsdFloat) -ninfF = Lit "-INF" (Just xsdFloat) +nanF = TypedLit "NaN" xsdFloat +infF = TypedLit "INF" xsdFloat +ninfF = TypedLit "-INF" xsdFloat nanD, infD, ninfD :: RDFLabel -nanD = Lit "NaN" (Just xsdDouble) -infD = Lit "INF" (Just xsdDouble) -ninfD = Lit "-INF" (Just xsdDouble) +nanD = TypedLit "NaN" xsdDouble +infD = TypedLit "INF" xsdDouble +ninfD = TypedLit "-INF" xsdDouble v1, v2, v3, v4, vb3, vb4 :: RDFLabel v1 = Var "v1" @@ -333,20 +335,22 @@ -- test ToRDFLabel/FromRDFlabel/IsString instances -- + +toLbl :: T.Text -> Maybe ScopedName -> RDFLabel +toLbl sVal (Just dtype) = TypedLit sVal dtype +toLbl sVal _ = Lit sVal testToConv :: (ToRDFLabel a, Eq a, Show a) => String -> T.Text -> Maybe ScopedName -> a -> Test testToConv lbl sVal dtype hVal = - let rdfVal = Lit sVal dtype - in testEq (":tconv:" ++ lbl) rdfVal (toRDFLabel hVal) + testEq (":tconv:" ++ lbl) (toLbl sVal dtype) $ toRDFLabel hVal testFrConv :: (FromRDFLabel a, Eq a, Show a) => String -> T.Text -> Maybe ScopedName -> a -> Test testFrConv lbl sVal dtype hVal = - let rdfVal = Lit sVal dtype - in testEq (":fconv:" ++ lbl) (Just hVal) (fromRDFLabel rdfVal) + testEq (":fconv:" ++ lbl) (Just hVal) $ fromRDFLabel (toLbl sVal dtype) testConv :: (ToRDFLabel a, FromRDFLabel a, Eq a, Show a) @@ -367,24 +371,24 @@ -- failure case testEq "fconv:fail chr1" (Nothing :: Maybe Char) (fromRDFLabel l1) , testEq "fconv:fail chr2" (Nothing :: Maybe Char) (fromRDFLabel s1) - , testEq "fconv:fail str1" (Nothing :: Maybe String) (fromRDFLabel (Lit "1.23" (Just xsdFloat))) + , testEq "fconv:fail str1" (Nothing :: Maybe String) (fromRDFLabel (TypedLit "1.23" xsdFloat)) , testEq "fconv:fail bool1" (Nothing :: Maybe Bool) (fromRDFLabel l1) - , testEq "fconv:fail bool2" (Nothing :: Maybe Bool) (fromRDFLabel (Lit "True" (Just xsdBoolean))) -- should we just let this be valid? - , testEq "fconv:fail bool3" (Nothing :: Maybe Bool) (fromRDFLabel (Lit "true" (Just xsdFloat))) + , testEq "fconv:fail bool2" (Nothing :: Maybe Bool) (fromRDFLabel (TypedLit "True" xsdBoolean)) -- should we just let this be valid? + , testEq "fconv:fail bool3" (Nothing :: Maybe Bool) (fromRDFLabel (TypedLit "true" xsdFloat)) , testEq "fconv:fail int1" (Nothing :: Maybe Int) (fromRDFLabel l1) - , testEq "fconv:fail int2" (Nothing :: Maybe Int) (fromRDFLabel (Lit "123456789012345" (Just xsdInteger))) + , testEq "fconv:fail int2" (Nothing :: Maybe Int) (fromRDFLabel (TypedLit "123456789012345" xsdInteger)) , testEq "fconv:fail float1" (Nothing :: Maybe Float) (fromRDFLabel l1) - , testEq "fconv:fail float2" (Nothing :: Maybe Float) (fromRDFLabel (Lit "1.234e101" (Just xsdFloat))) -- invalid input - , testEq "fconv:fail float3" (Nothing :: Maybe Float) (fromRDFLabel (Lit "-1.234e101" (Just xsdFloat))) -- invalid input - , testEq "fconv:fail float4" (Nothing :: Maybe Float) (fromRDFLabel (Lit "NaNs" (Just xsdFloat))) -- invalid input - , testEq "fconv:fail dbl1" (Nothing :: Maybe Double) (fromRDFLabel (Lit "1.23" (Just xsdFloat))) -- invalid input + , testEq "fconv:fail float2" (Nothing :: Maybe Float) (fromRDFLabel (TypedLit "1.234e101" xsdFloat)) -- invalid input + , testEq "fconv:fail float3" (Nothing :: Maybe Float) (fromRDFLabel (TypedLit "-1.234e101" xsdFloat)) -- invalid input + , testEq "fconv:fail float4" (Nothing :: Maybe Float) (fromRDFLabel (TypedLit "NaNs" xsdFloat)) -- invalid input + , testEq "fconv:fail dbl1" (Nothing :: Maybe Double) (fromRDFLabel (TypedLit "1.23" xsdFloat)) -- invalid input , testEq "fconv:fail sn1" (Nothing :: Maybe ScopedName) (fromRDFLabel l1) , testEq "fconv:fail qn1" (Nothing :: Maybe QName) (fromRDFLabel l1) , testEq "fconv:fail qu1" (Nothing :: Maybe URI) (fromRDFLabel l1) , testEq "fconv:fail triple" (Nothing :: Maybe (ScopedName, ScopedName, Int)) (fromRDFTriple t01) -- basic string tests - , testEq "tconv:emptystring1" (Lit "" Nothing) "" -- want to try out IsString so do not use testToConv + , testEq "tconv:emptystring1" (Lit "") "" -- want to try out IsString so do not use testToConv , testConv "emptystring2" "" Nothing (""::String) , testConv "char" "x" Nothing 'x' , testToConv "l1-1" "l1" Nothing l1 @@ -1589,7 +1593,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/RDFProofContextTest.hs b/tests/RDFProofContextTest.hs --- a/tests/RDFProofContextTest.hs +++ b/tests/RDFProofContextTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDFProofContextTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -19,23 +19,23 @@ module Main where -import Swish.RDF.BuiltInMap (rdfRulesetMap, allRulesets) -import Swish.RDF.RDFProofContext (rulesetRDF, rulesetRDFS, rulesetRDFD) -import Swish.RDF.RDFProof (RDFProof, RDFProofStep, makeRDFProof, makeRDFProofStep ) +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName, namespaceToBuilder) +import Swish.QName (LName, newLName) +import Swish.Proof (Step(..), checkProof, checkStep, explainProof) +import Swish.Rule (Formula(..), Rule(..), nullFormula, nullRule) +import Swish.Ruleset (getContextAxiom, getContextRule) -import Swish.RDF.RDFRuleset +import Swish.RDF.BuiltIn (rdfRulesetMap, allRulesets) + +import Swish.RDF.ProofContext (rulesetRDF, rulesetRDFS, rulesetRDFD) +import Swish.RDF.Proof (RDFProof, RDFProofStep, makeRDFProof, makeRDFProofStep ) +import Swish.RDF.Ruleset ( RDFFormula, RDFRule, RDFRuleset , nullRDFFormula , makeRDFFormula ) -import Swish.RDF.RDFGraph (RDFGraph) -import Swish.RDF.RDFGraphShowM () -import Swish.RDF.Proof (Step(..), checkProof, checkStep, explainProof) -import Swish.RDF.Ruleset (getContextAxiom, getContextRule) -import Swish.RDF.Rule (Formula(..), Rule(..), nullFormula, nullRule) - -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName, namespaceToBuilder) -import Swish.Utils.LookupMap (mapFindMaybe) +import Swish.RDF.Graph (RDFGraph) +-- import Swish.RDF.GraphShowLines () import Swish.RDF.Vocabulary ( namespaceRDF @@ -48,6 +48,8 @@ , scopeRDFD ) +import Data.LookupMap (mapFindMaybe) + import Test.HUnit ( Test(TestCase,TestList) , assertBool, assertEqual ) @@ -91,7 +93,7 @@ -- Various support methods -makeFormula :: Namespace -> T.Text -> B.Builder -> RDFFormula +makeFormula :: Namespace -> LName -> B.Builder -> RDFFormula makeFormula scope local gr = makeRDFFormula scope local (prefix `mappend` gr) @@ -103,7 +105,7 @@ getAxiom nam = getContextAxiom (makeSName nam) nullRDFFormula rdfdContext makeSName :: String -> ScopedName -makeSName nam = makeNSScopedName ns (T.pack loc) +makeSName nam = makeNSScopedName ns (fromJust (newLName (T.pack loc))) where (pre,_:loc) = break (==':') nam ns = case pre of @@ -678,7 +680,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/RDFProofTest.hs b/tests/RDFProofTest.hs --- a/tests/RDFProofTest.hs +++ b/tests/RDFProofTest.hs @@ -19,16 +19,17 @@ module Main where -import Swish.RDF.RDFProof +import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.Rule (Rule(..)) +import Swish.VarBinding (VarBinding(..), VarBindingModify(..)) +import Swish.VarBinding (makeVarFilterModify, varBindingId, varFilterNE) + +import Swish.RDF.Proof ( makeRdfInstanceEntailmentRule , makeRdfSubgraphEntailmentRule , makeRdfSimpleEntailmentRule ) - -import Swish.RDF.RDFQuery (rdfQueryFind, rdfQuerySubs) -import Swish.RDF.RDFVarBinding (RDFVarBinding, RDFVarBindingModify) - -import Swish.RDF.RDFRuleset +import Swish.RDF.Ruleset ( RDFRule , makeRDFGraphFromN3Builder , makeN3ClosureAllocatorRule @@ -37,20 +38,12 @@ , makeNodeAllocTo ) -import Swish.RDF.RDFGraph - ( Label(..), RDFLabel(..), RDFGraph - , add, allLabels, allNodes ) - -import Swish.RDF.VarBinding - ( VarBinding(..) - , VarBindingModify(..) - , makeVarFilterModify - , varBindingId -- , varFilterDisjunction, varFilterConjunction - , varFilterNE - ) +import Swish.RDF.Query (rdfQueryFind, rdfQuerySubs) +import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingModify) -import Swish.RDF.Rule (Rule(..)) -import Swish.Utils.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) +import Swish.RDF.Graph + ( Label(..), RDFLabel(..), RDFGraph + , addGraphs, allLabels, allNodes ) import Test.HUnit ( Test(TestList) ) @@ -143,7 +136,7 @@ fwd11 = fwdApply rul11 [graph1] bwd11 :: [[RDFGraph]] -bwd11 = bwdApply rul11 (add result11b result11c) +bwd11 = bwdApply rul11 (addGraphs result11b result11c) test1 :: Test test1 = diff --git a/tests/RDFQueryTest.hs b/tests/RDFQueryTest.hs --- a/tests/RDFQueryTest.hs +++ b/tests/RDFQueryTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDFQueryTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -22,17 +22,26 @@ module Main where -import Swish.RDF.RDFQuery +import Swish.Namespace (getNamespaceURI, ScopedName, makeScopedName) +import Swish.VarBinding + ( VarBinding(..) + , makeVarBinding + , joinVarBindings + , VarBindingModify(..) + , makeVarFilterModify + , varBindingId + , varFilterNE + ) +import Swish.RDF.Query ( rdfQueryFind, rdfQueryFilter , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify , rdfQueryInstance , rdfQuerySubs, rdfQueryBackSubs , rdfQuerySubsAll , rdfQuerySubsBlank, rdfQueryBackSubsBlank - -- debug ) -import Swish.RDF.RDFVarBinding +import Swish.RDF.VarBinding ( RDFVarBinding , RDFVarBindingFilter , rdfVarBindingUriRef, rdfVarBindingBlank @@ -42,20 +51,10 @@ , rdfVarBindingMemberProp ) -import Swish.RDF.RDFGraph (RDFGraph, RDFLabel(..), merge) -import Swish.RDF.VarBinding - ( VarBinding(..) - , makeVarBinding - , joinVarBindings - , VarBindingModify(..) - , makeVarFilterModify - , varBindingId - , varFilterNE - ) +import Swish.RDF.Graph (RDFGraph, RDFLabel(..), merge) -import Swish.Utils.Namespace (getNamespaceURI, ScopedName, makeScopedName) -import Swish.RDF.Vocabulary (namespaceRDF, langName, swishName, rdfType, rdfXMLLiteral) -import Swish.RDF.N3Parser (parseN3) +import Swish.RDF.Vocabulary (namespaceRDF, toLangTag, swishName, rdfType, rdfXMLLiteral) +import Swish.RDF.Parser.N3 (parseN3) import Test.HUnit ( Test(TestList) ) @@ -1287,11 +1286,11 @@ u_dt = Res q_dattyp l_1, l_2, l_3, l_4, l_5 :: RDFLabel -l_1 = Lit "l1" Nothing -l_2 = Lit "l2" (Just $ langName "fr") -l_3 = Lit "l3" (Just q_dattyp) -l_4 = Lit "l4" (Just q_dattyp) -- was: (Lang "fr") -l_5 = Lit "l5" (Just rdfXMLLiteral) +l_1 = Lit "l1" +l_2 = LangLit "l2" $ fromJust $ toLangTag "fr" +l_3 = TypedLit "l3" q_dattyp +l_4 = TypedLit "l4" q_dattyp +l_5 = TypedLit "l5" rdfXMLLiteral b_1, b_2, b_3, b_l1, b_l2 :: RDFLabel b_1 = Blank "1" @@ -1666,7 +1665,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/RDFRulesetTest.hs b/tests/RDFRulesetTest.hs --- a/tests/RDFRulesetTest.hs +++ b/tests/RDFRulesetTest.hs @@ -5,7 +5,7 @@ -------------------------------------------------------------------------------- -- | -- Module : RDFRulesetTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -20,27 +20,33 @@ module Main where -import Swish.RDF.RDFRuleset +import Swish.Namespace (Namespace, makeNamespace, getNamespaceTuple, getNamespaceURI, ScopedName, makeScopedName, makeNSScopedName, namespaceToBuilder) +import Swish.QName (LName) +import Swish.Rule (Formula(..), Rule(..), fwdCheckInference ) +import Swish.Ruleset (makeRuleset, getRulesetNamespace, getRulesetAxioms) +import Swish.Ruleset (getRulesetRules, getRulesetAxiom, getRulesetRule) +import Swish.VarBinding (makeVarBinding, vbmCompose, makeVarFilterModify) + +import Swish.RDF.Ruleset ( RDFFormula, RDFRule, RDFClosure, RDFRuleset , GraphClosure(..) , makeRDFGraphFromN3Builder , makeRDFFormula , makeN3ClosureSimpleRule , makeNodeAllocTo - -- for debugging , graphClosureFwdApply, graphClosureBwdApply ) -import Swish.RDF.RDFQuery (rdfQueryBack, rdfQueryBackModify) +import Swish.RDF.Query (rdfQueryBack, rdfQueryBackModify) -import Swish.RDF.RDFVarBinding +import Swish.RDF.VarBinding ( RDFVarBinding , RDFVarBindingModify , RDFVarBindingFilter , rdfVarBindingXMLLiteral ) -import Swish.RDF.RDFGraph +import Swish.RDF.Graph ( Label (..), RDFLabel(..), RDFGraph , Arc(..) , getArcs @@ -48,14 +54,7 @@ , toRDFGraph ) -import Swish.RDF.VarBinding (makeVarBinding, vbmCompose, makeVarFilterModify) -import Swish.RDF.Ruleset - ( makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules - , getRulesetAxiom, getRulesetRule ) - -import Swish.RDF.Rule (Formula(..), Rule(..), fwdCheckInference ) import Swish.RDF.Vocabulary (namespaceRDF, namespaceRDFS, namespaceOWL, scopeRDF) -import Swish.Utils.Namespace (Namespace, makeNamespace, getNamespaceTuple, getNamespaceURI, ScopedName, makeScopedName, makeNSScopedName, namespaceToBuilder) import Test.HUnit ( Test(TestCase,TestList) @@ -268,7 +267,7 @@ scopeex :: Namespace scopeex = toNS (Just "ex") "http://id.ninebynine.org/wip/2003/RDFProofCheck#" -makeFormula :: Namespace -> T.Text -> B.Builder -> RDFFormula +makeFormula :: Namespace -> LName -> B.Builder -> RDFFormula makeFormula scope local gr = makeRDFFormula scope local $ prefix `mappend` gr @@ -403,7 +402,8 @@ -------------------------------------------------------------------------------- -- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- All rights reserved. -- -- This file is part of Swish. diff --git a/tests/VarBindingTest.hs b/tests/VarBindingTest.hs --- a/tests/VarBindingTest.hs +++ b/tests/VarBindingTest.hs @@ -19,7 +19,7 @@ module Main where -import Swish.RDF.VarBinding +import Swish.VarBinding ( VarBinding(..) , subBinding, nullVarBinding, makeVarBinding , boundVars, subBinding, makeVarBinding