swish-0.10.4.0/app/0000755000000000000000000000000014205001511012022 5ustar0000000000000000swish-0.10.4.0/scripts/0000755000000000000000000000000013767226176012765 5ustar0000000000000000swish-0.10.4.0/src/0000755000000000000000000000000014220136201012033 5ustar0000000000000000swish-0.10.4.0/src/Data/0000755000000000000000000000000013543702315012720 5ustar0000000000000000swish-0.10.4.0/src/Data/Interned/0000755000000000000000000000000014312330055014461 5ustar0000000000000000swish-0.10.4.0/src/Data/Ord/0000755000000000000000000000000013543702315013444 5ustar0000000000000000swish-0.10.4.0/src/Data/String/0000755000000000000000000000000013543702315014166 5ustar0000000000000000swish-0.10.4.0/src/Network/0000755000000000000000000000000013543702315013500 5ustar0000000000000000swish-0.10.4.0/src/Network/URI/0000755000000000000000000000000013543702315014137 5ustar0000000000000000swish-0.10.4.0/src/Swish/0000755000000000000000000000000014312330055013135 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/0000755000000000000000000000000014220136201013543 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/BuiltIn/0000755000000000000000000000000014220136201015111 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/Datatype/0000755000000000000000000000000013543702315015332 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/0000755000000000000000000000000014220136201015754 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/Formatter/0000755000000000000000000000000014312330055015513 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/Parser/0000755000000000000000000000000014312330055015004 5ustar0000000000000000swish-0.10.4.0/src/Swish/RDF/Vocabulary/0000755000000000000000000000000014162356332015670 5ustar0000000000000000swish-0.10.4.0/src/Swish/Utils/0000755000000000000000000000000013543702315014244 5ustar0000000000000000swish-0.10.4.0/tests/0000755000000000000000000000000014205054002012407 5ustar0000000000000000swish-0.10.4.0/src/Data/Interned/URI.hs0000644000000000000000000000652314220136201015455 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE TypeFamilies #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : URI -- Copyright : (c) 2011, 2012, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies, FlexibleInstances, TypeFamilies -- -- Support interning URIs. -- -------------------------------------------------------------------------------- module Data.Interned.URI ( InternedURI ) where import Data.String (IsString(..)) import Data.Hashable import Data.Interned import Data.Maybe (fromMaybe) import Network.URI -- 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 fromString = intern . fromMaybe (error "Error: unable to create a URI.") . parseURIReference instance Eq InternedURI where InternedURI a _ == InternedURI b _ = a == b instance Ord InternedURI where compare (InternedURI a _) (InternedURI b _) = compare a b instance Show InternedURI where showsPrec d (InternedURI _ b) = showsPrec d b instance Interned InternedURI where type Uninterned InternedURI = URI data Description InternedURI = DU !URI deriving #if (__GLASGOW_HASKELL__ >= 802) stock #endif (Eq) describe = DU identify = InternedURI #if MIN_VERSION_intern(0,9,0) #else identity (InternedURI i _) = i #endif cache = iuCache instance Uninternable InternedURI where unintern (InternedURI _ b) = b -- Rather than access the URI components, just use the reverse of the -- string representation of the URI. instance Hashable (Description InternedURI) where #if MIN_VERSION_hashable(1,2,0) #else hash = hashWithSalt 5381 -- use the stringSalt value from Data.Hashable #endif hashWithSalt salt (DU u) = hashWithSalt salt ((reverse . show) u) iuCache :: Cache InternedURI iuCache = mkCache {-# NOINLINE iuCache #-} -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Data/Ord/Partial.hs0000644000000000000000000002733513543702315015406 0ustar0000000000000000-------------------------------------------------------------------------------- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Data/String/ShowLines.hs0000644000000000000000000000567613543702315016453 0ustar0000000000000000-------------------------------------------------------------------------------- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Network/URI/Ord.hs0000644000000000000000000000402513543702315015220 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Ord -- Copyright : (c) 2012, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : As it provides nothing, it should be pretty portable -- -- *This module is deprecated and will be removed* -- -- This module no-longer does anything since -- 'Network.URI.URI' now has an 'Ord' instance by -- default (prior to @network @2.4.0.0@ this was not the case). -- -- This module used to provide an ordering for earlier versions -- of the network package, but with the split of 'Network.URI' -- out to the @network-uri@ in version @2.6.0.0@, the CPP -- needed to keep this going got annoying enough for me to -- just require a recent @network@ package. -- -------------------------------------------------------------------------------- module Network.URI.Ord () where -------------------------------------------------------------------------------- -- -- Copyright (c) 2014 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish.hs0000644000000000000000000002734414220136201013476 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2020 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -- Swish: Semantic Web Inference Scripting in Haskell -- -- This program is a simple skeleton for constructing Semantic Web [1] -- inference tools in Haskell, using the RDF graph and several RDF -- parsers (at present Notation 3 and NTriples). -- -- It might be viewed as a kind of embroyonic CWM [2] in Haskell, -- except that the intent is that Haskell will be used as a primary -- language for defining inferences. As such, Swish is an open-ended -- toolkit for constructing new special-purpose Semantic Web -- applications rather than a closed, self-contained general-purpose -- SW application. As such, it is part of another experiment along -- the lines described in [3]. -- -- The script format used by Swish is described in -- "Swish.Script". -- -- Users wishing to process RDF data directly may prefer to look at -- 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: -- -- (2) CWM: -- -- (3) Motivation: -- -- (4) Notation 3: -- -- (5) Turtle: -- -- (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 ( SwishStatus(..) , SwishAction , runSwish , runSwishActions , displaySwishHelp , splitArguments , validateCommands ) where 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 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 `fmap` execStateT (swishCommands acts) emptyState -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Commands.hs0000644000000000000000000003250714220136201015234 0ustar0000000000000000{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Commands -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014, 2020 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : FlexibleContexts, 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 (when) import qualified Data.Set as S 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 (S.toList $ getArcs oldGr) p2 = partitionGraph (S.toList $ 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 = gets (fromMaybe defURI . 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, 2014, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Datatype.hs0000644000000000000000000012507614220136201015252 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Datatype -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2018, 2019, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : ExistentialQuantification, 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(..)) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 808) import Control.Applicative ((<$>)) #endif import Data.Maybe (isJust, catMaybes) import qualified Data.Map as M 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) -- |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 = let m = M.fromList $ map (\n -> (dtRelName n, n)) (tvalRel dtv) in M.lookup nam m -- | Return the named datatype value modifier, if it exists. getDTMod :: ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) getDTMod nam dtv = let m = M.fromList $ map (\n -> (dmName n, n)) (tvalMod dtv) in M.lookup nam m -- |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 = 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 } -- |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 } -- |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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 :: (Ord lb, Ord 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 = fmap 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 = 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, 2018, 2019, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/GraphClass.hs0000644000000000000000000001726414220136201015525 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE DeriveTraversable #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphClass -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2016, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DeriveTraversable, DerivingStrategies, 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(..) , ArcSet , Selector , arc, arcToTriple, arcFromTriple , hasLabel, arcLabels -- , arcNodes , getComponents ) where import Data.Hashable (Hashable(..)) import Data.List (foldl') import Data.Ord (comparing) import qualified Data.Foldable as F import qualified Data.Set as S 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 LDGraph lg lb where -- | Create the empty graph. emptyGraph :: lg lb -- | Replace the existing arcs in the graph. setArcs :: lg lb -> ArcSet lb -> lg lb -- | Extract all the arcs from a graph getArcs :: lg lb -> ArcSet lb -- | Extract those arcs that match the given `Selector`. extract :: (Ord lb) => Selector lb -> lg lb -> lg lb extract sel = update (S.filter sel) -- | Add the two graphs addGraphs :: (Ord lb) => lg lb -> lg lb -> lg lb addGraphs addg = update (S.union (getArcs addg)) -- | Remove those arcs in the first graph from the second -- graph delete :: (Ord lb) => lg lb -- ^ g1 -> lg lb -- ^ g2 -> lg lb -- ^ g2 - g1 -> g3 delete g1 g2 = setArcs g2 (getArcs g2 `S.difference` getArcs g1) -- | 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 :: (Ord lb) => lg lb -> S.Set lb labels = getComponents arcLabels . getArcs -- | Enumerate the distinct nodes contained in a graph; -- that is, any label that appears in the subject -- or object position of an `Arc`. nodes :: (Ord lb) => lg lb -> S.Set lb nodes = getComponents arcNodes . getArcs -- | Update the arcs in a graph using a supplied function. update :: (ArcSet lb -> ArcSet lb) -> lg lb -> lg lb update f g = setArcs g ( f (getArcs g) ) -- | Extract components from a set. getComponents :: Ord b => (a -> [b]) -> S.Set a -> S.Set b getComponents f = let ins sgr = foldl' (flip S.insert) sgr . f in S.foldl' ins S.empty -- | 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. -- -- We do not need Ord/Show constraints here, but it means we can just use -- Label as a short-form for Ord/Show in code class (Ord lb, Show 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 -- | 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif (Eq, Functor, F.Foldable, T.Traversable) -- | A set - or graph - of arcs. type ArcSet lb = S.Set (Arc lb) instance (Hashable lb) => Hashable (Arc lb) where #if MIN_VERSION_hashable(1,2,0) #else hash (Arc s p o) = hash s `hashWithSalt` p `hashWithSalt` o #endif 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 = comparing arcToTriple 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, 2016, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/GraphMatch.hs0000644000000000000000000006442614220136201015516 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphMatch -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2016, 2018, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : FlexibleInstances, 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(..), ArcSet, Label(..)) import Swish.GraphClass (getComponents, arcLabels, hasLabel, arcToTriple) import Control.Exception.Base (assert) import Control.Arrow (second) import Data.Function (on) import Data.Hashable (hashWithSalt) import Data.List (foldl', sortBy, groupBy, partition) import Data.Ord (comparing) import Data.Word import qualified Data.List as L import qualified Data.Map as M import qualified Data.Set as S -------------------------- -- 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, Show lv) => Show (GenLabelEntry lb lv) where show (LabelEntry k v) = show k ++ ":" ++ show v instance (Label lb, Eq lv) => Eq (GenLabelEntry lb lv) where (LabelEntry k1 v1) == (LabelEntry k2 v2) = (k1,v1) == (k2,v2) instance (Label lb, Ord lv) => Ord (GenLabelEntry lb lv) where (LabelEntry lb1 lv1) `compare` (LabelEntry lb2 lv2) = (lb1, lv1) `compare` (lb2, lv2) -- | Type for label->index lookup table data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = LabelMap Word32 (M.Map 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, lmap1) == (gen2, lmap2) -- | The empty label map table. emptyMap :: (Label lb) => LabelMap lb emptyMap = LabelMap 1 M.empty -------------------------- -- 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) -- TODO: use set on input -- | 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 `hashWithSalt` 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)) ? -- TODO: Should this use Set (Arc lb) instead of [Arc 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.) -> ArcSet lb -- ^ the first graph to be compared -> ArcSet lb -- ^ the second graph to be compared -> (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 " $ -} S.map (makeScopedArc 1) gs1 sgs2 = {- trace "sgs2 " $ -} S.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. -> ArcSet lb -- ^ (@gs1@ argument) -- first of two lists of arcs (triples) to be compared -> ArcSet 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) -> ArcSet lb -> ArcSet 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 = M.toList 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 = M.findWithDefault 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 l2) -- | 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 $ M.insert lb (g,lh) lmap -- | 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) => S.Set lb -> LabelMap lb -> LabelMap lb assignLabelMap ns lmap = S.foldl' (flip assignLabelMap1) lmap ns assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb assignLabelMap1 lab (LabelMap g lvs) = LabelMap g $ M.insertWith (const id) lab (g, initVal lab) lvs -- Calculate initial value for a node initVal :: (Label lb) => lb -> Word32 initVal = fromIntegral . hashVal 0 hashVal :: (Label lb) => Word32 -> lb -> Int hashVal seed lab = if labelIsVar lab then 23 `hashWithSalt` seed else labelHash (fromIntegral seed) lab -- | Return the equivalence classes of the supplied nodes -- using the label map. equivalenceClasses :: (Label lb) => LabelMap lb -- ^ label map -> S.Set lb -- ^ nodes to be reclassified -> [EquivalenceClass lb] equivalenceClasses lmap ls = pairGroup $ S.toList $ S.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) => ArcSet lb -- ^ (the @gs1@ argument) the first of two sets of arcs to perform a -- basis for reclassifying the labels in the first equivalence -- class in each pair of @ecpairs@. -> ArcSet lb -- ^ (the @gs2@ argument) the second of two sets of arcs 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' = classifyCombine lm $ M.union 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) = (M.findWithDefault nullLabelVal lab x,lab) -- Replace the values in lm1 with those from lm2, but do not copy over new -- keys from lm2 classifyCombine :: (Ord a) => M.Map a b -> M.Map a b -> M.Map a b classifyCombine = M.mergeWithKey (\_ _ v -> Just v) id (const M.empty) -- | Calculate a new index value for a supplied set of labels based on the -- supplied label map and adjacency calculations in the supplied graph -- remapLabels :: (Label lb) => ArcSet 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' $ M.fromList newEntries where gen' = gen + 1 newEntries = [ (l, (gen', fromIntegral (newIndex l))) | l <- ls ] -- TODO: should review this given the changes to the hash code -- since it was re-written newIndex l | labelIsVar l = mapAdjacent l -- adjacency classifies variable labels | otherwise = hashVal gen l -- otherwise rehash (to disentangle collisions) TODO: BRANCH IS UNTESTED -- mapAdjacent used to use `rem` hashModulus mapAdjacent l = hashModulus `hashWithSalt` sum (sigsOver l) gls = S.toList gs sigsOver l = select (hasLabel l) gls (arcSignatures lmap gls) -- |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 the set of distinct labels used in the graph. graphLabels :: (Label lb) => ArcSet lb -> S.Set lb graphLabels = getComponents arcLabels -- TODO: worry about overflow? -- TODO: should probably return a Set of (Int, Arc lb) or something, -- as may be useful for the calling code -- | 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) = hashModulus `hashWithSalt` ( labelVal2 s + labelVal2 p * 3 + labelVal2 o * 5 ) 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 ) == ( graphMap nodeMap gs2 ) then (same) -- graphMap :: (Label lb) => LabelMap lb -> ArcSet lb -> ArcSet LabelIndex graphMap = S.map . fmap . mapLabelIndex -- | 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 -> ArcSet lb -> ArcSet lb -> Bool graphMapEq lmap = (==) `on` graphMap lmap -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2016, 2018, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/GraphMem.hs0000644000000000000000000001321513543702315015202 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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, 2014, 2016, 2018 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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 qualified Data.Set as S import Swish.GraphClass import Swish.GraphMatch import Data.Hashable (Hashable(..)) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Ord (comparing) #if !(MIN_VERSION_base(4, 11, 0)) import Data.Semigroup #endif -- | Simple memory-based graph type. data GraphMem lb = GraphMem { arcs :: ArcSet lb } instance LDGraph GraphMem lb where emptyGraph = GraphMem S.empty getArcs = arcs setArcs g as = g { arcs=as } instance (Label lb) => Eq (GraphMem lb) where (==) = graphEq instance (Label lb) => Ord (GraphMem lb) where compare = comparing getArcs instance (Label lb) => Show (GraphMem lb) where show = graphShow instance (Label lb) => Semigroup (GraphMem lb) where (<>) = addGraphs instance (Label lb) => Monoid (GraphMem lb) where mempty = emptyGraph #if !(MIN_VERSION_base(4, 11, 0)) mappend = (<>) #endif graphShow :: (Label lb) => GraphMem lb -> String graphShow g = "Graph:" ++ S.foldr ((++) . ("\n " ++) . show) "" (arcs g) -- | 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 hashWithSalt salt (LF l) = salt `hashWithSalt` (1::Int) `hashWithSalt` l hashWithSalt salt (LV l) = salt `hashWithSalt` (2::Int) `hashWithSalt` l #if !MIN_VERSION_hashable(1,2,0) hash (LF l) = 1 `hashWithSalt` l hash (LV l) = 2 `hashWithSalt` l #endif 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 Ord LabelMem where (LF l1) `compare` (LF l2) = l1 `compare` l2 (LV l1) `compare` (LV l2) = l1 `compare` l2 (LF _) `compare` _ = LT _ `compare` (LF _) = GT instance Show LabelMem where show (LF l1) = '!' : l1 show (LV l2) = '?' : l2 -------------------------------------------------------------------------------- -- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/GraphPartition.hs0000644000000000000000000005225414220136201016427 0ustar0000000000000000{-# LANGUAGE CPP #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphPartition -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies -- -- 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif (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 -- Chose ordering to be "more information" first/smaller (arbitrary choice). instance (Label lb) => Ord (GraphPartition lb) where (PartSub s1 p1) `compare` (PartSub s2 p2) = (s1,p1) `compare` (s2,p2) (PartObj o1) `compare` (PartObj o2) = o1 `compare` o2 (PartSub _ _) `compare` _ = LT _ `compare` (PartSub _ _) = GT 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, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Monad.hs0000644000000000000000000002133314220136201014524 0ustar0000000000000000{-# LANGUAGE CPP #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Monad -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies -- -- Composed state and IO monad for Swish -- -------------------------------------------------------------------------------- module Swish.Monad ( SwishStateIO, SwishState(..), SwishStatus(..) , SwishFormat(..) , 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 -- * 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.List (nub) import System.IO (hPutStrLn, stderr) import qualified Data.Map as M {-| The supported input and output formats. -} data SwishFormat = Turtle -- ^ Turtle format | N3 -- ^ N3 format | NT -- ^ NTriples format deriving #if (__GLASGOW_HASKELL__ >= 802) stock #endif 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif (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 = M.empty , rules = M.empty , 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 = M.lookup 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 (nub $ M.elems $ 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 M.lookup nam (rules state) of Nothing -> getMaybeContextRule nam $ nub $ M.elems $ 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 = M.lookup (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] } -} -- | A LookupMap for the graphs dictionary. type NamedGraphMap = M.Map ScopedName [RDFGraph] -- | 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, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Namespace.hs0000644000000000000000000002052113543702315015374 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Namespace -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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.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.Maybe (fromMaybe) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Ord (comparing) 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 Ord Namespace where -- using show for the URI is wasteful (Namespace a1 b1) `compare` (Namespace a2 b2) = (a1, show b1) `compare` (a2, show b2) instance Show Namespace where show (Namespace (Just p) u) = show p ++ ":<" ++ show u ++ ">" show (Namespace _ u) = "<" ++ show u ++ ">" -- | 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 'QName' values are equal. instance Eq ScopedName where sn1 == sn2 = getQName sn1 == getQName sn2 -- | Scoped names are ordered by their 'QName' components. instance Ord ScopedName where compare = comparing getQName -- | 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Proof.hs0000644000000000000000000002716014220136201014557 0ustar0000000000000000{-# LANGUAGE CPP #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Proof -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2016, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies -- -- 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 Data.List (union, intersect, intercalate, foldl') import Data.Maybe (catMaybes, isNothing) import Data.String.ShowLines (ShowLines(..)) import qualified Data.Set as S ------------------------------------------------------------ -- 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif 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, Ord 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, Ord 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 :: Ord 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, Ord 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, Ord 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 :: Ord 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 (S.fromList sant `S.isSubsetOf` S.fromList prev) -- (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, 2016, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/QName.hs0000644000000000000000000002361114220136201014470 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : QName -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies, OverloadedStrings -- -- This module defines an algebraic datatype for qualified names (QNames), -- which represents a 'URI' as the combination of a namespace 'URI' -- and a local component ('LName'), which can be empty. -- -- Although RDF supports using IRIs, the use of 'URI' here precludes this, -- which means that, for instance, 'LName' only accepts a subset of valid -- characters. There is currently no attempt to convert from an IRI into a URI. -- -------------------------------------------------------------------------------- -- 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 Data.Char (isAscii) import Data.Maybe (fromMaybe) import Data.Interned (intern, unintern) import Data.Interned.URI (InternedURI) import Data.Ord (comparing) import Data.String (IsString(..)) 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 a space character and can only contain ascii characters (those that match 'Data.Char.isAscii'). In version @0.9.0.3@ and earlier, the following characters were not allowed in local names: \'#\', \':\', or \'/\' characters. This is all rather experimental. -} newtype LName = LName T.Text deriving #if (__GLASGOW_HASKELL__ >= 802) stock #endif (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) -- 0.7.0.1 and earlier -- newLName l = if T.any (\c -> c `elem` " #:/" || not (isAscii c)) l then Nothing else Just (LName l) -- 0.9.0.3 and earlier newLName l = if T.any (\c -> c == ' ' || not (isAscii c)) 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> let qn5 = "http://example.com/bob/fred:joe" :: QName > swish> map getLocalName [qn1, qn2, qn3, qn4, qn5] > ["","bob","fred","x","fred:joe"] > 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 u1 == u2 = getQNameURI u1 == getQNameURI u2 -- | In @0.8.0.0@ the ordering now uses the ordering defined in -- "Network.URI.Ord" rather than the @Show@ -- instance. This should make no difference unless a password -- was included in the URI when using basic access authorization. -- instance Ord QName where compare = comparing getQNameURI -- | The format used to display the URI is @\@, and does not -- include the password if using basic access authorization. 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 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 $ start uri emptyLName start = QName (intern uri) in case uf of "#" -> q0 '#':xs -> start (uri {uriFragment = "#"}) `fmap` 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}) `fmap` 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 {-| 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, 2013, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF.hs0000644000000000000000000000341613543702315014117 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDF -- 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 -- -- This module provides an in-memory RDF Graph (it re-exports -- "Swish.RDF.Graph"). -- -------------------------------------------------------------------------------- module Swish.RDF (module Swish.RDF.Graph) where import Swish.RDF.Graph -------------------------------------------------------------------------------- -- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/BuiltIn.hs0000644000000000000000000000365113543702315015466 0ustar0000000000000000-------------------------------------------------------------------------------- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/BuiltIn/Datatypes.hs0000644000000000000000000000552013543702315017421 0ustar0000000000000000-------------------------------------------------------------------------------- -- 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.Datatype (typeName) 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 qualified Data.Map as M ------------------------------------------------------------ -- 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 = M.lookup nam $ M.fromList $ map (\dt -> (typeName dt, dt)) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/BuiltIn/Rules.hs0000644000000000000000000001267714220136201016554 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Rules -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2022 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.Ruleset (getRulesetNamespace) import Swish.VarBinding (openVbmName, 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 qualified Data.Map as M ------------------------------------------------------------ -- 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 = M.lookup nam $ M.fromList $ map (\ovbm -> (openVbmName ovbm, ovbm)) allOpenVarBindingModify ------------------------------------------------------------ -- Lookup map for built-in rulesets ------------------------------------------------------------ -- | A 'LookupMap' of 'allRulesets'. rdfRulesetMap :: RDFRulesetMap rdfRulesetMap = M.fromList $ map (\r -> (getRulesetNamespace r, r)) 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, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/ClassRestrictionRule.hs0000644000000000000000000005433414220136201020233 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : ClassRestrictionRule -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2018, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module implements an inference rule based on a restruction on class -- membership of one or more values. -- -------------------------------------------------------------------------------- module Swish.RDF.ClassRestrictionRule ( ClassRestriction(..), ClassRestrictionFn , makeDatatypeRestriction, makeDatatypeRestrictionFn , makeRDFClassRestrictionRules , makeRDFDatatypeRestrictionRules , falseGraph, falseGraphStr ) where 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 , getArcs , merge , toRDFGraph, emptyRDFGraph , Arc(..) , resRdfType , resRdfdMaxCardinality ) import Swish.RDF.Datatype (RDFDatatypeVal, fromRDFLabel, toRDFLabel) import Swish.RDF.Ruleset (RDFRule, makeRDFGraphFromN3Builder) import Swish.RDF.Query ( rdfQueryFind , rdfFindValSubj, rdfFindPredVal, rdfFindPredInt , rdfFindList ) import Swish.RDF.VarBinding (RDFVarBinding) import Swish.RDF.Vocabulary (namespaceRDFD) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 808) import Control.Applicative ((<$>)) #endif import Data.List (delete, nub, subsequences) import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Ord.Partial (minima, maxima, partCompareEq, partComparePair, partCompareListMaybe, partCompareListSubset) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid (..)) #endif import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B ------------------------------------------------------------ -- Class restriction data type ------------------------------------------------------------ -- |Type of function that evaluates missing node values in a -- restriction from those supplied. type ClassRestrictionFn = [Maybe RDFLabel] -> Maybe [[RDFLabel]] -- |Datatype for named class restriction data ClassRestriction = ClassRestriction { crName :: ScopedName , crFunc :: ClassRestrictionFn } -- | Equality of class restrictions is based on the name of the restriction. instance Eq ClassRestriction where cr1 == cr2 = crName cr1 == crName cr2 instance Show ClassRestriction where show cr = "ClassRestriction:" ++ show (crName cr) ------------------------------------------------------------ -- Instantiate a class restriction from a datatype relation ------------------------------------------------------------ -- |Make a class restriction from a datatype relation. -- -- This lifts application of the datatype relation to operate -- on 'RDFLabel' values, which are presumed to contain appropriately -- datatyped values. -- makeDatatypeRestriction :: RDFDatatypeVal vt -> DatatypeRel vt -> ClassRestriction makeDatatypeRestriction dtv dtrel = ClassRestriction { crName = dtRelName dtrel , crFunc = makeDatatypeRestrictionFn dtv (dtRelFunc dtrel) } -- The core logic below is something like @(map toLabels . dtrelfn . map frLabel)@ -- but the extra lifting and catMaybes are needed to get the final result -- type in the right form. -- |Make a class restriction function from a datatype relation function. -- makeDatatypeRestrictionFn :: RDFDatatypeVal vt -> DatatypeRelFn vt -> ClassRestrictionFn makeDatatypeRestrictionFn dtv dtrelfn = fmap (mapMaybe toLabels) . dtrelfn . map frLabel where frLabel Nothing = Nothing frLabel (Just l) = fromRDFLabel dtv l toLabels = mapM toLabel -- Maybe [RDFLabel] toLabel = toRDFLabel dtv ------------------------------------------------------------ -- Make rules from supplied class restrictions and graph ------------------------------------------------------------ mkPrefix :: Namespace -> B.Builder mkPrefix = namespaceToBuilder ruleQuery :: RDFGraph ruleQuery = makeRDFGraphFromN3Builder $ mconcat [ mkPrefix namespaceRDFD , " ?c a rdfd:GeneralRestriction ; " , " rdfd:onProperties ?p ; " , " rdfd:constraint ?r . " ] -- | 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 . " -- |Make a list of class restriction rules given a list of class restriction -- values and a graph containing one or more class restriction definitions. -- makeRDFClassRestrictionRules :: [ClassRestriction] -> RDFGraph -> [RDFRule] makeRDFClassRestrictionRules crs gr = mapMaybe constructRule (queryForRules gr) where queryForRules = rdfQueryFind ruleQuery constructRule = makeRestrictionRule1 crs gr makeRestrictionRule1 :: [ClassRestriction] -> RDFGraph -> RDFVarBinding -> Maybe RDFRule makeRestrictionRule1 crs gr vb = makeRestrictionRule2 rn c ps cs where c = fromMaybe NoNode $ vbMap vb (Var "c") p = fromMaybe NoNode $ vbMap vb (Var "p") r = fromMaybe NoNode $ vbMap vb (Var "r") cs = filter (> 0) $ map fromInteger $ rdfFindPredInt c resRdfdMaxCardinality gr ps = rdfFindList gr p -- TODO: do not need to go via a map since looking through a list rn = M.lookup (getScopedName r) $ M.fromList $ map (\cr -> (crName cr, cr)) crs makeRestrictionRule2 :: Maybe ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> Maybe RDFRule makeRestrictionRule2 (Just restriction) cls@(Res cname) props cs = Just restrictionRule where restrictionRule = Rule { ruleName = cname -- fwdApply :: [ex] -> [ex] , fwdApply = fwdApplyRestriction restriction cls props cs -- bwdApply :: ex -> [[ex]] , bwdApply = bwdApplyRestriction restriction cls props cs , checkInference = bwdCheckInference restrictionRule } makeRestrictionRule2 _ _ _ _ = Nothing -- trace "\nmakeRestrictionRule: missing class restriction" -- Forward apply class restriction. fwdApplyRestriction :: ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> [RDFGraph] -> [RDFGraph] fwdApplyRestriction restriction cls props cs antgrs = maybe [falseGraph] concat newgrs where -- Instances of the named class in the graph: ris = nub $ rdfFindValSubj resRdfType cls antgr -- Merge antecedent graphs into one (with bnode renaming): -- (Uses 'if' and 'foldl1' to avoid merging in the common case -- of just one graph supplied.) antgr = if null antgrs then emptyRDFGraph else foldl1 merge antgrs -- Apply class restriction to single instance of the restricted class newgr :: RDFLabel -> Maybe [RDFGraph] newgr ri = fwdApplyRestriction1 restriction ri props cs antgr newgrs :: Maybe [[RDFGraph]] newgrs = mapM newgr ris -- Forward apply class restriction to single class instance (ci). -- Return single set of inferred results, for each combination of -- property values, or an empty list, or Nothing if the supplied values -- are inconsistent with the restriction. fwdApplyRestriction1 :: ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph -> Maybe [RDFGraph] fwdApplyRestriction1 restriction ci props cs antgr = if grConsistent then Just newgrs else Nothing where -- Apply restriction to graph (grConsistent,_,_,sts) = applyRestriction restriction ci props cs antgr -- Select results, eliminate those with unknowns nts :: [[RDFLabel]] nts = mapMaybe sequence sts -- Make new graph from results, including only newly generated arcs newarcs = S.fromList [Arc ci p v | vs <- nts, (p,v) <- zip props vs ] `S.difference` getArcs antgr newgrs = if S.null newarcs then [] else [toRDFGraph newarcs] -- Backward apply class restriction. -- -- Returns a list of alternatives, any one of which is sufficient to -- satisfy the given consequent. -- bwdApplyRestriction :: ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph -> [[RDFGraph]] bwdApplyRestriction restriction cls props cs congr = fromMaybe [[falseGraph]] newgrs where -- Instances of the named class in the graph: ris = rdfFindValSubj resRdfType cls congr -- Apply class restriction to single instance of the restricted class newgr :: RDFLabel -> Maybe [[RDFGraph]] newgr ri = bwdApplyRestriction1 restriction cls ri props cs congr -- 'map newgr ris' is conjunction of disjunctions, where -- each disjunction is itself a conjunction of conjunctions. -- 'sequence' distributes the conjunction over the disjunction, -- yielding an equivalent disjunction of conjunctions -- map concat flattens the conjunctions of conjuctions newgrs :: Maybe [[RDFGraph]] newgrs = map concat . sequence <$> mapM newgr ris -- Backward apply a class restriction to single class instance (ci). -- Return one or more sets of antecedent results from which the consequence -- can be derived in the defined relation, an empty list if the supplied -- consequence cannot be inferred, or Nothing if the consequence is -- inconsistent with the restriction. bwdApplyRestriction1 :: ClassRestriction -> RDFLabel -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph -> Maybe [[RDFGraph]] bwdApplyRestriction1 restriction cls ci props cs congr = if grConsistent then Just grss else Nothing where -- Apply restriction to graph (grConsistent,pvs,cts,_) = applyRestriction restriction ci props cs congr -- Build list of all full tuples consistent with the values supplied fts :: [[RDFLabel]] fts = concatMap snd cts -- Construct partial tuples from members of fts from which at least -- one of the supplied values can be derived pts :: [([Maybe RDFLabel],[RDFLabel])] pts = concatMap (deriveTuple restriction) fts -- Select combinations of members of pts from which all the -- supplied values can be derived dtss :: [[[Maybe RDFLabel]]] dtss = coverSets pvs pts -- Filter members of dtss that fully cover the values -- obtained from the consequence graph. ftss :: [[[Maybe RDFLabel]]] ftss = filter (not . (\t -> coversVals deleteMaybe t pvs)) dtss -- Make new graphs for all alternatives grss :: [[RDFGraph]] grss = map ( makeGraphs . newArcs ) ftss -- Collect arcs for one alternative newArcs dts = [ Arc ci p v | mvs <- dts, (p,Just v) <- zip props mvs ] -- Make graphs for one alternative -- TODO: convert to sets makeGraphs = map (toRDFGraph . S.fromList . (:[])) . (Arc ci resRdfType cls :) -- Helper function to select sub-tuples from which some of a set of -- values can be derived using a class restriction. -- -- restriction is the restriction being evaluated. -- ft is a full tuple of values known to be consistent with -- the restriction -- -- The result returned is a list of pairs, whose first member is a partial -- tuples from which the full tuple supplied can be derived, and the second -- is the supplied tuple calculated from that input. -- deriveTuple :: ClassRestriction -> [RDFLabel] -> [([Maybe RDFLabel], [RDFLabel])] deriveTuple restriction ft = map (tosnd ft) $ minima partCompareListMaybe $ filter derives partials where partials = mapM (\x -> [Nothing, Just x]) ft derives = ([ft] ==) . fromJust . crFunc restriction tosnd = flip (,) -- Helper function to apply a restriction to selected information from -- a supplied graph, and returns a tuple containing: -- (a) an indication of whether the graph is consistent with the -- restriction -- (b) a list of values specified in the graph for each property -- (c) a complete list of tuples that use combinations of values from -- the graph and are consistent with the restriction. -- Each member is a pair consisting of some combination of input -- values, and a list of complete tuple values that can be -- calculated from those inputs, or an empty list if there is -- insufficient information. -- (d) a set of tuples that are consistent with the restriction and use -- as much information from the graph as possible. This set is -- minimal in the sense that they must all correspond to different -- complete input tuples satisfying the restriction. -- -- This function factors out logic that is common to forward and -- backward chaining of a class restriction. -- -- restriction is the class restriction being applied -- ci is the identifier of a graph node to be tested -- props is a list of properties of the graph noode whose values -- are constrained by the class restriction. -- cs is a list of max cardinality constraints on the restriction, -- the minimum of which is used as the cardinality constraint -- on the restriction. If the list is null, no cardinality -- constraint is applied. -- gr is the graph from which property values are extracted. -- applyRestriction :: ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph -> ( Bool , [[RDFLabel]] , [([Maybe RDFLabel],[[RDFLabel]])] , [[Maybe RDFLabel]] ) applyRestriction restriction ci props cs gr = (coversVals deleteMaybe sts pvs && cardinalityOK, pvs, cts, sts ) where -- Extract from the antecedent graph all specified values of the -- restricted properties (constructs inner list for each property) pvs :: [[RDFLabel]] pvs = [ rdfFindPredVal ci p gr | p <- props ] -- Convert tuple of alternatives to list of alternative tuples -- (Each tuple is an inner list) pts :: [[Maybe RDFLabel]] pts = mapM allJustAndNothing pvs -- Try class restriction calculation for each tuple -- For each, result may be: -- Nothing (inconsistent) -- Just [] (underspecified) -- Just [t] (single tuple of values derived from given values) -- Just ts (alternative tuples derived from given values) rts :: [Maybe [[RDFLabel]]] rts = map (crFunc restriction) pts -- Extract list of consistent tuples of given values cts :: [([Maybe RDFLabel],[[RDFLabel]])] cts = mapMaybe tupleConv (zip pts rts) -- TODO: be more idiomatic? tupleConv :: (a, Maybe b) -> Maybe (a,b) tupleConv (a, Just b) = Just (a,b) tupleConv _ = Nothing -- Build list of consistent tuples with maximum information -- based on that supplied and available -- mts = concatMap mostValues cts mts = map mostOneValue cts -- Eliminate consistent results subsumed by others. -- This results in a mimimal possible set of consistent inputs, -- because if any pair could be consistently unified then their -- common subsumer would still be in the list, and both would be -- thereby eliminated. sts :: [[Maybe RDFLabel]] sts = maxima partCompareListMaybe mts -- Check the cardinality constraint cardinalityOK = null cs || length sts <= minimum cs -- Map a non-empty list of values to a list of Just values, -- preceding each with a Nothing element. -- -- Nothing corresponds to an unknown value. This logic is used -- as part of constructing a list of alternative tuples of known -- data values (either supplied or calculated from the class -- restriction). -- allJustAndNothing :: [a] -> [Maybe a] allJustAndNothing as = Nothing:map Just as {- -- Get maximum information about possible tuple values from a -- given pair of input tuple, which is known to be consistent with -- the restriction, and calculated result tuples. Where the result -- tuple is not exactly calculated, return the input tuple. -- -- imvs tuple of Maybe element values, with Nothing for -- unspecified values -- movss Maybe list of possible fully-specified result tuples, -- an empty list if no result tuples can be computed -- based on the input tuple, or Nothing if the input -- tuple is inconsistent. -- mostValues :: ([Maybe a],[[a]]) -> [[Maybe a]] mostValues (imvs,([])) = [imvs] mostValues (_,movss) = map (map Just) movss -} -- Get maximum information about possible tuple values from a -- given pair of input and possible result tuples, which is -- known to be consistent with the restriction. If the result -- tuple is not exactly calculated, return the input tuple. -- -- This is a variant of mostValues that returns a single vector. -- Multiple possible values are considered to be equivalent to -- Just [], i.e. unknown result. -- -- imvs tuple of Maybe element values, with Nothing for -- unspecified values -- movss Maybe list of possible fully-specified result tuples, -- or an empty list if no result tuples can be computed -- based on the input tuple. -- mostOneValue :: ([Maybe a],[[a]]) -> [Maybe a] mostOneValue (_,[movs]) = map Just movs mostOneValue (imvs,_) = imvs -- Helper function that returns subsets of dts that "cover" the indicated -- values; i.e. from which all of the supplied values can be deduced -- by the enumerated function results. The minima of all such subsets is -- returned, as each of these corresponds to some minimum information needed -- to deduce all of the given values. -- -- pvs is a list of lists of values to be covered. The inner list -- contains multiple values for each member of a tuple. -- dts is an enumerated list of function values from some subset of -- the tuple space to complete tuples. Each member is a pair -- containing the partial tuple (using Nothing for unspecified -- values) and the full tuple calculated from it. -- -- The return value is a disjunction of conjunctions of partial tuples -- that cover the indicated parameter values. -- -- NOTE: -- The result minimization is not perfect (cf. test2 below), but I believe -- it is adequate for the practical situations I envisage, and in any -- case will not result in incorrect values. It's significance is for -- search-tree pruning. A perfect minimization might be achieved by -- using a more subtle partial ordering that takes account of both subsets -- and the partial ordering of set members in place of 'partCompareListSubset'. -- coverSets :: (Eq a) => [[a]] -> [([Maybe a],[a])] -> [[[Maybe a]]] coverSets pvs dts = minima partCompareListSubset $ map (map fst) ctss where ctss = filter coverspvs $ tail $ subsequences cts cts = minima (partComparePair partCompareListMaybe partCompareEq) dts coverspvs cs = coversVals delete (map snd cs) pvs -- Does a supplied list of tuples cover a list of possible alternative -- values for each tuple member? -- coversVals :: (a->[b]->[b]) -> [[a]] -> [[b]] -> Bool coversVals dropVal ts vss = -- all null (foldr dropUsed vss ts) any (all null) (scanr dropUsed vss ts) where -- Remove single tuple values from the list of supplied values: dropUsed [] [] = [] dropUsed (a:as) (bs:bss) = dropVal a bs : dropUsed as bss dropUsed _ _ = error "coversVals.dropUsed: list length mismatch" {- -- Does a supplied list of possible alternative values for each -- element of a tuple cover every tuple in a supplied list? -- -- (See module spike-coverVals.hs for test cases) -- coversAll :: ([a]->b->Bool) -> [[a]] -> [[b]] -> Bool coversAll matchElem vss ts = all (invss vss) ts where -- Test if a given tuple is covered by vss invss vss t = and $ zipWith matchElem vss t -- Test if the value in a Maybe is contained in a list. maybeElem :: (Eq a) => Maybe a -> [a] -> Bool maybeElem Nothing = const True maybeElem (Just t) = elem t -} -- |Delete a Maybe value from a list deleteMaybe :: (Eq a) => Maybe a -> [a] -> [a] deleteMaybe Nothing as = as deleteMaybe (Just a) as = delete a as -- | Make restriction rules from the supplied datatype and graph. makeRDFDatatypeRestrictionRules :: RDFDatatypeVal vt -> RDFGraph -> [RDFRule] makeRDFDatatypeRestrictionRules dtval = makeRDFClassRestrictionRules dcrs where dcrs = map (makeDatatypeRestriction dtval) (tvalRel dtval) -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2018, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype.hs0000644000000000000000000001573213543702315015676 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Datatype -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2018 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 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 = fmap (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, 2018 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/Decimal.hs0000644000000000000000000004016114220136201017650 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# 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, 2014, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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 ) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif 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, 2014, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/Integer.hs0000644000000000000000000004252114220136201017711 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Integer -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014, 2018, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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.Maybe (maybeToList) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif 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, [ (fmap (:[]) `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] = [q | r == 0] 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, 2014, 2018, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/MapDecimal.hs0000644000000000000000000000525413543702315020326 0ustar0000000000000000{-# 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/MapInteger.hs0000644000000000000000000000511113543702315020355 0ustar0000000000000000{-# 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Datatype/XSD/String.hs0000644000000000000000000002375013543702315017601 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : String -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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 ) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid(Monoid(..)) #endif 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Formatter/NTriples.hs0000644000000000000000000001466013767237337017644 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : NTriples -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2015, 2020 Doug Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This Module implements a NTriples formatter for a 'RDFGraph'. -- -- REFERENCES: -- -- - \"RDF Test Cases\", -- W3C Recommendation 10 February 2004, -- -- -- NOTES: -- -- - Update to the document \"N-Triples. A line-based syntax for an RDF graph\" -- W3C Working Group Note 09 April 2013, -- -- -------------------------------------------------------------------------------- module Swish.RDF.Formatter.NTriples ( formatGraphAsText , formatGraphAsLazyText , formatGraphAsBuilder ) where import Swish.RDF.Formatter.Internal ( NodeGenState(..) , SLens (..) , emptyNgs , mapBlankNode_ ) 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 Data.Char (ord, intToDigit, toUpper) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid import Control.Applicative ((<$>)) #endif -- import Prelude -- 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.Set as S 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. type Formatter a = State NodeGenState a _nodeGen :: SLens NodeGenState NodeGenState _nodeGen = SLens id $ const id -- | 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 = evalState (formatGraph gr) emptyNgs ---------------------------------------------------------------------- -- Formatting as a monad-based computation ---------------------------------------------------------------------- formatGraph :: RDFGraph -> Formatter B.Builder formatGraph gr = mconcat <$> mapM formatArc (S.toList (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] 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, "@", B.fromText (fromLangTag lang)] formatLabel (TypedLit lit dt) = return $ mconcat [quoteText lit, "^^", 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 = mapBlankNode_ _nodeGen -- TODO: can we use Network.URI to protect the URI? showScopedName :: ScopedName -> B.Builder 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 ["\"", B.fromText (quote st), "\""] {- 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, 2013, 2014, 2015, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Formatter/N3.hs0000644000000000000000000004023314163107250016334 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : N3 -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2020, 2021 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.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree , SLens(..) , LabelContext(..) , NodeGenState(..) , changeState , hasMore , emptyNgs , findMaxBnode , processArcs , quoteB , formatScopedName , formatPlainLit , formatLangLit , formatTypedLit , insertList , nextLine_ , mapBlankNode_ , formatPrefixes_ , formatGraph_ , formatSubjects_ , formatProperties_ , formatObjects_ , insertBnode_ , extractList_ ) import Swish.Namespace (ScopedName) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..), NamespaceMap, emptyNamespaceMap, FormulaMap, emptyFormulaMap, setNamespaces, getNamespaces, getFormulae, emptyRDFGraph ) import Swish.RDF.Vocabulary ( rdfType, rdfNil, owlSameAs, logImplies ) import Control.Monad (void) import Control.Monad.State (State, modify, get, gets, put, runState) import Data.Char (isDigit) import Data.List (uncons) import Data.Word (Word32) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif -- 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.Map as M 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 ---------------------------------------------------------------------- -- -- 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). 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)] , prefixes :: NamespaceMap , nodeGenSt :: NodeGenState , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format , traceBuf :: [String] } type SL a = SLens N3FormatterState a _lineBreak :: SL Bool _lineBreak = SLens lineBreak $ \a b -> a { lineBreak = b } _nodeGen :: SL NodeGenState _nodeGen = SLens nodeGenSt $ \a b -> a { nodeGenSt = b } type Formatter a = State N3FormatterState a updateState :: N3FormatterState -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> N3FormatterState updateState ost nsubjs nprops nobjs = ost { subjs = nsubjs, props = nprops, objs = nobjs } emptyN3FS :: NamespaceMap -> NodeGenState -> N3FormatterState emptyN3FS pmap ngs = N3FS { indent = "\n" , lineBreak = False , graph = emptyRDFGraph , subjs = [] , props = [] , objs = [] , formAvail = emptyFormulaMap , formQueue = [] , prefixes = pmap , nodeGenSt = ngs , bNodesCheck = [] , traceBuf = [] } setIndent :: B.Builder -> Formatter () setIndent ind = modify $ \st -> st { indent = ind } setLineBreak :: Bool -> Formatter () setLineBreak brk = modify $ \st -> st { lineBreak = brk } setSubjs :: SubjTree RDFLabel -> Formatter () setSubjs sl = modify $ \st -> st { subjs = sl } setProps :: PredTree RDFLabel -> Formatter () setProps ps = modify $ \st -> st { props = ps } {- getObjs :: Formatter ([RDFLabel]) getObjs = objs `fmap` get setObjs :: [RDFLabel] -> Formatter () setObjs os = do st <- get put $ st { objs = os } -} {- 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 = M.delete fn fa, formQueue = (fn,fv) : formQueue st } case M.lookup 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 (rval, nform) = M.updateLookupWithKey (\_ _ -> Nothing) fn $ formAvail st put $ st { formAvail = nform } return rval {- 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 -} {- TODO: Should we change the preds/objs entries as well? -} extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) extractList = extractList_ subjs props setSubjs setProps ---------------------------------------------------------------------- -- 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 { nodeGen = findMaxBnode gr } (out, fgs) = runState fg (emptyN3FS emptyNamespaceMap 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 = formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects formatPrefixes :: NamespaceMap -> Formatter B.Builder formatPrefixes = formatPrefixes_ nextLine formatSubjects :: Formatter B.Builder formatSubjects = formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder formatProperties = formatProperties_ nextProperty formatLabel formatObjects props nextLine formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder formatObjects = formatObjects_ nextObject formatLabel objs nextLine insertFormula :: RDFGraph -> Formatter B.Builder insertFormula gr = do pmap0 <- gets prefixes ngs0 <- gets nodeGenSt ind <- gets indent let grm = formatGraph (ind `mappend` " ") "" True False (setNamespaces emptyNamespaceMap gr) (f3str, fgs') = runState grm (emptyN3FS pmap0 ngs0) modify $ \st -> st { nodeGenSt = nodeGenSt fgs' , prefixes = prefixes fgs' } f4str <- nextLine " } " return $ mconcat [" { ",f3str, f4str] {- Add a blank node inline. -} insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder insertBnode SubjContext lbl = do flag <- hasMore props txt <- if flag then (`mappend` "\n") `fmap` formatProperties lbl "" else return "" -- TODO: handle indentation? return $ mconcat ["[", txt, "]"] insertBnode _ lbl = insertBnode_ subjs props objs updateState formatProperties lbl ---------------------------------------------------------------------- -- Formatting helpers ---------------------------------------------------------------------- newState :: RDFGraph -> N3FormatterState -> N3FormatterState newState gr st = let pre' = prefixes st `M.union` getNamespaces gr (arcSubjs, bNodes) = processArcs gr in st { graph = gr , subjs = arcSubjs , props = [] , objs = [] , formAvail = getFormulae gr , prefixes = pre' , bNodesCheck = bNodes } -- A version of uncons for a list which is not empty but we haven't -- encoded that invariant. -- getNext :: [a] -> (a, [a]) getNext xs = case uncons xs of Just (a, as) -> (a, as) Nothing -> error "Invariant broken: list is empty" nextSubject :: Formatter RDFLabel nextSubject = changeState $ \st -> let ((a,b), sbs) = getNext (subjs st) nst = st { subjs = sbs , props = b , objs = [] } in (a, nst) nextProperty :: RDFLabel -> Formatter RDFLabel nextProperty _ = changeState $ \st -> let ((a,b), prs) = getNext (props st) nst = st { props = prs , objs = b } in (a, nst) nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel nextObject _ _ = changeState $ \st -> let (ob, obs) = getNext (objs st) nst = st { objs = obs } in (ob, nst) nextLine :: B.Builder -> Formatter B.Builder nextLine = nextLine_ indent _lineBreak -- 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. TODO: look at the (_:_) check on the blank string; why is this needed? -} formatLabel lctxt lab@(Blank (_:_)) = do mlst <- extractList lctxt lab case mlst of Just lst -> insertList (formatLabel ObjContext) lst Nothing -> do mfml <- extractFormula lab case mfml of Just fml -> insertFormula fml Nothing -> do nb1 <- gets bNodesCheck 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 <- gets prefixes queueFormula lab return $ formatScopedName sn pr formatLabel _ (Lit lit) = return $ formatPlainLit lit formatLabel _ (LangLit lit lcode) = return $ formatLangLit lit lcode formatLabel _ (TypedLit lit dtype) = return $ formatTypedLit True lit dtype formatLabel _ lab = return $ B.fromString $ show lab 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 = mapBlankNode_ _nodeGen -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2020, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Formatter/Turtle.hs0000644000000000000000000003400114163107250017327 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Turtle -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2018, 2019, 2020, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This Module implements a Turtle formatter -- for an 'RDFGraph' value. -- -- REFERENCES: -- -- - \"Turtle, Terse RDF Triple Language\", -- W3C Working Draft 09 August 2011 () -- -- -- NOTES: -- -- - The formatter needs to be updated to the W3C -- Candidate Recommendation (19 February 2013, -- ). -- -- - Should literal strings (@Lit@) be written out as @xsd:string@, or -- should @TypedLit@ strings with a type of @xsd:string@ be written -- out with no type? (e.g. see -- ). -- -------------------------------------------------------------------------------- {- 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 ) where import Swish.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree , SLens(..) , LabelContext(..) , NodeGenState(..) , changeState , hasMore , emptyNgs , findMaxBnode , processArcs , formatScopedName , formatPlainLit , formatLangLit , formatTypedLit , insertList , nextLine_ , mapBlankNode_ , formatPrefixes_ , formatGraph_ , formatSubjects_ , formatProperties_ , formatObjects_ , insertBnode_ , extractList_ ) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) , NamespaceMap , emptyNamespaceMap , getNamespaces , emptyRDFGraph ) import Swish.RDF.Vocabulary (rdfType, rdfNil) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 808) import Control.Applicative ((<$>)) #endif import Control.Monad.State (State, modify, gets, runState) import Data.Char (isDigit) import Data.List (uncons) import Data.Word (Word32) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif -- 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.Map as M 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 ---------------------------------------------------------------------- -- -- 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). 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)] , prefixes :: NamespaceMap , nodeGenSt :: NodeGenState , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format , traceBuf :: [String] } type SL a = SLens TurtleFormatterState a _lineBreak :: SL Bool _lineBreak = SLens lineBreak $ \a b -> a { lineBreak = b } _nodeGen :: SL NodeGenState _nodeGen = SLens nodeGenSt $ \a b -> a { nodeGenSt = b } type Formatter a = State TurtleFormatterState a updateState :: TurtleFormatterState -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> TurtleFormatterState updateState ost nsubjs nprops nobjs = ost { subjs = nsubjs, props = nprops, objs = nobjs } emptyTFS :: NodeGenState -> TurtleFormatterState emptyTFS ngs = TFS { indent = "\n" , lineBreak = False , graph = emptyRDFGraph , subjs = [] , props = [] , objs = [] , prefixes = emptyNamespaceMap , nodeGenSt = ngs , bNodesCheck = [] , traceBuf = [] } setIndent :: B.Builder -> Formatter () setIndent ind = modify $ \st -> st { indent = ind } setLineBreak :: Bool -> Formatter () setLineBreak brk = modify $ \st -> st { lineBreak = brk } setSubjs :: SubjTree RDFLabel -> Formatter () setSubjs sl = modify $ \st -> st { subjs = sl } setProps :: PredTree RDFLabel -> Formatter () setProps ps = modify $ \st -> st { props = ps } {- TODO: Should we change the preds/objs entries as well? -} extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) extractList = extractList_ subjs props setSubjs setProps ---------------------------------------------------------------------- -- 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 { 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 = formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects formatPrefixes :: NamespaceMap -> Formatter B.Builder formatPrefixes = formatPrefixes_ nextLine formatSubjects :: Formatter B.Builder formatSubjects = formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder formatProperties = formatProperties_ nextProperty formatLabel formatObjects props nextLine formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder formatObjects = formatObjects_ nextObject formatLabel objs nextLine {- Add a blank node inline. -} insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder insertBnode SubjContext lbl = do -- a safety check flag <- hasMore props if flag then do txt <- (`mappend` "\n") `fmap` formatProperties lbl "" return $ mconcat ["[] ", txt] else error $ "Internal error: expected properties with label: " ++ show lbl insertBnode _ lbl = insertBnode_ subjs props objs updateState formatProperties lbl ---------------------------------------------------------------------- -- Formatting helpers ---------------------------------------------------------------------- newState :: RDFGraph -> TurtleFormatterState -> TurtleFormatterState newState gr st = let pre' = prefixes st `M.union` getNamespaces gr (arcSubjs, bNodes) = processArcs gr in st { graph = gr , subjs = arcSubjs , props = [] , objs = [] , prefixes = pre' , bNodesCheck = bNodes } -- A version of uncons for a list which is not empty but we haven't -- encoded that invariant. -- getNext :: [a] -> (a, [a]) getNext xs = case uncons xs of Just (a, as) -> (a, as) Nothing -> error "Invariant broken: list is empty" nextSubject :: Formatter RDFLabel nextSubject = changeState $ \st -> let ((a,b), sbs) = getNext (subjs st) nst = st { subjs = sbs , props = b , objs = [] } in (a, nst) nextProperty :: RDFLabel -> Formatter RDFLabel nextProperty _ = changeState $ \st -> let ((a,b), prs) = getNext (props st) nst = st { props = prs , objs = b } in (a, nst) nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel nextObject _ _ = changeState $ \st -> let (ob, obs) = getNext (objs st) nst = st { objs = obs } in (ob, nst) nextLine :: B.Builder -> Formatter B.Builder nextLine = nextLine_ indent _lineBreak -- 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/string -- literals. -- -- 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. TODO: why is there a (_:_) check on the blank node? -} formatLabel lctxt lab@(Blank (_:_)) = do mlst <- extractList lctxt lab case mlst of Just lst -> insertList (formatLabel ObjContext) 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 <- gets bNodesCheck 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 = gets (formatScopedName sn . prefixes) formatLabel _ (Lit lit) = return $ formatPlainLit lit formatLabel _ (LangLit lit lcode) = return $ formatLangLit lit lcode formatLabel _ (TypedLit lit dtype) = return $ formatTypedLit False lit dtype formatLabel _ lab = return $ B.fromString $ show lab 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 = mapBlankNode_ _nodeGen -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2018, 2019, 2020, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Graph.hs0000644000000000000000000015543414220136201015154 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Graph -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2015, 2016, 2018, 2020. 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, FlexibleInstances, MultiParamTypeClasses, OverloadedStrings -- -- This module defines a memory-based RDF graph instance. At present only -- RDF 1.0 is explicitly supported; I have not gone through the RDF 1.1 -- changes to see how the code needs to be updated. This means that you -- can have untyped strings in your graph that do not match the same content -- but with an explicit @xsd:string@ datatype. -- -- Note that the identifiers for blank nodes may /not/ be propogated when -- a graph is written out using one of the formatters, such as -- 'Swish.RDF.Formatter.Turtle'. There is limited support for -- generating new blank nodes from an existing set of triples; e.g. -- 'newNode' and 'newNodes'. -- -------------------------------------------------------------------------------- ------------------------------------------------------------ -- 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 , RDFArcSet , RDFTriple , toRDFTriple, fromRDFTriple , NSGraph(..) , RDFGraph , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} , NamespaceMap , emptyNamespaceMap , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap , addArc, merge , allLabels, allNodes, remapLabels, remapLabelList , newNode, newNodes , setNamespaces, getNamespaces , setFormulae, getFormulae, setFormula, getFormula , fmapNSGraph , traverseNSGraph -- * 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 ( getNamespaceTuple , getScopedNameURI , ScopedName , getScopeLocal, getScopeNamespace , getQName , makeQNameScopedName , makeURIScopedName , nullScopedName ) import Swish.RDF.Vocabulary (LanguageTag) import Swish.RDF.Vocabulary (fromLangTag, xsdBoolean, xsdDate, xsdDateTime, xsdDecimal, xsdDouble, xsdFloat, xsdInteger , rdfType, rdfList, rdfFirst, rdfRest, rdfNil , rdfsMember, rdfdGeneralRestriction, rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality , rdfsSeeAlso, rdfValue, rdfsLabel, rdfsComment, rdfProperty , rdfsSubPropertyOf, rdfsSubClassOf, rdfsClass, rdfsLiteral , rdfsDatatype, rdfXMLLiteral, rdfsRange, rdfsDomain, rdfsContainer , rdfBag, rdfSeq, rdfAlt , rdfsContainerMembershipProperty, rdfsIsDefinedBy , rdfsResource, rdfStatement, rdfSubject, rdfPredicate, rdfObject , rdfRDF, rdfDescription, rdfID, rdfAbout, rdfParseType , rdfResource, rdfLi, rdfNodeID, rdfDatatype, rdfXMLLiteral , rdf1, rdf2, rdfn , owlSameAs, logImplies, namespaceRDF ) import Swish.GraphClass (LDGraph(..), Label (..), Arc(..), ArcSet, Selector) import Swish.GraphClass (arc, arcLabels, getComponents) import Swish.GraphMatch (LabelMap, ScopedLabel(..)) import Swish.GraphMatch (graphMatch) import Swish.QName (QName, getLName) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Control.Applicative (Applicative(pure), (<$>), (<*>)) import Data.Monoid (Monoid(..)) #endif import Control.Arrow ((***)) import Network.URI (URI) import Data.Maybe (mapMaybe) import Data.Char (ord, isDigit) import Data.Hashable (hashWithSalt) import Data.List (intersect, union, foldl') -- import Data.Ord (comparing) import Data.Word (Word32) import Data.String (IsString(..)) #if MIN_VERSION_time(1,5,0) import Data.Time (UTCTime, Day, ParseTime, parseTimeM, formatTime, defaultTimeLocale) #else import Data.Time (UTCTime, Day, ParseTime, parseTime, formatTime) import System.Locale (defaultTimeLocale) #endif #if !(MIN_VERSION_base(4, 11, 0)) import Data.Semigroup #endif import Text.Printf import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Read as T import qualified Data.Traversable as Traversable -- | RDF graph node values -- -- cf. version 1.0 -- -- 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 -- Order, from lowest to highest is -- Res, Lit, LangLit, TypedLit, Blank, Var, NoNode -- compare (Res sn1) (Res sn2) = compare sn1 sn2 compare (Res _) _ = LT compare _ (Res _) = GT compare (Lit s1) (Lit s2) = compare s1 s2 compare (Lit _) _ = LT compare _ (Lit _) = GT compare (LangLit s1 l1) (LangLit s2 l2) = compare (s1,l1) (s2,l2) compare (LangLit _ _) _ = LT compare _ (LangLit _ _) = GT compare (TypedLit s1 t1) (TypedLit s2 t2) = compare (s1,t1) (s2,t2) compare (TypedLit _ _) _ = LT compare _ (TypedLit _ _) = GT compare (Blank ln1) (Blank ln2) = compare ln1 ln2 compare (Blank _) _ = LT compare _ (Blank _) = GT compare (Var ln1) (Var ln2) = compare ln1 ln2 compare (Var _) NoNode = LT compare _ (Var _) = GT compare NoNode NoNode = EQ 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@. instance FromRDFLabel RDFLabel where fromRDFLabel = Just -- 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" #if MIN_VERSION_time(1,5,0) pt f = parseTimeM True defaultTimeLocale f inVal #else pt f = parseTime defaultTimeLocale f inVal #endif 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 -- The Data.Text API points out issues with processing a text -- character-by-character, but it's not clear to me how to avoid -- that here. -- -- One assumption would be that the strings aren't likely to be large, -- so that several calls to T.find or similar could be made to -- simplify certain cases. -- -- Is it worth scanning through the text to look for characters like \n -- or #, or to look for sequences like '##'? -- Is it worth sending in a flag to indicate the different modes for -- handling \n characters, or just leave this complexity in 'quoteT False'? -- processChar :: Char -> (T.Text, Bool) -- ^ the boolean is @True@ if the returned text has been -- expanded so that it begins with @\\@ processChar '"' = ("\\\"", True) processChar '\\' = ("\\\\", True) processChar '\n' = ("\\n", True) processChar '\r' = ("\\r", True) processChar '\t' = ("\\t", True) processChar '\b' = ("\\b", True) -- processChar '\f' = ("\\f", True) -- Using the above I get invalid output according to -- rapper version 2.0.9, so use the following for now -- (changed at version 0.9.0.6) processChar '\f' = ("\\u000C", True) -- processChar c = let nc = ord c -- lazy ways to convert to hex-encoded strings four = T.append "\\u" . T.pack $ printf "%04X" nc eight = T.append "\\U" . T.pack $ printf "%08X" nc in if nc < 0x20 then (four, True) else if nc < 0x7f then (T.singleton c, False) else if nc < 0x10000 then (four, True) else (eight, True) convertChar :: Char -> T.Text convertChar = fst . processChar -- | See `quote`. quoteT :: Bool -> T.Text -> T.Text quoteT True txt = -- Output is to be used as "..." let go dl x = case T.uncons x of Just (c, xs) -> go (dl . T.append (convertChar c)) xs _ -> dl T.empty in go (T.append T.empty) txt -- One complexity here is my reading of the Turtle grammar -- STRING_LITERAL_LONG_QUOTE ::= '"""' (('"' | '""')? [^"\] | ECHAR | UCHAR)* '"""' -- which says that any un-protected double-quote characters can not -- be followed by a \ character. One option would be to always use the -- 'quoteT True' behavior. -- quoteT _ txt = -- Output is to be used as """..."""" let go dl x = case T.uncons x of Just ('"', xs) -> go1 dl xs Just ('\n', xs) -> go (dl . T.cons '\n') xs Just (c, xs) -> go (dl . T.append (convertChar c)) xs _ -> dl T.empty -- Seen one double quote go1 dl x = case T.uncons x of Just ('"', xs) -> go2 dl xs Just ('\n', xs) -> go (dl . T.append "\"\n") xs Just ('\\', xs) -> go (dl . T.append "\\\"\\\\") xs Just (c, xs) -> let (t, f) = processChar c dl' = if f then T.append "\\\"" else T.cons '"' in go (dl . dl' . T.append t) xs _ -> dl "\\\"" -- Seen two double quotes go2 dl x = case T.uncons x of Just ('"', xs) -> go (dl . T.append "\\\"\\\"\\\"") xs Just ('\n', xs) -> go (dl . T.append "\"\"\n") xs Just ('\\', xs) -> go (dl . T.append "\\\"\\\"\\\\") xs Just (c, xs) -> let (t, f) = processChar c dl' = T.append (if f then "\\\"\\\"" else "\"\"") in go (dl . dl' . T.append t) xs _ -> dl "\\\"\\\"" -- at the start of the string we have 3 quotes, so any -- starting quote characters must be quoted. go0 dl x = case T.uncons x of Just ('"', xs) -> go0 (dl . T.append "\\\"") xs Just ('\n', xs) -> go (dl . T.cons '\n') xs Just (c, xs) -> go (dl . T.append (convertChar c)) xs _ -> dl T.empty in go0 (T.append T.empty) txt -- | Turtle-style quoting rules for a string. -- -- At present the choice is between using one or three -- double quote (@\"@) characters to surround the string; i.e. using -- single quote (@'@) characters is not supported. -- -- As of Swish 0.9.0.6, the @\\f@ character is converted to -- @\\u000C@ rather than left as is to aid interoperability -- with some other tools. -- quote :: Bool -- ^ @True@ if the string is to be displayed using one rather than three quotes. -> String -- ^ String to quote. -> String -- ^ The string does /not/ contain the surrounding quote marks. quote f = T.unpack . quoteT f . T.pack {- 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 a single double-quote mark at each end, -- e.g. "...". quote1Str :: T.Text -> String quote1Str t = '"' : T.unpack (quoteT True 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 -- | A set of RDF triples. type RDFArcSet = ArcSet 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 map for name spaces (key is the prefix). type NamespaceMap = M.Map (Maybe T.Text) URI -- TODO: should val be URI or namespace? -- | Create an empty namespace map. emptyNamespaceMap :: NamespaceMap emptyNamespaceMap = M.empty -- | 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 (Ord lb, Ord gr) => Ord (LookupFormula lb gr) where (Formula a1 b1) `compare` (Formula a2 b2) = (a1,b1) `compare` (a2,b2) -- | A named formula. type Formula lb = LookupFormula lb (NSGraph lb) instance (Label lb) => Show (Formula lb) where show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" -- | A map for named formulae. type FormulaMap lb = M.Map lb (NSGraph lb) -- | Create an empty formula map. emptyFormulaMap :: FormulaMap RDFLabel emptyFormulaMap = M.empty -- fmapFormulaMap :: (Ord a, Ord b) => (a -> b) -> FormulaMap a -> FormulaMap b fmapFormulaMap :: (Ord a) => (a -> a) -> FormulaMap a -> FormulaMap a fmapFormulaMap f m = M.fromList $ map (f *** fmapNSGraph f) $ M.assocs m -- TODO: how to traverse formulamaps now? {- traverseFormulaMap :: (Applicative f, Ord a, Ord b) => (a -> f b) -> FormulaMap a -> f (FormulaMap b) -} traverseFormulaMap :: (Applicative f, Ord a) => (a -> f a) -> FormulaMap a -> f (FormulaMap a) traverseFormulaMap f = Traversable.traverse (traverseFormula f) {- traverseFormula :: (Applicative f, Ord a, Ord b) => (a -> f b) -> Formula a -> f (Formula b) -} {- traverseFormula :: (Applicative f, Ord a) => (a -> f a) -> Formula a -> f (Formula a) traverseFormula f (Formula k gr) = Formula <$> f k <*> traverseNSGraph f gr -} traverseFormula :: (Applicative f, Ord a) => (a -> f a) -> NSGraph a -> f (NSGraph a) {- traverseFormula :: (Applicative f, Ord a, Ord b) => (a -> f b) -> NSGraph a -> f (NSGraph b) -} traverseFormula = traverseNSGraph {- 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 :: ArcSet lb -- ^ the statements in the graph } instance LDGraph NSGraph lb where emptyGraph = NSGraph emptyNamespaceMap M.empty S.empty getArcs = statements setArcs g as = g { statements=as } -- | The '<>' operation uses 'merge' rather than 'addGraphs'. instance (Label lb) => Semigroup (NSGraph lb) where (<>) = merge -- | The 'mappend' operation uses the Semigroup instance -- (so 'merge' rather than 'addGraphs'). instance (Label lb) => Monoid (NSGraph lb) where mempty = emptyGraph #if !(MIN_VERSION_base(4, 11, 0)) mappend = (<>) #endif -- fmapNSGraph :: (Ord lb1, Ord lb2) => (lb1 -> lb2) -> NSGraph lb1 -> NSGraph lb2 -- | 'fmap' for 'NSGraph' instances. fmapNSGraph :: (Ord lb) => (lb -> lb) -> NSGraph lb -> NSGraph lb fmapNSGraph f (NSGraph ns fml stmts) = NSGraph ns (fmapFormulaMap f fml) ((S.map $ fmap f) stmts) {- traverseNSGraph :: (Applicative f, Ord a, Ord b) => (a -> f b) -> NSGraph a -> f (NSGraph b) -} -- | 'Data.Traversable.traverse' for 'NSGraph' instances. traverseNSGraph :: (Applicative f, Ord a) => (a -> f a) -> NSGraph a -> f (NSGraph a) traverseNSGraph f (NSGraph ns fml stmts) = NSGraph ns <$> traverseFormulaMap f fml <*> (traverseSet $ Traversable.traverse f) stmts traverseSet :: (Applicative f, Ord b) => (a -> f b) -> S.Set a -> f (S.Set b) traverseSet f = S.foldr cons (pure S.empty) where cons x s = S.insert <$> f x <*> s instance (Label lb) => Eq (NSGraph lb) where (==) = grEq -- The namespaces are not used in the ordering since this could -- lead to identical graphs not being considered the same when -- ordering. -- instance (Label lb) => Ord (NSGraph lb) where (NSGraph _ fml1 stmts1) `compare` (NSGraph _ fml2 stmts2) = (fml1,stmts1) `compare` (fml2,stmts2) 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 = fmap formGraph $ M.lookup l (formulae g) getFormula g l = M.lookup l (formulae g) -- | Add (or replace) a formula. setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb -- setFormula f g = g { formulae = M.insert (formLabel f) f (formulae g) } setFormula (Formula fn fg) g = g { formulae = M.insert fn fg (formulae g) } {-| 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 = update (S.insert ar) 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 = concatMap ((pp ++) . show) fml fml = map (uncurry Formula) $ M.assocs (getFormulae g) -- NOTE: want to just show 'name :- graph' pp = "\n " ++ p showArcs :: (Label lb) => String -> NSGraph lb -> String showArcs p g = S.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 -- hmmm, if we compare the formula, rather then graph, -- a lot of tests fail (when the formulae are named by blank -- nodes). Presumably because the quality check for Formula forces -- the label to be identical, which it needn't be with bnodes -- for the match to hold. -- mapFormula g l = M.lookup l (getFormulae g) -- mapFormula g l = fmap formGraph $ M.lookup l (getFormulae g) -- the above discussion is hopefully moot now storing graph directly mapFormula g l = M.lookup 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 = S.toList $ allLabels labelIsVar gr1 bn2 = S.toList $ 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 -> S.Set lb allLabels p gr = S.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 -> S.Set lb allNodes p = unionNodes p S.empty . nodes -- | List all nodes in graph formulae satisfying a supplied predicate formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> S.Set lb formulaNodes p gr = foldl' (unionNodes p) fkeys (map (allLabels p) fvals) where fm = formulae gr -- fvals = map formGraph $ M.elems fm fvals = M.elems fm -- TODO: can this conversion be improved? fkeys = S.filter p $ S.fromList $ M.keys fm -- | Helper to filter variable nodes and merge with those found so far unionNodes :: (Label lb) => (lb -> Bool) -> S.Set lb -> S.Set lb -> S.Set lb unionNodes p ls1 ls2 = ls1 `S.union` S.filter p ls2 -- TODO: use S.Set lb rather than [lb] in the following -- |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 = fmapNSGraph (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 = M.findWithDefault nv nv $ M.fromList $ 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 -- TODO: optimize this for common case @nnn@ and @_nnn@: -- always generate @_nnn@ and keep track of last allocated -- -- |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.) -- 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 set 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 :: RDFArcSet -> RDFGraph toRDFGraph arcs = let lbls = getComponents arcLabels arcs getNS (Res s) = Just s getNS (TypedLit _ dt) = Just dt getNS _ = Nothing ns = mapMaybe (fmap getScopeNamespace . getNS) $ S.toList lbls nsmap = foldl' (\m ins -> let (p,u) = getNamespaceTuple ins in M.insertWith (const id) p u m) 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, 2013, 2014, 2015, 2016, 2018, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/GraphShowLines.hs0000644000000000000000000000436313767237337017035 0ustar0000000000000000{-# LANGUAGE FlexibleInstances #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphShowLines -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2020 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, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Parser/NTriples.hs0000644000000000000000000002664514066415574017135 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : NTriples -- Copyright : (c) 2011, 2012, 2013, 2018, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP -- -- 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, -- -- -- NOTES: -- -- - If the URI is actually an IRI (Internationalized Resource Identifiers) -- then the parser will fail since 'Network.URI.parseURI' fails. -- -- - The case of language tags is retained. -- -- - Update to the document \"N-Triples. A line-based syntax for an RDF graph\" -- W3C Working Group Note 09 April 2013, -- -- -------------------------------------------------------------------------------- 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) #if MIN_VERSION_base(4, 7, 0) import Data.Functor (($>)) #endif import Data.Maybe (fromMaybe) import Text.ParserCombinators.Poly.StateText #if !MIN_VERSION_base(4, 7, 0) ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif ---------------------------------------------------------------------- -- 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" :: String)) {- 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 isaZ, isaZ09 :: Char -> Bool isaZ c = isaz c || isAZ c isaZ09 c = isaZ c || is09 c isHeadChar, isBodyChar :: Char -> Bool isHeadChar = isaZ isBodyChar = isaZ09 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 = 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 below (from section 'URI References') The absoluteURI production encodes a Unicode string representing an RDF URI references as specified in [RDF-CONCEPTS]. These are encoded in N-Triples using the escapes described in section Strings. -} uriref :: NTParser ScopedName uriref = do ignore $ char '<' uri <- manyFinally' character (char '>') maybe (failBad ("Invalid URI: <" ++ uri ++ ">")) (return . makeURIScopedName) (parseURI uri) 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 '@' *> commit (Left <$> language)) <|> (string "^^" *> commit (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. -- -- Although the EBNF only lists [a-z] we also support upper case values, -- since the W3C Turtle test case includes a NTriples file with -- "...@en-UK" in it. -- language :: NTParser LanguageTag language = 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? {- 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' $> '\t') <|> (char 'n' $> '\n') <|> (char 'r' $> '\r') <|> (char '"' $> '"') <|> (char '\\' $> '\\') <|> (char 'u' *> hex4) <|> (char 'U' *> hex8) character :: NTParser Char character = (char '\\' *> protectedChar) <|> satisfy isAsciiChar -------------------------------------------------------------------------------- -- -- Copyright (c) 2011, 2012, 2013, 2018 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Parser/N3.hs0000644000000000000000000011050013767237337015643 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : N3 -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2018, 2020 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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: -- -- - The parser needs to be updated to the latest version -- (\"W3C Team Submission 28 March 2011\", -- ) -- -- - 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 , getNamespaceTuple , 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) #if MIN_VERSION_base(4, 7, 0) import Data.Functor (($>)) #endif import Data.Maybe (fromMaybe, fromJust) import Data.Word (Word32) import Network.URI (URI(..), parseURIReference) import Text.ParserCombinators.Poly.StateText import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L #if !MIN_VERSION_base(4, 7, 0) ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif ---------------------------------------------------------------------- -- 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' = M.insert pre uri (prefixUris st) -- | Set name for special syntax element setSName :: String -> ScopedName -> N3State -> N3State setSName nam snam st = st { syntaxUris=s' } where s' = M.insert 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 = M.findWithDefault 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 = M.lookup 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 = M.singleton Nothing hashURI muri = fmap (makeQNameScopedName Nothing) mbase smap = M.fromList $ 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 = M.fromList $ map getNamespaceTuple 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 (pkey, pval) = getNamespaceTuple $ getScopeNamespace snam opmap = prefixUris st rval = Res snam -- TODO: the lookup and the replacement could be fused case M.lookup pkey opmap of Just val | val == pval -> return rval | otherwise -> do stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval _ -> do stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } 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 (ns, uri) = getNamespaceTuple $ getScopeNamespace dtype newp = M.insert ns uri 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 = 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` ("-_"::String) || 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' $> '\t') <|> (char 'n' $> '\n') <|> (char 'r' $> '\r') <|> (char '"' $> '"') <|> (char '\'' $> '\'') <|> (char '\\' $> '\\') <|> (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 = T.pack <$> bracket sQuot sQuot (many n3Character) {- tripleQUoted ::= """[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""" The following may not match the output format we now create (with the move to the Turtle Candidate Recommendation), so re-writing as a test, but this means pulling in a lot of Turtle productions, which should be shared. tripleQuoted = tQuot *> fmap T.pack (manyTill (n3Character <|> sQuot <|> char '\n') tQuot) where -- tQuot = try (count 3 sQuot) tQuot = exactly 3 sQuot -} tripleQuoted :: N3Parser T.Text tripleQuoted = let sep = exactly 3 sQuot in T.concat <$> bracket sep sep (many _tCharsLong) {-- Turtle productions: start --} oneOrTwo :: N3Parser T.Text oneOrTwo = do ignore $ char '"' mb <- optional (char '"') case mb of Just _ -> return "\"\"" _ -> return "\"" _multiQuote :: N3Parser T.Text _multiQuote = do mq <- optional oneOrTwo r <- noneOf "\"\\" return $ fromMaybe T.empty mq `T.snoc` r _tCharsLong :: N3Parser T.Text _tCharsLong = T.singleton <$> _protChar <|> _multiQuote _protChar :: N3Parser Char _protChar = char '\\' *> (_echar' <|> _uchar') _echar' :: N3Parser Char _echar' = (char 't' $> '\t') <|> (char 'b' $> '\b') <|> (char 'n' $> '\n') <|> (char 'r' $> '\r') <|> (char 'f' $> '\f') <|> (char '\\' $> '\\') <|> (char '"' $> '"') <|> (char '\'' $> '\'') _uchar' :: N3Parser Char _uchar' = (char 'u' *> commit hex4) <|> (char 'U' *> commit hex8) {-- Turtle productions: end --} 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 ignore $ char '<' ustr <- manyFinally' ((satisfy isSpace *> next) <|> next) (char '>') case parseURIReference ustr of Nothing -> failBad $ "Invalid URI: <" ++ ustr ++ ">" 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 M.lookup (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) $> () {- 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 '!' $> addStatementRev forwardExpr = char '^' $> 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 $ const 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"::String)) <*> 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, 2013, 2014, 2018, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Parser/Turtle.hs0000644000000000000000000007476614220136201016636 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Turtle -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2018, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies, 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 Candidate Recommendation 19 February 2013 ( -- -- NOTES: -- -- - Prior to version @0.9.0.4@, the parser followed the -- W3C Working Draft 09 August 2011 () -- -- - Strings with no language tag are converted to a 'LitTag' not a -- 'TypedLitTag' with a type of @xsd:string@ (e.g. see -- ). -- -- - If the URI is actually an IRI (Internationalized Resource Identifiers) -- then the parser will fail since 'Network.URI.parseURI' fails. -- -- - The current (August 2013) Turtle test suite from -- passes except for the four -- tests with non-ASCII local names, namely: -- @localName_with_assigned_nfc_bmp_PN_CHARS_BASE_character_boundaries@, -- @localName_with_assigned_nfc_PN_CHARS_BASE_character_boundaries@, -- @localName_with_nfc_PN_CHARS_BASE_character_boundaries@, -- and -- @localName_with_non_leading_extras@. -- -------------------------------------------------------------------------------- -- TODO: -- - should the productions moved to an Internal module for use by -- others - e.g. Sparql or the N3 parser? module Swish.RDF.Parser.Turtle ( ParseResult , parseTurtle , parseTurtlefromText ) where import Swish.GraphClass (arc) import Swish.Namespace (Namespace, ScopedName) import Swish.Namespace (makeNamespace, getNamespaceTuple , getScopeNamespace, getScopedNameURI , getScopeNamespace, makeURIScopedName, makeNSScopedName) import Swish.QName (newLName, emptyLName) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) , 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 , sepEndBy1 , isymbol , lexeme , whiteSpace , hex4 , hex8 , appendURIs ) import Control.Applicative import Control.Monad (foldM) import Data.Char (chr, isAsciiLower, isAsciiUpper, isDigit, isHexDigit, ord, toLower) #if MIN_VERSION_base(4, 7, 0) import Data.Functor (($>)) #endif import Data.Maybe (fromMaybe) import Data.Word (Word32) import Network.URI (URI(..), parseURIReference) import Text.ParserCombinators.Poly.StateText import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L #if !MIN_VERSION_base(4, 7, 0) ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif ---------------------------------------------------------------------- -- 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif 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' = M.insert 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 = M.lookup 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 "#" -} -- | The W3C turtle tests - e.g. - -- point out there's no default prefix mapping. -- emptyState :: Maybe URI -- ^ starting base for the graph -> TurtleState emptyState mbase = let pmap = M.empty -- M.singleton 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 that ensures white space after -- the bracket symbol is parsed. br :: Char -> Char -> TurtleParser a -> TurtleParser a br lsym rsym = let f = lexeme . char in bracket (f lsym) (f rsym) -- this is a lot simpler than N3 atWord :: T.Text -> TurtleParser () atWord s = (char '@' *> lexeme (stringT s)) $> () -- | Case insensitive match. charI :: Char -- ^ must be upper case -> TurtleParser Char charI c = satisfy (`elem` c : [ toLower c ]) -- | Case insensitive match. stringI :: String -- ^ must be upper case -> TurtleParser String stringI = mapM charI {- 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 (nspre, nsuri) = getNamespaceTuple $ getScopeNamespace dtype newp = M.insert nspre nsuri 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 = isAsciiLower isAZ = isAsciiUpper isaZ c = isaz c || isAZ c is09 = isDigit isaZ09 c = isaZ c || is09 c {- 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 (updated to use the Data.Map.Map representation). -} operatorLabel :: ScopedName -> TurtleParser RDFLabel operatorLabel snam = do st <- stGet let (pkey, pval) = getNamespaceTuple $ getScopeNamespace snam opmap = prefixUris st rval = Res snam -- TODO: the lookup and the replacement could be fused; it may not -- even make sense to separate now using a Map case M.lookup pkey opmap of Just val | val == pval -> return rval | otherwise -> do stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval _ -> do stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval findPrefix :: T.Text -> TurtleParser Namespace findPrefix pre = do st <- stGet case M.lookup (Just pre) (prefixUris st) of Just uri -> return $ makeNamespace (Just pre) uri Nothing -> failBad $ "Undefined prefix '" ++ T.unpack pre ++ ":'." -- | Add the message to the start of the error message if the -- parser fails (a minor specialization of 'adjustErr'). {- addErr :: Parser s a -> String -> Parser s a addErr p m = adjustErr p (m++) -} ( String -- ^ Error message to add (a new line is added after the message) -> Parser s a ( infixl 3 infixl 4 (whiteSpace *> many statement *> eof *> stGet) where mkGr s = setNamespaces (prefixUris s) (graphState s) {- [2] statement ::= directive | triples '.' -} statement :: TurtleParser () statement = directive <|> (triples *> commit fullStop base sparqlPrefix sparqlBase > commit _iriRef >>= stUpdate . setBase {- [6s] sparqlPrefix ::= "PREFIX" PNAME_NS IRIREF -} sparqlPrefix :: TurtleParser () sparqlPrefix = do ignore $ lexeme $ stringI "PREFIX" p <- commit $ lexeme _pnameNS u <- lexeme _iriRef stUpdate $ setPrefix (fmap L.toStrict p) u {- [6] triples ::= subject predicateObjectList | blankNodePropertyList predicateObjectList? -} triples :: TurtleParser () triples = (subject >>= predicateObjectList) <|> (blankNodePropertyList >>= ignore . optional . predicateObjectList) {- [7] predicateObjectList ::= verb objectList (';' (verb objectList)?)* -} predicateObjectList :: RDFLabel -> TurtleParser () predicateObjectList subj = let term = verb >>= objectList subj in ignore $ sepEndBy1 term (many1 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 ::= iri | BlankNode | collection -} subject :: TurtleParser RDFLabel subject = (Res <$> iri) <|> blankNode <|> collection {- [11] predicate ::= iri -} predicate :: TurtleParser RDFLabel predicate = Res <$> iri {- [12] object ::= iri | BlankNode | collection | blankNodePropertyList | literal -} object :: TurtleParser RDFLabel object = (Res <$> iri) <|> blankNode <|> collection <|> blankNodePropertyList <|> literal {- [13] literal ::= RDFLiteral | NumericLiteral | BooleanLiteral -} literal :: TurtleParser RDFLabel literal = lexeme $ rdfLiteral <|> numericLiteral <|> booleanLiteral {- [14] blankNodePropertyList ::= '[' predicateObjectList ']' -} blankNodePropertyList :: TurtleParser RDFLabel blankNodePropertyList = do bNode <- newBlankNode br '[' ']' $ lexeme (predicateObjectList bNode) return bNode {- [15] 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 {- [16] NumericLiteral ::= INTEGER | DECIMAL | DOUBLE NOTE: We swap the order from this production I have removed the conversion to a canonical form for the double production, since it makes running the W3C tests for Turtle harder (since it assumes that "1E0" is passed through as is). It is also funny to create a "canonical" form for only certain data types. -} numericLiteral :: TurtleParser RDFLabel numericLiteral = let f t v = makeDatatypedLiteral t (L.toStrict v) in (f xsdDouble <$> _double) <|> (f xsdDecimal <$> _decimal) <|> (f xsdInteger <$> _integer) {- [128s] RDFLiteral ::= String (LANGTAG | '^^' iri)? TODO: remove 'Lit lbl' form, since dtype=xsd:string in this case. -} rdfLiteral :: TurtleParser RDFLabel rdfLiteral = do lbl <- L.toStrict <$> turtleString opt <- optional ((Left <$> (_langTag (string "^^" *> (Right <$> (commit iri LangLit lbl lcode Just (Right dtype) -> TypedLit lbl dtype _ -> Lit lbl {- [133s] BooleanLiteral ::= 'true' | 'false' -} booleanLiteral :: TurtleParser RDFLabel booleanLiteral = makeDatatypedLiteral xsdBoolean . T.pack <$> lexeme (string "true" <|> string "false") {- [17] String ::= STRING_LITERAL_QUOTE | STRING_LITERAL_SINGLE_QUOTE | STRING_LITERAL_LONG_SINGLE_QUOTE | STRING_LITERAL_LONG_QUOTE -} turtleString :: TurtleParser L.Text turtleString = lexeme ( _stringLiteralLongQuote <|> _stringLiteralQuote <|> _stringLiteralLongSingleQuote <|> _stringLiteralSingleQuote ) _iriRef) <|> prefixedName) {- [136s] PrefixedName ::= PNAME_LN | PNAME_NS -} prefixedName :: TurtleParser ScopedName prefixedName = _pnameLN <|> flip makeNSScopedName emptyLName <$> (_pnameNS >>= findPrefixNamespace) {- [137s] BlankNode ::= BLANK_NODE_LABEL | ANON -} blankNode :: TurtleParser RDFLabel blankNode = lexeme (_blankNodeLabel <|> _anon) {--- Productions for terminals ---} {- [18] IRIREF ::= '<' ([^#x00-#x20<>\"{}|^`\] | UCHAR)* '>' -} _iriRef :: TurtleParser URI _iriRef = do -- ignore $ char '<' -- why a, I using manyFinally' here? '>' shouldn't overlap -- with iriRefChar. -- ustr <- manyFinally' iriRefChar (char '>') ustr <- bracket (char '<') (commit (char '>')) (many iriRefChar) case parseURIReference ustr of Nothing -> failBad $ "Invalid URI: <" ++ ustr ++ ">" Just uref -> do s <- stGet either fail return $ appendURIs (baseUri s) uref iriRefChar :: TurtleParser Char iriRefChar = satisfy isIRIChar <|> _uchar isIRIChar :: Char -> Bool isIRIChar c = c > chr 0x20 && c `notElem` ("<>\"{}|^`\\"::String) {- [139s] PNAME_NS ::= PN_PREFIX? ':' -} _pnameNS :: TurtleParser (Maybe L.Text) _pnameNS = optional _pnPrefix <* char ':' {- [140s] PNAME_LN ::= 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 ++ "'" {- [141s] BLANK_NODE_LABEL ::= '_:' (PN_CHARS_U | [0-9]) ((PN_CHARS | '.')* PN_CHARS)? -} _blankNodeLabel :: TurtleParser RDFLabel _blankNodeLabel = do ignore $ string "_:" fChar <- _pnCharsU <|> satisfy is09 rest <- _pnRest return $ Blank $ fChar : L.unpack rest {- Extracted from BLANK_NODE_LABEL and PN_PREFIX :== ( ( PN_CHARS | '.' )* PN_CHARS )? We assume below that the match is only ever done for small strings, so the cost isn't likely to be large. Let's see how well this assumption holds up. -} _pnRest :: TurtleParser L.Text _pnRest = noTrailingDot _pnChars {- There are two productions which look like ( (parser | '.')* parser )? Unfortunately one of them has parser returning a Char and the other has the parser returning multiple characters, so separate out for now; hopefully can combine Have decided to try replacing this with sepEndBy1, treating the '.' as a separator, since this is closer to the EBNF. However, this then eats up multiple '.' characters. noTrailingDot :: TurtleParser Char -- ^ This *should not* match '.' -> TurtleParser L.Text noTrailingDot p = do terms <- sepEndBy1 (many p) (char '.') return $ L.pack $ intercalate "." terms noTrailingDotM :: TurtleParser L.Text -- ^ This *should not* match '.' -> TurtleParser L.Text noTrailingDotM p = do terms <- sepEndBy1 (many p) (char '.') return $ L.intercalate "." $ map L.concat terms -} noTrailing :: TurtleParser a -- ^ parser for '.' -> ([a] -> String) -- ^ Collect fragments into a string -> TurtleParser a -- ^ This *should not* match '.' -> TurtleParser L.Text noTrailing dotParser conv parser = do lbl <- many (parser <|> dotParser) let (nret, lclean) = clean $ conv 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) "." return $ L.pack lclean noTrailingDot :: TurtleParser Char -- ^ This *should not* match '.' -> TurtleParser L.Text noTrailingDot = noTrailing (char '.') id noTrailingDotM :: TurtleParser L.Text -- ^ This *should not* match '.' -> TurtleParser L.Text noTrailingDotM = noTrailing (char '.' $> ".") (L.unpack . L.concat) {- [144s] LANGTAG ::= '@' [a-zA-Z]+ ('-' [a-zA-Z0-9]+)* 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 <- commit $ 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? -- Returns True for + and False for -. _leadingSign :: TurtleParser (Maybe Bool) _leadingSign = do ms <- optional (satisfy (`elem` ("+-"::String))) return $ (== '+') `fmap` ms {- For when we tried to create a canonical representation. addSign :: Maybe Bool -> L.Text -> L.Text addSign (Just False) t = L.cons '-' t addSign _ t = t -} addSign :: Maybe Bool -> L.Text -> L.Text addSign (Just True) t = L.cons '+' t addSign (Just _) t = L.cons '-' t addSign _ t = t {- [19] INTEGER ::= [+-]? [0-9]+ We try to produce a canonical form for the numbers. -} _integer :: TurtleParser L.Text _integer = do ms <- _leadingSign rest <- many1Satisfy is09 return $ addSign ms rest {- [20] DECIMAL ::= [+-]? [0-9]* '.' [0-9]+ -} _decimal :: TurtleParser L.Text _decimal = do ms <- _leadingSign leading <- manySatisfy is09 ichar '.' trailing <- many1Satisfy is09 let ans2 = L.cons '.' trailing ans = if L.null leading -- then L.cons '0' ans2 -- create a 'canonical' version then ans2 else L.append leading ans2 return $ addSign ms ans {- [21] DOUBLE ::= [+-]? ([0-9]+ '.' [0-9]* EXPONENT | '.' [0-9]+ EXPONENT | [0-9]+ EXPONENT) -} _d1 :: TurtleParser L.Text _d1 = do a <- many1Satisfy is09 ichar '.' b <- manySatisfy is09 return $ a `L.append` ('.' `L.cons` b) _d2 :: TurtleParser L.Text _d2 = do ichar '.' b <- many1Satisfy is09 return $ '.' `L.cons` b _d3 :: TurtleParser L.Text _d3 = many1Satisfy is09 _double :: TurtleParser L.Text _double = do ms <- _leadingSign leading <- _d1 <|> _d2 <|> _d3 e <- _exponent return $ addSign ms $ leading `L.append` e {- [154s] EXPONENT ::= [eE] [+-]? [0-9]+ -} _exponent :: TurtleParser L.Text _exponent = do e <- char 'e' <|> char 'E' ms <- _leadingSign L.cons e . addSign ms <$> _integer {- [22] STRING_LITERAL_QUOTE ::= '"' ([^#x22#x5C#xA#xD] | ECHAR | UCHAR)* '"' [23] STRING_LITERAL_SINGLE_QUOTE ::= "'" ([^#x27#x5C#xA#xD] | ECHAR | UCHAR)* "'" [24] STRING_LITERAL_LONG_SINGLE_QUOTE ::= "'''" (("'" | "''")? [^'\] | ECHAR | UCHAR)* "'''" [25] STRING_LITERAL_LONG_QUOTE ::= '"""' (('"' | '""')? [^"\] | ECHAR | UCHAR)* '"""' Since ECHAR | UCHAR is common to all these we pull it out to create the _protChar parser. -} _protChar :: TurtleParser Char _protChar = char '\\' *> (_echar' <|> _uchar') _exclSLQ, _exclSLSQ :: String _exclSLQ = map chr [0x22, 0x5c, 0x0a, 0x0d] _exclSLSQ = map chr [0x27, 0x5c, 0x0a, 0x0d] _stringLiteralQuote, _stringLiteralSingleQuote :: TurtleParser L.Text _stringLiteralQuote = _stringIt dQuot (_tChars _exclSLQ) _stringLiteralSingleQuote = _stringIt sQuot (_tChars _exclSLSQ) _stringLiteralLongQuote, _stringLiteralLongSingleQuote :: TurtleParser L.Text _stringLiteralLongQuote = _stringItLong dQuot3 (_tCharsLong '"') _stringLiteralLongSingleQuote = _stringItLong sQuot3 (_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 = _protChar <|> noneOf excl oneOrTwo :: Char -> TurtleParser L.Text oneOrTwo c = do ignore $ char c mb <- optional (char c) case mb of Just _ -> return $ L.pack [c,c] _ -> return $ L.singleton c _multiQuote :: Char -> TurtleParser L.Text _multiQuote c = do mq <- optional (oneOrTwo c) r <- noneOf (c : "\\") return $ fromMaybe L.empty mq `L.snoc` r _tCharsLong :: Char -> TurtleParser L.Text _tCharsLong c = L.singleton <$> _protChar <|> _multiQuote c {- [26] UCHAR ::= '\u' HEX HEX HEX HEX | '\U' HEX HEX HEX HEX HEX HEX HEX HEX -} _uchar :: TurtleParser Char _uchar = char '\\' >> _uchar' _uchar' :: TurtleParser Char _uchar' = (char 'u' *> (commit hex4 (char 'U' *> (commit hex8 _echar' -} _echar' :: TurtleParser Char _echar' = (char 't' $> '\t') <|> (char 'b' $> '\b') <|> (char 'n' $> '\n') <|> (char 'r' $> '\r') <|> (char 'f' $> '\f') <|> (char '\\' $> '\\') <|> (char '"' $> '"') <|> (char '\'' $> '\'') {- [161s] WS ::= #x20 | #x9 | #xD | #xA -} _ws :: TurtleParser () _ws = ignore $ satisfy (`elem` _wsChars) _wsChars :: String _wsChars = map chr [0x20, 0x09, 0x0d, 0x0a] {- [162s] ANON ::= '[' WS* ']' -} _anon :: TurtleParser RDFLabel _anon = br '[' ']' (many _ws) >> newBlankNode {- [163s] PN_CHARS_BASE ::= [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] | [#x10000-#xEFFFF] 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 {- [164s] PN_CHARS_U ::= PN_CHARS_BASE | '_' [166s] PN_CHARS ::= PN_CHARS_U | '-' | [0-9] | #x00B7 | [#x0300-#x036F] | [#x203F-#x2040] -} _pnCharsU, _pnChars :: TurtleParser Char _pnCharsU = _pnCharsBase <|> char '_' _pnChars = let f c = let i = ord c in match i [(0x300, 0x36f), (0x203f, 0x2040)] in _pnCharsU <|> char '-' <|> satisfy is09 <|> char (chr 0xb7) <|> satisfy f {- [167s] PN_PREFIX ::= PN_CHARS_BASE ((PN_CHARS | '.')* PN_CHARS)? [168s] PN_LOCAL ::= (PN_CHARS_U | ':' | [0-9] | PLX) ((PN_CHARS | '.' | ':' | PLX)* (PN_CHARS | ':' | PLX))? -} _pnPrefix :: TurtleParser L.Text _pnPrefix = L.cons <$> _pnCharsBase <*> _pnRest _pnLocal :: TurtleParser L.Text _pnLocal = do s <- L.singleton <$> (_pnCharsU <|> char ':' <|> satisfy is09) <|> _plx e <- noTrailingDotM (L.singleton <$> (_pnChars <|> char ':') <|> _plx) return $ s `L.append` e {- [169s] PLX ::= PERCENT | PN_LOCAL_ESC [170s] PERCENT ::= '%' HEX HEX [171s] HEX ::= [0-9] | [A-F] | [a-f] [172s] PN_LOCAL_ESC ::= '\' ('_' | '~' | '.' | '-' | '!' | '$' | '&' | "'" | '(' | ')' | '*' | '+' | ',' | ';' | '=' | '/' | '?' | '#' | '@' | '%') We do not convert hex-encoded values into the characters, which means we have to deal with Text rather than Char for these parsers, which is annoying. -} _plx, _percent :: TurtleParser L.Text _plx = _percent <|> (L.singleton <$> _pnLocalEsc) _percent = do ichar '%' a <- _hex L.cons '%' . L.cons a . L.singleton <$> _hex _hex, _pnLocalEsc :: TurtleParser Char _hex = satisfy isHexDigit _pnLocalEsc = char '\\' *> satisfy (`elem` _pnLocalEscChars) _pnLocalEscChars :: String _pnLocalEscChars = "_~.-!$&'()*+,;=/?#@%" -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2018, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Parser/Utils.hs0000644000000000000000000002673114220136201016444 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Utils -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2018, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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) #if MIN_VERSION_base(4, 7, 0) import Data.Functor (($>)) #endif import Data.Maybe (fromMaybe, fromJust) import Network.URI (URI(..), relativeTo, parseURIReference) import Text.ParserCombinators.Poly.StateText import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Read as R #if !MIN_VERSION_base(4, 7, 0) ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif -- Code -- | Append the two URIs. Given the change in signature of -- `Network.URI.relativeTo` in version @2.4.0.0@ of @network@, -- it is not clear that this function is necessary. At the -- very least, it should be changed to just return a `URI`. -- 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 "" -> Right $ uri `relativeTo` base _ -> Right uri -- | Type for special name lookup table type SpecialMap = M.Map String ScopedName -- | 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 $> () -- | 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 $> []) <|> ((:) <$> 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')) $> () {- 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, 2014, 2018, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Proof.hs0000644000000000000000000003647713543702315015221 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Proof -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2016 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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.Proof ( RDFProof, RDFProofStep , makeRDFProof, makeRDFProofStep , makeRdfInstanceEntailmentRule , makeRdfSubgraphEntailmentRule , makeRdfSimpleEntailmentRule ) where 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.Graph (RDFLabel(..), RDFGraph, fmapNSGraph) import Swish.RDF.Graph (merge, allLabels, remapLabelList) import Swish.RDF.Query (rdfQueryInstance, rdfQuerySubs) import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) import Swish.Utils.ListHelpers (flist) import Data.List (subsequences) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import qualified Data.Map as M import qualified Data.Set as S ------------------------------------------------------------ -- 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 (LDGraph lg lb, Eq (lg lb)) => Expression (lg lb) where isValid = S.null . getArcs ------------------------------------------------------------ -- Define RDF-specific types for proof framework ------------------------------------------------------------ -- | An RDF proof. type RDFProof = Proof RDFGraph -- | A step in an RDF proof. 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] -- ^ the chain of inference rules in the proof. -> 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 '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 } -- 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 = S.toList $ allLabels labelIsVar mergeGraph -- Obtain list of possible remappings for non-variable nodes mapList = remapLabelList nonvarNodes varNodes mapSubLists = (tail . subsequences) mapList mapGr ls = fmapNSGraph (\l -> M.findWithDefault l l (M.fromList 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 = S.toList $ 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 ------------------------------------------------------------ -- 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 -- 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. 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 -- TODO: update to use sets as appropriate map (setArcs mergeGraph . S.fromList) (init $ tail $ subsequences $ S.toList $ 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 mempty else foldl1 addGraphs ante in -- Check each consequent graph arc is in the antecedent graph getArcs cons `S.isSubsetOf` 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 mempty else foldl1 addGraphs 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, 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/ProofContext.hs0000644000000000000000000006544613543702315016564 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : ProofContext -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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 ) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Query.hs0000644000000000000000000006113514220136201015212 0ustar0000000000000000{-# LANGUAGE CPP #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Query -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP -- -- 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: -- -- >>> :set -XOverloadedStrings -- >>> import Swish.RDF -- >>> import Swish.RDF.Parser.N3 (parseN3fromText) -- >>> import Swish.RDF.Query -- >>> import Swish.VarBinding (VarBinding(vbMap)) -- >>> import Network.URI (parseURI) -- >>> import Data.Maybe (fromJust, mapMaybe) -- >>> 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." -- >>> let ans = rdfQueryFind qgr igr -- >>> :t ans -- ans :: [Swish.RDF.VarBinding.RDFVarBinding] -- >>> ans -- [[(?node,a:a),(?type,a:A)],[(?node,a:b),(?type,a:B)]] -- >>> let bn = toRDFLabel . fromJust . parseURI $ "http://example.com/B" -- >>> let arcs = rdfFindArcs (rdfObjEq bn) igr -- >>> :t arcs -- arcs :: [RDFTriple] -- >>> arcs -- [(a:b,rdf:type,a:B)] -- >>> let lbls = mapMaybe (`vbMap` (Var "type")) ans -- >>> :t lbls -- lbls :: [RDFLabel] -- >>> lbls -- [a:A,a:B] -- -------------------------------------------------------------------------------- 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 , traverseNSGraph ) 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) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import qualified Data.Set as S ------------------------------------------------------------ -- Primitive RDF graph queries ------------------------------------------------------------ -- Get a list of arcs from a graph. -- -- Can we update the routines to work with sets instead? getTriples :: RDFGraph -> [RDFTriple] getTriples = S.toList . getArcs -- | 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 . getTriples -- 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) (S.toList $ 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 -- ^ Query graph -> RDFGraph -- ^ Target graph -> [[RDFVarBinding]] rdfQueryBack qg tg = let ga = getTriples in rdfQueryBack1 matchQueryVariable [] (ga qg) (ga 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 . getTriples ------------------------------------------------------------ -- 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 = S.toList $ 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) -- the addgraphs part is important, possibly just to remove duplicated entries where (g,vs) = runState (traverseNSGraph (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 = S.toList . S.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, 2014, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Ruleset.hs0000644000000000000000000005210513543702315015541 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Ruleset -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2016 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, 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.Ruleset ( -- * 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.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(..), ArcSet, LDGraph(..)) import Swish.VarBinding (VarBindingModify(..)) import Swish.VarBinding (makeVarBinding, applyVarBinding, joinVarBindings, vbmCompose, varBindingId) import Swish.RDF.Query ( rdfQueryFind , rdfQueryBack, rdfQueryBackModify , rdfQuerySubs , rdfQuerySubsBlank ) import Swish.RDF.Graph ( RDFLabel(..), RDFGraph, RDFArcSet , makeBlank, newNodes , merge, allLabels , toRDFGraph) import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingModify) import Swish.RDF.Parser.N3 (parseN3) import Swish.RDF.Vocabulary (swishName, namespaceRDF, namespaceRDFS) import Swish.Utils.ListHelpers (flist) import Data.List (nub) import Data.Maybe (fromMaybe) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import qualified Data.Set as S 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 map for 'RDFRule' rules. type RDFRuleMap = RuleMap RDFGraph -- | A 'GraphClosure' for RDF statements. type RDFClosure = GraphClosure RDFLabel -- | A 'Ruleset' for RDF. type RDFRuleset = Ruleset RDFGraph -- | A map 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 ------------------------------------------------------------ -- |Datatype for constructing a graph closure rule data GraphClosure lb = GraphClosure { nameGraphRule :: ScopedName -- ^ Name of rule for proof display , ruleAnt :: ArcSet lb -- ^ Antecedent triples pattern -- (may include variable nodes) , ruleCon :: ArcSet 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. } -- | Equality is based on the closure rule, anrecedents and -- consequents. instance (Label lb) => Eq (GraphClosure lb) where c1 == c2 = nameGraphRule c1 == nameGraphRule c2 && ruleAnt c1 == ruleAnt c2 && ruleCon c1 == ruleCon c2 instance 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 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 -} -- | 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 :: RDFArcSet -> RDFGraph -> [RDFVarBinding] queryFind qas = rdfQueryFind (toRDFGraph qas) queryBack :: RDFArcSet -> RDFGraph -> [[RDFVarBinding]] queryBack qas = rdfQueryBack (toRDFGraph qas) querySubs :: [RDFVarBinding] -> RDFArcSet -> [RDFGraph] querySubs vars = rdfQuerySubs vars . toRDFGraph querySubsBlank :: [RDFVarBinding] -> RDFArcSet -> [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 } ------------------------------------------------------------ -- 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 = S.unions $ map 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 -> 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 -- |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 -- |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 {- 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 -> 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 $ S.toList (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, 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/VarBinding.hs0000644000000000000000000001625313543702315016145 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- 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 : OverloadedStrings -- -- This module instantiates the `VarBinding` types and methods for use -- with RDF graph labels. -- -------------------------------------------------------------------------------- -- See module RDFQueryTest for test cases. module Swish.RDF.VarBinding ( RDFVarBinding , RDFVarBindingModify, RDFOpenVarBindingModify, RDFOpenVarBindingModifyMap , RDFVarBindingFilter , nullRDFVarBinding , rdfVarBindingUriRef, rdfVarBindingBlank , rdfVarBindingLiteral , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped , rdfVarBindingMemberProp ) where import Swish.Namespace (ScopedName) import Swish.VarBinding (VarBinding(..), VarBindingModify(..), OpenVarBindingModify, VarBindingFilter(..)) import Swish.VarBinding (nullVarBinding, applyVarBinding, makeVarTestFilter) import Swish.RDF.Graph ( RDFLabel(..) , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral , isDatatyped, isMemberProp, isUri, isBlank ) import Swish.RDF.Vocabulary (swishName) import qualified Data.Map as M ------------------------------------------------------------ -- 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 = M.Map ScopedName 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, 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary.hs0000644000000000000000000002561114220136201016213 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Vocabulary -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2014, 2021, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module defines some commonly used vocabulary terms, -- using the 'Namespace' and 'ScopedName' data types. Additional vocabularies -- are available in the set of @Swish.RDF.Vocabulary.*@ modules, parts of -- which are re-exported by this module -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary ( -- * Namespaces namespaceRDFD , namespaceXsdType , namespaceMATH , namespaceLOG , namespaceDAML , namespaceDefault , namespaceSwish -- ** 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 , swishName , rdfdGeneralRestriction , rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality , logImplies , defaultBase -- * Re-exported modules , module Swish.RDF.Vocabulary.RDF , module Swish.RDF.Vocabulary.OWL , module Swish.RDF.Vocabulary.XSD ) 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 Control.Monad (guard) import Data.Char (isDigit, isAsciiLower) import Data.List (isPrefixOf) import Data.List.NonEmpty (NonEmpty(..)) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (mappend, mconcat) #endif 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 ------------------------------------------------------------ -- Define some common namespace values ------------------------------------------------------------ toNS :: T.Text -> T.Text -> Namespace toNS p utxt = let ustr = T.unpack utxt uri = fromMaybe (error ("Unable to convert " ++ ustr ++ " to a URI")) $ parseURI ustr in makeNamespace (Just p) uri toNSU :: T.Text -> URI -> Namespace toNSU p = makeNamespace (Just p) -- | Create a namespace for the datatype family schema used by Swish. namespaceXsdType :: LName -- ^ local name -> Namespace -- ^ Namespace has prefix @xsd_lbl@ and -- URI of @http:\/\/id.ninebynine.org\/2003\/XMLSchema\/lbl#@. 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 namespaceRDFD = toNSU "rdfd" namespaceRDFDURI -- | Maps @math@ to . namespaceMATH :: Namespace namespaceMATH = toNS "math" "http://www.w3.org/2000/10/swap/math#" -- | Maps @log@ to . namespaceLOG :: Namespace namespaceLOG = toNSU "log" namespaceLOGURI -- | Maps @daml@ to . namespaceDAML :: Namespace namespaceDAML = toNS "daml" "http://www.daml.org/2000/10/daml-ont#" -- | Maps @swish@ to @http:\/\/id.ninebynine.org\/2003\/Swish\/@. namespaceSwish :: Namespace namespaceSwish = toNSU "swish" namespaceSwishURI -- | Maps @default@ to @http:\/\/id.ninebynine.org\/default\/@. namespaceDefault :: Namespace namespaceDefault = toNSU "default" namespaceDefaultURI tU :: String -> URI tU = fromMaybe (error "Internal error processing namespace URI") . parseURI namespaceRDFDURI, namespaceLOGURI, namespaceSwishURI, 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/" namespaceDefaultURI = tU "http://id.ninebynine.org/default/" -- | Convert a local name to a scoped name in the @swish@ namespace (`namespaceSwish`). swishName :: LName -> ScopedName swishName = makeNSScopedName namespaceSwish ----------------------------------------------------------- -- Language tags ------------------------------------------------------------ -- -- Note: simple language tag URIs may be abbreviated as lang:tag, -- but if the tag contains a hyphen, this would not be valid QName -- form in Notation3, even though it is a valid QName component. -- Fortunately, they do not currently need to appear in Notation3 as -- distinct labels (but future developments may change that). -- | 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 instance Show LanguageTag where show = T.unpack . fromLangTag -- | 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 instance Ord LanguageTag where LanguageTag _ t1 `compare` LanguageTag _ t2 = t1 `compare` 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 = do let tag = T.toLower lbl toks = T.split (== '-') tag guard (all (\s -> let l = T.length s in l > 0 && l < 9) toks) -- T.split can't return [] but the compiler doesn't know this case toks of primtag : subtags -> do guard (T.all isAsciiLower primtag && all (T.all (\c -> isAsciiLower c || isDigit c)) subtags) pure $ LanguageTag lbl (NE.fromList toks) [] -> 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 ------------------------------------------------------------ -- | Maps @rs_rdf@ to @http:\/\/id.ninebynine.org\/2003\/Ruleset\/rdf#@. scopeRDF :: Namespace scopeRDF = toNS "rs_rdf" "http://id.ninebynine.org/2003/Ruleset/rdf#" -- | Maps @rs_rdfs@ to @http:\/\/id.ninebynine.org\/2003\/Ruleset\/rdfs#@. scopeRDFS :: Namespace scopeRDFS = toNS "rs_rdfs" "http://id.ninebynine.org/2003/Ruleset/rdfs#" -- | Maps @rs_rdfd@ to @http:\/\/id.ninebynine.org\/2003\/Ruleset\/rdfd#@. scopeRDFD :: Namespace scopeRDFD = toNS "rs_rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" ------------------------------------------------------------ -- Define some common vocabulary terms ------------------------------------------------------------ toRDFD :: LName -> ScopedName toRDFD = makeNSScopedName namespaceRDFD -- | @rdfd:GeneralRestriction@. rdfdGeneralRestriction :: ScopedName rdfdGeneralRestriction = toRDFD "GeneralRestriction" -- | @rdfd:onProperties@. rdfdOnProperties :: ScopedName rdfdOnProperties = toRDFD "onProperties" -- | @rdfd:constraint@. rdfdConstraint :: ScopedName rdfdConstraint = toRDFD "constraint" -- | @rdfd:maxCardinality@. rdfdMaxCardinality :: ScopedName rdfdMaxCardinality = toRDFD "maxCardinality" -- | @log:implies@. logImplies :: ScopedName logImplies = makeNSScopedName namespaceLOG "implies" -- | @default:base@. defaultBase :: ScopedName defaultBase = makeNSScopedName namespaceDefault "base" -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2014, 2021, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/DublinCore.hs0000644000000000000000000006464513543702315020267 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.DublinCore -- Copyright : (c) 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines some commonly used vocabulary terms from the Dublin Core -- vocabularies (). -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.DublinCore ( namespaceDCTERMS , namespaceDCELEM , namespaceDCAM , namespaceDCTYPE -- * Classes -- | See the \"Classes\" section at . , dctAgent , dctAgentClass , dctBibliographicResource , dctFileFormat , dctFrequency , dctJurisdiction , dctLicenseDocument , dctLinguisticSystem , dctLocation , dctLocationPeriodOrJurisdiction , dctMediaType , dctMediaTypeOrExtent , dctMethodOfAccrual , dctMethodOfInstruction , dctPeriodOfTime , dctPhysicalMedium , dctPhysicalResource , dctPolicy , dctProvenanceStatement , dctRightsStatement , dctSizeOrDuration , dctStandard -- * Properties -- | See the \"Properties\" section at . , dctabstract , dctaccessRights , dctaccrualMethod , dctaccrualPeriodicity , dctaccrualPolicy , dctalternative , dctaudience , dctavailable , dctbibliographicCitation , dctconformsTo , dctcontributor , dctcoverage , dctcreated , dctcreator , dctdate , dctdateAccepted , dctdateCopyrighted , dctdateSubmitted , dctdescription , dcteducationLevel , dctextent , dctformat , dcthasFormat , dcthasPart , dcthasVersion , dctidentifier , dctinstructionalMethod , dctisFormatOf , dctisPartOf , dctisReferencedBy , dctisReplacedBy , dctisRequiredBy , dctissued , dctisVersionOf , dctlanguage , dctlicense , dctmediator , dctmedium , dctmodified , dctprovenance , dctpublisher , dctreferences , dctrelation , dctreplaces , dctrequires , dctrights , dctrightsHolder , dctsource , dctspatial , dctsubject , dcttableOfContents , dcttemporal , dcttitle , dcttype , dctvalid -- * Legacy Properties -- -- | The following properties are from the legacy /elements/ vocabulary -- (@http:\/\/purl.org\/dc\/elements\/1.1\/contributor\/@). See -- . , dcelemcontributor , dcelemcoverage , dcelemcreator , dcelemdate , dcelemdescription , dcelemformat , dcelemidentifier , dcelemlanguage , dcelempublisher , dcelemrelation , dcelemrights , dcelemsource , dcelemsubject , dcelemtitle , dcelemtype -- * Encoding -- | See the \"Vocabulary Encoding Schemes\" section at . , dctLCSH , dctMESH , dctDDC , dctLCC , dctUDC , dctDCMIType , dctIMT , dctTGN , dctNLM -- * Datatypes -- | See the \"Syntax Encoding Schemes\" section at . , dctBox , dctISO3166 , dctISO639_2 , dctISO639_3 , dctPeriod , dctPoint , dctRFC1766 , dctRFC3066 , dctRFC4646 , dctRFC5646 , dctURI , dctW3CDTF -- * Types -- | See the \"DCMI Type Vocabulary\" section at . , dctypeCollection , dctypeDataset , dctypeEvent , dctypeImage , dctypeInteractiveResource , dctypeService , dctypeSoftware , dctypeSound , dctypeText , dctypePhysicalObject , dctypeStillImage , dctypeMovingImage -- * DCMI Abstract Model -- -- | Terms from the DCMI Abstract Model (). , dcammemberOf , dcamVocabularyEncodingScheme ) where import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (parseURI) import qualified Data.Text as T ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . fromMaybe (error "Internal error processing DC URI") . parseURI -- | Maps @dcterms@ to . namespaceDCTERMS :: Namespace namespaceDCTERMS = toNS "dcterms" "http://purl.org/dc/terms/" -- | Maps @dcelem@ to the legacy namespace . namespaceDCELEM :: Namespace namespaceDCELEM = toNS "dcelem" "http://purl.org/dc/elements/1.1/" -- | Maps @dcam@ to . namespaceDCAM :: Namespace namespaceDCAM = toNS "dcam" "http://purl.org/dc/dcam/" -- | Maps @dctype@ to . namespaceDCTYPE :: Namespace namespaceDCTYPE = toNS "dctype" "http://purl.org/dc/dcmitype/" ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toDCT, toDCE, toDCAM, toDCTYPE :: LName -> ScopedName toDCT = makeNSScopedName namespaceDCTERMS toDCE = makeNSScopedName namespaceDCELEM toDCAM = makeNSScopedName namespaceDCAM toDCTYPE = makeNSScopedName namespaceDCTYPE -- Classes -- | @dcterms:Agent@ from . dctAgent :: ScopedName dctAgent = toDCT "Agent" -- | @dcterms:AgentClass@ from . dctAgentClass :: ScopedName dctAgentClass = toDCT "AgentClass" -- | @dcterms:BibliographicResource@ from . dctBibliographicResource :: ScopedName dctBibliographicResource = toDCT "BibliographicResource" -- | @dcterms:FileFormat@ from . dctFileFormat :: ScopedName dctFileFormat = toDCT "FileFormat" -- | @dcterms:Frequency@ from . dctFrequency :: ScopedName dctFrequency = toDCT "Frequency" -- | @dcterms:Jurisdiction@ from . dctJurisdiction :: ScopedName dctJurisdiction = toDCT "Jurisdiction" -- | @dcterms:LicenseDocument@ from . dctLicenseDocument :: ScopedName dctLicenseDocument = toDCT "LicenseDocument" -- | @dcterms:LinguisticSystem@ from . dctLinguisticSystem :: ScopedName dctLinguisticSystem = toDCT "LinguisticSystem" -- | @dcterms:Location@ from . dctLocation :: ScopedName dctLocation = toDCT "Location" -- | @dcterms:LocationPeriodOrJurisdiction@ from . dctLocationPeriodOrJurisdiction :: ScopedName dctLocationPeriodOrJurisdiction = toDCT "LocationPeriodOrJurisdiction" -- | @dcterms:MediaType@ from . dctMediaType :: ScopedName dctMediaType = toDCT "MediaType" -- | @dcterms:MediaTypeOrExtent@ from . dctMediaTypeOrExtent :: ScopedName dctMediaTypeOrExtent = toDCT "MediaTypeOrExtent" -- | @dcterms:MethodOfAccrual@ from . dctMethodOfAccrual :: ScopedName dctMethodOfAccrual = toDCT "MethodOfAccrual" -- | @dcterms:MethodOfInstruction@ from . dctMethodOfInstruction :: ScopedName dctMethodOfInstruction = toDCT "MethodOfInstruction" -- | @dcterms:PeriodOfTime@ from . dctPeriodOfTime :: ScopedName dctPeriodOfTime = toDCT "PeriodOfTime" -- | @dcterms:PhysicalMedium@ from . dctPhysicalMedium :: ScopedName dctPhysicalMedium = toDCT "PhysicalMedium" -- | @dcterms:PhysicalResource@ from . dctPhysicalResource :: ScopedName dctPhysicalResource = toDCT "PhysicalResource" -- | @dcterms:Policy@ from . dctPolicy :: ScopedName dctPolicy = toDCT "Policy" -- | @dcterms:ProvenanceStatement@ from . dctProvenanceStatement :: ScopedName dctProvenanceStatement = toDCT "ProvenanceStatement" -- | @dcterms:RightsStatement@ from . dctRightsStatement :: ScopedName dctRightsStatement = toDCT "RightsStatement" -- | @dcterms:SizeOrDuration@ from . dctSizeOrDuration :: ScopedName dctSizeOrDuration = toDCT "SizeOrDuration" -- | @dcterms:Standard@ from . dctStandard :: ScopedName dctStandard = toDCT "Standard" -- Properties -- | @dcterms:abstract@ from . dctabstract :: ScopedName dctabstract = toDCT "abstract" -- | @dcterms:accessRights@ from . dctaccessRights :: ScopedName dctaccessRights = toDCT "accessRights" -- | @dcterms:accrualMethod@ from . dctaccrualMethod :: ScopedName dctaccrualMethod = toDCT "accrualMethod" -- | @dcterms:accrualPeriodicity@ from . dctaccrualPeriodicity :: ScopedName dctaccrualPeriodicity = toDCT "accrualPeriodicity" -- | @dcterms:accrualPolicy@ from . dctaccrualPolicy :: ScopedName dctaccrualPolicy = toDCT "accrualPolicy" -- | @dcterms:alternative@ from . dctalternative :: ScopedName dctalternative = toDCT "alternative" -- | @dcterms:audience@ from . dctaudience :: ScopedName dctaudience = toDCT "audience" -- | @dcterms:available@ from . dctavailable :: ScopedName dctavailable = toDCT "available" -- | @dcterms:bibliographicCitation@ from . dctbibliographicCitation :: ScopedName dctbibliographicCitation = toDCT "bibliographicCitation" -- | @dcterms:conformsTo@ from . dctconformsTo :: ScopedName dctconformsTo = toDCT "conformsTo" -- | @dcterms:contributor@ from . dctcontributor :: ScopedName dctcontributor = toDCT "contributor" -- | @dcterms:coverage@ from . dctcoverage :: ScopedName dctcoverage = toDCT "coverage" -- | @dcterms:created@ from . dctcreated :: ScopedName dctcreated = toDCT "created" -- | @dcterms:creator@ from . dctcreator :: ScopedName dctcreator = toDCT "creator" -- | @dcterms:date@ from . dctdate :: ScopedName dctdate = toDCT "date" -- | @dcterms:dateAccepted@ from . dctdateAccepted :: ScopedName dctdateAccepted = toDCT "dateAccepted" -- | @dcterms:dateCopyrighted@ from . dctdateCopyrighted :: ScopedName dctdateCopyrighted = toDCT "dateCopyrighted" -- | @dcterms:dateSubmitted@ from . dctdateSubmitted :: ScopedName dctdateSubmitted = toDCT "dateSubmitted" -- | @dcterms:description@ from . dctdescription :: ScopedName dctdescription = toDCT "description" -- | @dcterms:educationLevel@ from . dcteducationLevel :: ScopedName dcteducationLevel = toDCT "educationLevel" -- | @dcterms:extent@ from . dctextent :: ScopedName dctextent = toDCT "extent" -- | @dcterms:format@ from . dctformat :: ScopedName dctformat = toDCT "format" -- | @dcterms:hasFormat@ from . dcthasFormat :: ScopedName dcthasFormat = toDCT "hasFormat" -- | @dcterms:hasPart@ from . dcthasPart :: ScopedName dcthasPart = toDCT "hasPart" -- | @dcterms:hasVersion@ from . dcthasVersion :: ScopedName dcthasVersion = toDCT "hasVersion" -- | @dcterms:identifier@ from . dctidentifier :: ScopedName dctidentifier = toDCT "identifier" -- | @dcterms:instructionalMethod@ from . dctinstructionalMethod :: ScopedName dctinstructionalMethod = toDCT "instructionalMethod" -- | @dcterms:isFormatOf@ from . dctisFormatOf :: ScopedName dctisFormatOf = toDCT "isFormatOf" -- | @dcterms:isPartOf@ from . dctisPartOf :: ScopedName dctisPartOf = toDCT "isPartOf" -- | @dcterms:isReferencedBy@ from . dctisReferencedBy :: ScopedName dctisReferencedBy = toDCT "isReferencedBy" -- | @dcterms:isReplacedBy@ from . dctisReplacedBy :: ScopedName dctisReplacedBy = toDCT "isReplacedBy" -- | @dcterms:isRequiredBy@ from . dctisRequiredBy :: ScopedName dctisRequiredBy = toDCT "isRequiredBy" -- | @dcterms:issued@ from . dctissued :: ScopedName dctissued = toDCT "issued" -- | @dcterms:isVersionOf@ from . dctisVersionOf :: ScopedName dctisVersionOf = toDCT "isVersionOf" -- | @dcterms:language@ from . dctlanguage :: ScopedName dctlanguage = toDCT "language" -- | @dcterms:license@ from . dctlicense :: ScopedName dctlicense = toDCT "license" -- | @dcterms:mediator@ from . dctmediator :: ScopedName dctmediator = toDCT "mediator" -- | @dcterms:medium@ from . dctmedium :: ScopedName dctmedium = toDCT "medium" -- | @dcterms:modified@ from . dctmodified :: ScopedName dctmodified = toDCT "modified" -- | @dcterms:provenance@ from . dctprovenance :: ScopedName dctprovenance = toDCT "provenance" -- | @dcterms:publisher@ from . dctpublisher :: ScopedName dctpublisher = toDCT "publisher" -- | @dcterms:references@ from . dctreferences :: ScopedName dctreferences = toDCT "references" -- | @dcterms:relation@ from . dctrelation :: ScopedName dctrelation = toDCT "relation" -- | @dcterms:replaces@ from . dctreplaces :: ScopedName dctreplaces = toDCT "replaces" -- | @dcterms:requires@ from . dctrequires :: ScopedName dctrequires = toDCT "requires" -- | @dcterms:rights@ from . dctrights :: ScopedName dctrights = toDCT "rights" -- | @dcterms:rightsHolder@ from . dctrightsHolder :: ScopedName dctrightsHolder = toDCT "rightsHolder" -- | @dcterms:source@ from . dctsource :: ScopedName dctsource = toDCT "source" -- | @dcterms:spatial@ from . dctspatial :: ScopedName dctspatial = toDCT "spatial" -- | @dcterms:subject@ from . dctsubject :: ScopedName dctsubject = toDCT "subject" -- | @dcterms:tableOfContents@ from . dcttableOfContents :: ScopedName dcttableOfContents = toDCT "tableOfContents" -- | @dcterms:temporal@ from . dcttemporal :: ScopedName dcttemporal = toDCT "temporal" -- | @dcterms:title@ from . dcttitle :: ScopedName dcttitle = toDCT "title" -- | @dcterms:type@ from . dcttype :: ScopedName dcttype = toDCT "type" -- | @dcterms:valid@ from . dctvalid :: ScopedName dctvalid = toDCT "valid" -- legacy elements vocabulary: properties -- | @dcelem:contributor@ from . dcelemcontributor :: ScopedName dcelemcontributor = toDCE "contributor" -- | @dcelem:coverage@ from . dcelemcoverage :: ScopedName dcelemcoverage = toDCE "coverage" -- | @dcelem:creator@ from . dcelemcreator :: ScopedName dcelemcreator = toDCE "creator" -- | @dcelem:date@ from . dcelemdate :: ScopedName dcelemdate = toDCE "date" -- | @dcelem:description@ from . dcelemdescription :: ScopedName dcelemdescription = toDCE "description" -- | @dcelem:format@ from . dcelemformat :: ScopedName dcelemformat = toDCE "format" -- | @dcelem:identifier@ from . dcelemidentifier :: ScopedName dcelemidentifier = toDCE "identifier" -- | @dcelem:language@ from . dcelemlanguage :: ScopedName dcelemlanguage = toDCE "language" -- | @dcelem:publisher@ from . dcelempublisher :: ScopedName dcelempublisher = toDCE "publisher" -- | @dcelem:relation@ from . dcelemrelation :: ScopedName dcelemrelation = toDCE "relation" -- | @dcelem:rights@ from . dcelemrights :: ScopedName dcelemrights = toDCE "rights" -- | @dcelem:source@ from . dcelemsource :: ScopedName dcelemsource = toDCE "source" -- | @dcelem:subject@ from . dcelemsubject :: ScopedName dcelemsubject = toDCE "subject" -- | @dcelem:title@ from . dcelemtitle :: ScopedName dcelemtitle = toDCE "title" -- | @dcelem:type@ from . dcelemtype :: ScopedName dcelemtype = toDCE "type" -- Datatypes -- | @dcterms:Box@ from . dctBox :: ScopedName dctBox = toDCT "Box" -- | @dcterms:ISO3166@ from . dctISO3166 :: ScopedName dctISO3166 = toDCT "ISO3166" -- | @dcterms:ISO639-2@ from . dctISO639_2 :: ScopedName dctISO639_2 = toDCT "ISO639-2" -- | @dcterms:ISO639-3@ from . dctISO639_3 :: ScopedName dctISO639_3 = toDCT "ISO639-3" -- | @dcterms:Period@ from . dctPeriod :: ScopedName dctPeriod = toDCT "Period" -- | @dcterms:Point@ from . dctPoint :: ScopedName dctPoint = toDCT "Point" -- | @dcterms:RFC1766@ from . dctRFC1766 :: ScopedName dctRFC1766 = toDCT "RFC1766" -- | @dcterms:RFC3066@ from . dctRFC3066 :: ScopedName dctRFC3066 = toDCT "RFC3066" -- | @dcterms:RFC4646@ from . dctRFC4646 :: ScopedName dctRFC4646 = toDCT "RFC4646" -- | @dcterms:RFC5646@ from . dctRFC5646 :: ScopedName dctRFC5646 = toDCT "RFC5646" -- | @dcterms:URI@ from . dctURI :: ScopedName dctURI = toDCT "URI" -- | @dcterms:W3CDTF@ from . dctW3CDTF :: ScopedName dctW3CDTF = toDCT "W3CDTF" -- | @dcam:memberOf@ from . dcammemberOf :: ScopedName dcammemberOf = toDCAM "memberOf" -- | @dcam:memberOf@ from . dcamVocabularyEncodingScheme :: ScopedName dcamVocabularyEncodingScheme = toDCAM "VocabularyEncodingScheme" -- | @dctype:Collection@ from . dctypeCollection :: ScopedName dctypeCollection = toDCTYPE "Collection" -- | @dctype:Dataset@ from . dctypeDataset :: ScopedName dctypeDataset = toDCTYPE "Dataset" -- | @dctype:Event@ from . dctypeEvent :: ScopedName dctypeEvent = toDCTYPE "Event" -- | @dctype:Image@ from . dctypeImage :: ScopedName dctypeImage = toDCTYPE "Image" -- | @dctype:InteractiveResource@ from . dctypeInteractiveResource :: ScopedName dctypeInteractiveResource = toDCTYPE "InteractiveResource" -- | @dctype:Service@ from . dctypeService :: ScopedName dctypeService = toDCTYPE "Service" -- | @dctype:Software@ from . dctypeSoftware :: ScopedName dctypeSoftware = toDCTYPE "Software" -- | @dctype:Sound@ from . dctypeSound :: ScopedName dctypeSound = toDCTYPE "Sound" -- | @dctype:Text@ from . dctypeText :: ScopedName dctypeText = toDCTYPE "Text" -- | @dctype:PhysicalObject@ from . dctypePhysicalObject :: ScopedName dctypePhysicalObject = toDCTYPE "PhysicalObject" -- | @dctype:StillImage@ from . dctypeStillImage :: ScopedName dctypeStillImage = toDCTYPE "StillImage" -- | @dctype:MovingImage@ from . dctypeMovingImage :: ScopedName dctypeMovingImage = toDCTYPE "MovingImage" -- | @dcterms:LCSH@ from . dctLCSH :: ScopedName dctLCSH = toDCT "LCSH" -- | @dcterms:MESH@ from . dctMESH :: ScopedName dctMESH = toDCT "MESH" -- | @dcterms:DDC@ from . dctDDC :: ScopedName dctDDC = toDCT "DDC" -- | @dcterms:LCC@ from . dctLCC :: ScopedName dctLCC = toDCT "LCC" -- | @dcterms:UDC@ from . dctUDC :: ScopedName dctUDC = toDCT "UDC" -- | @dcterms:DCMIType@ from . dctDCMIType :: ScopedName dctDCMIType = toDCT "DCMIType" -- | @dcterms:IMT@ from . dctIMT :: ScopedName dctIMT = toDCT "IMT" -- | @dcterms:TGN@ from . dctTGN :: ScopedName dctTGN = toDCT "TGN" -- | @dcterms:NLM@ from . dctNLM :: ScopedName dctNLM = toDCT "NLM" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/FOAF.hs0000644000000000000000000003523713543702315016747 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.FOAF -- Copyright : (c) 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines some commonly used vocabulary terms from the FOAF -- vocabulary (). -- -- Note that unlike some of the existing vocabularies in Swish, the FOAF -- one matches the case and spelling of the RDF terms; so we -- use 'foafbased_near' -- rather than @foafBasedNear@. This is partly because some terms would -- end up with the same Haskell label if a conversion to camel-case wer -- used. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.FOAF ( -- | The version used for this module is -- \"FOAF Vocabulary Specification 0.98 Namespace Document 9 August 2010 - /Marco Polo Edition/\", -- . namespaceFOAF -- * Classes , foafAgent , foafDocument , foafGroup , foafImage , foafLabelProperty , foafOnlineAccount , foafOnlineChatAccount , foafOnlineEcommerceAccount , foafOnlineGamingAccount , foafOrganization , foafPerson , foafPersonalProfileDocument , foafProject -- * Properties , foafaccount , foafaccountName , foafaccountServiceHomepage , foafage , foafaimChatID , foafbased_near , foafbirthday , foafcurrentProject , foafdepiction , foafdepicts , foafdnaChecksum , foaffamilyName , foaffamily_name , foaffirstName , foaffocus , foaffundedBy , foafgeekcode , foafgender , foafgivenName , foafgivenname , foafholdsAccount , foafhomepage , foaficqChatID , foafimg , foafinterest , foafisPrimaryTopicOf , foafjabberID , foafknows , foaflastName , foaflogo , foafmade , foafmaker , foafmbox , foafmbox_sha1sum , foafmember , foafmembershipClass , foafmsnChatID , foafmyersBriggs , foafname , foafnick , foafopenid , foafpage , foafpastProject , foafphone , foafplan , foafprimaryTopic , foafpublications , foafschoolHomepage , foafsha1 , foafskypeID , foafstatus , foafsurname , foaftheme , foafthumbnail , foaftipjar , foaftitle , foaftopic , foaftopic_interest , foafweblog , foafworkInfoHomepage , foafworkplaceHomepage , foafyahooChatID ) where import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ foafURI :: URI foafURI = fromMaybe (error "Internal error processing FOAF URI") $ parseURI "http://xmlns.com/foaf/0.1/" -- | Maps @foaf@ to . namespaceFOAF :: Namespace namespaceFOAF = makeNamespace (Just "foaf") foafURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toF :: LName -> ScopedName toF = makeNSScopedName namespaceFOAF -- Classes -- | @foaf:Agent@ from . foafAgent :: ScopedName foafAgent = toF "Agent" -- | @foaf:Document@ from . foafDocument :: ScopedName foafDocument = toF "Document" -- | @foaf:Group@ from . foafGroup :: ScopedName foafGroup = toF "Group" -- | @foaf:Image@ from . foafImage :: ScopedName foafImage = toF "Image" -- | @foaf:LabelProperty@ from . foafLabelProperty :: ScopedName foafLabelProperty = toF "LabelProperty" -- | @foaf:OnlineAccount@ from . foafOnlineAccount :: ScopedName foafOnlineAccount = toF "OnlineAccount" -- | @foaf:OnlineChatAccount@ from . foafOnlineChatAccount :: ScopedName foafOnlineChatAccount = toF "OnlineChatAccount" -- | @foaf:OnlineEcommerceAccount@ from . foafOnlineEcommerceAccount :: ScopedName foafOnlineEcommerceAccount = toF "OnlineEcommerceAccount" -- | @foaf:OnlineGamingAccount@ from . foafOnlineGamingAccount :: ScopedName foafOnlineGamingAccount = toF "OnlineGamingAccount" -- | @foaf:Organization@ from . foafOrganization :: ScopedName foafOrganization = toF "Organization" -- | @foaf:Person@ from . foafPerson :: ScopedName foafPerson = toF "Person" -- | @foaf:PersonalProfileDocument@ from . foafPersonalProfileDocument :: ScopedName foafPersonalProfileDocument = toF "PersonalProfileDocument" -- | @foaf:Project@ from . foafProject :: ScopedName foafProject = toF "Project" -- Properties -- | @foaf:account@ from . foafaccount :: ScopedName foafaccount = toF "account" -- | @foaf:accountName@ from . foafaccountName :: ScopedName foafaccountName = toF "accountName" -- | @foaf:accountServiceHomepage@ from . foafaccountServiceHomepage :: ScopedName foafaccountServiceHomepage = toF "accountServiceHomepage" -- | @foaf:age@ from . foafage :: ScopedName foafage = toF "age" -- | @foaf:aimChatID@ from . foafaimChatID :: ScopedName foafaimChatID = toF "aimChatID" -- | @foaf:based_near@ from . foafbased_near :: ScopedName foafbased_near = toF "based_near" -- | @foaf:birthday@ from . foafbirthday :: ScopedName foafbirthday = toF "birthday" -- | @foaf:currentProject@ from . foafcurrentProject :: ScopedName foafcurrentProject = toF "currentProject" -- | @foaf:depiction@ from . foafdepiction :: ScopedName foafdepiction = toF "depiction" -- | @foaf:depicts@ from . foafdepicts :: ScopedName foafdepicts = toF "depicts" -- | @foaf:dnaChecksum@ from . foafdnaChecksum :: ScopedName foafdnaChecksum = toF "dnaChecksum" -- | @foaf:familyName@ from . foaffamilyName :: ScopedName foaffamilyName = toF "familyName" -- | @foaf:family_name@ from . foaffamily_name :: ScopedName foaffamily_name = toF "family_name" -- | @foaf:firstName@ from . foaffirstName :: ScopedName foaffirstName = toF "firstName" -- | @foaf:focus@ from . foaffocus :: ScopedName foaffocus = toF "focus" -- | @foaf:fundedBy@ from . foaffundedBy :: ScopedName foaffundedBy = toF "fundedBy" -- | @foaf:geekcode@ from . foafgeekcode :: ScopedName foafgeekcode = toF "geekcode" -- | @foaf:gender@ from . foafgender :: ScopedName foafgender = toF "gender" -- | @foaf:givenName@ from . foafgivenName :: ScopedName foafgivenName = toF "givenName" -- | @foaf:givenname@ from . foafgivenname :: ScopedName foafgivenname = toF "givenname" -- | @foaf:holdsAccount@ from . foafholdsAccount :: ScopedName foafholdsAccount = toF "holdsAccount" -- | @foaf:homepage@ from . foafhomepage :: ScopedName foafhomepage = toF "homepage" -- | @foaf:icqChatID@ from . foaficqChatID :: ScopedName foaficqChatID = toF "icqChatID" -- | @foaf:img@ from . foafimg :: ScopedName foafimg = toF "img" -- | @foaf:interest@ from . foafinterest :: ScopedName foafinterest = toF "interest" -- | @foaf:isPrimaryTopicOf@ from . foafisPrimaryTopicOf :: ScopedName foafisPrimaryTopicOf = toF "isPrimaryTopicOf" -- | @foaf:jabberID@ from . foafjabberID :: ScopedName foafjabberID = toF "jabberID" -- | @foaf:knows@ from . foafknows :: ScopedName foafknows = toF "knows" -- | @foaf:lastName@ from . foaflastName :: ScopedName foaflastName = toF "lastName" -- | @foaf:logo@ from . foaflogo :: ScopedName foaflogo = toF "logo" -- | @foaf:made@ from . foafmade :: ScopedName foafmade = toF "made" -- | @foaf:maker@ from . foafmaker :: ScopedName foafmaker = toF "maker" -- | @foaf:mbox@ from . foafmbox :: ScopedName foafmbox = toF "mbox" -- | @foaf:mbox_sha1sum@ from . foafmbox_sha1sum :: ScopedName foafmbox_sha1sum = toF "mbox_sha1sum" -- | @foaf:member@ from . foafmember :: ScopedName foafmember = toF "member" -- | @foaf:membershipClass@ from . foafmembershipClass :: ScopedName foafmembershipClass = toF "membershipClass" -- | @foaf:msnChatID@ from . foafmsnChatID :: ScopedName foafmsnChatID = toF "msnChatID" -- | @foaf:myersBriggs@ from . foafmyersBriggs :: ScopedName foafmyersBriggs = toF "myersBriggs" -- | @foaf:name@ from . foafname :: ScopedName foafname = toF "name" -- | @foaf:nick@ from . foafnick :: ScopedName foafnick = toF "nick" -- | @foaf:openid@ from . foafopenid :: ScopedName foafopenid = toF "openid" -- | @foaf:page@ from . foafpage :: ScopedName foafpage = toF "page" -- | @foaf:pastProject@ from . foafpastProject :: ScopedName foafpastProject = toF "pastProject" -- | @foaf:phone@ from . foafphone :: ScopedName foafphone = toF "phone" -- | @foaf:plan@ from . foafplan :: ScopedName foafplan = toF "plan" -- | @foaf:primaryTopic@ from . foafprimaryTopic :: ScopedName foafprimaryTopic = toF "primaryTopic" -- | @foaf:publications@ from . foafpublications :: ScopedName foafpublications = toF "publications" -- | @foaf:schoolHomepage@ from . foafschoolHomepage :: ScopedName foafschoolHomepage = toF "schoolHomepage" -- | @foaf:sha1@ from . foafsha1 :: ScopedName foafsha1 = toF "sha1" -- | @foaf:skypeID@ from . foafskypeID :: ScopedName foafskypeID = toF "skypeID" -- | @foaf:status@ from . foafstatus :: ScopedName foafstatus = toF "status" -- | @foaf:surname@ from . foafsurname :: ScopedName foafsurname = toF "surname" -- | @foaf:theme@ from . foaftheme :: ScopedName foaftheme = toF "theme" -- | @foaf:thumbnail@ from . foafthumbnail :: ScopedName foafthumbnail = toF "thumbnail" -- | @foaf:tipjar@ from . foaftipjar :: ScopedName foaftipjar = toF "tipjar" -- | @foaf:title@ from . foaftitle :: ScopedName foaftitle = toF "title" -- | @foaf:topic@ from . foaftopic :: ScopedName foaftopic = toF "topic" -- | @foaf:topic_interest@ from . foaftopic_interest :: ScopedName foaftopic_interest = toF "topic_interest" -- | @foaf:weblog@ from . foafweblog :: ScopedName foafweblog = toF "weblog" -- | @foaf:workInfoHomepage@ from . foafworkInfoHomepage :: ScopedName foafworkInfoHomepage = toF "workInfoHomepage" -- | @foaf:workplaceHomepage@ from . foafworkplaceHomepage :: ScopedName foafworkplaceHomepage = toF "workplaceHomepage" -- | @foaf:yahooChatID@ from . foafyahooChatID :: ScopedName foafyahooChatID = toF "yahooChatID" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/Geo.hs0000644000000000000000000000647213543702315016745 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.Geo -- Copyright : (c) 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines some commonly used vocabulary terms from the Geo -- vocabulary (, WGS84 Geo Positioning: an RDF vocabulary). -- -- Note that unlike some of the existing vocabularies in Swish, the Geo -- one matches the case and spelling of the RDF terms; so we -- use 'geolat' rather than @geoLat@. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.Geo ( namespaceGEO -- * Classes , geoSpatialThing , geoPoint -- * Properties , geolocation , geolat , geolong , geolat_long ) where import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ geoURI :: URI geoURI = fromMaybe (error "Internal error processing Geo URI") $ parseURI "http://www.w3.org/2003/01/geo/wgs84_pos#" -- | Maps @geo@ to . namespaceGEO :: Namespace namespaceGEO = makeNamespace (Just "geo") geoURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toG :: LName -> ScopedName toG = makeNSScopedName namespaceGEO -- | @geo:location@. geolocation :: ScopedName geolocation = toG "location" -- | @geo:lat@. geolat :: ScopedName geolat = toG "lat" -- | @geo:long@. geolong :: ScopedName geolong = toG "long" -- | @geo:lat_long@ (it is suggested that this not be used when generating RDF statements). geolat_long :: ScopedName geolat_long = toG "lat_long" -- | @geo:SpatialThing@. geoSpatialThing :: ScopedName geoSpatialThing = toG "SpatialThing" -- | @geo:Point@. geoPoint :: ScopedName geoPoint = toG "Point" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/OWL.hs0000644000000000000000000001136313543702315016667 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.OWL -- 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 vocabulary terms from the OWL vocabulary. Note that there -- is an unfortunate mixture of styles for property names - e.g. 'owlSameAs' -- and 'owlequivalentClass'. At present there is no systematic attempt to -- include terms from the vocabulary. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.OWL ( namespaceOWL , owlOntology , owlimports , owlversionInfo , owldeprecated , owlpriorVersion , owlbackwardCompatibleWith , owlincompatibleWith , owlClass , owlThing , owlNothing , owlNamedIndividual , owlSameAs , owlequivalentClass , owlequivalentProperty , owlObjectProperty , owlDatatypeProperty , owlAnnotationProperty , owlrational , owlreal ) where import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ owlURI :: URI owlURI = fromMaybe (error "Internal error processing OWL URI") $ parseURI "http://www.w3.org/2002/07/owl#" -- | Maps @owl@ to . namespaceOWL :: Namespace namespaceOWL = makeNamespace (Just "owl") owlURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toO :: LName -> ScopedName toO = makeNSScopedName namespaceOWL -- | @owl:sameAs@. owlSameAs :: ScopedName owlSameAs = toO "sameAs" -- | @owl:equivalentClass@. owlequivalentClass :: ScopedName owlequivalentClass = toO "equivalentClass" -- | @owl:equivalentProperty@. owlequivalentProperty :: ScopedName owlequivalentProperty = toO "equivalentPropery" -- | @owl:Ontology@. owlOntology :: ScopedName owlOntology = toO "Ontology" -- | @owl:imports@. owlimports :: ScopedName owlimports = toO "imports" -- | @owl:versionInfo@. owlversionInfo :: ScopedName owlversionInfo = toO "versionInfo" -- | @owl:deprecated@. owldeprecated :: ScopedName owldeprecated = toO "deprecated" -- | @owl:priorVersion@. owlpriorVersion :: ScopedName owlpriorVersion = toO "priorVersion" -- | @owl:backwartCompatibleWith@. owlbackwardCompatibleWith :: ScopedName owlbackwardCompatibleWith = toO "backwardCompatibleWith" -- | @owl:incompatibleWith@. owlincompatibleWith :: ScopedName owlincompatibleWith = toO "incompatibleWith" -- | @owl:Class@. owlClass :: ScopedName owlClass = toO "Class" -- | @owl:ObjectProperty@. owlObjectProperty :: ScopedName owlObjectProperty = toO "ObjectProperty" -- | @owl:DatatypeProperty@. owlDatatypeProperty :: ScopedName owlDatatypeProperty = toO "DatatypeProperty" -- | @owl:AnnotationProperty@. owlAnnotationProperty :: ScopedName owlAnnotationProperty = toO "AnnotationProperty" -- | @owl:NamedIndividual@. owlNamedIndividual :: ScopedName owlNamedIndividual = toO "NamedIndividual" -- | @owl:Thing@. owlThing :: ScopedName owlThing = toO "Thing" -- | @owl:Thing@. owlNothing :: ScopedName owlNothing = toO "Nothing" -- | @owl:rational@. owlrational :: ScopedName owlrational = toO "rational" -- | @owl:real@. owlreal :: ScopedName owlreal = toO "real" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/Provenance.hs0000644000000000000000000002272613543702315020333 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.Provenance -- Copyright : (c) 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines some vocabulary terms from the Provenance Ontology -- by the W3C Provenance Working Group -- (). -- This is /experimental/ since the Ontology is still a Working Draft. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.Provenance ( -- | The version used for this module is -- \"W3C Working Draft 13 December 2011\", -- . namespacePROV -- * Classes , provActivity , provAgent , provControl , provEntity , provGeneration , provLocation , provParticipation , provProvenanceContainer , provQualifiedInvolvement , provRecipe , provRole , provUsage -- * Properties , provdependedOn , provendedAt , provhadLocation , provhadOriginalSource , provhadParticipant , provhadQualifiedControl , provhadQualifiedEntity , provhadQualifiedGeneration , provhadQualifiedParticipation , provhadQualifiedUsage , provhadRecipe , provhadRole , provhadTemporalValue , provstartedAt , provused , provwasAttributedTo , provwasComplementOf , provwasControlledBy , provwasDerivedFrom , provwasEventuallyDerivedFrom , provwasGeneratedAt , provwasGeneratedBy , provwasInformedBy , provwasQuoteOf , provwasRevisionOf , provwasScheduledAfter , provwasSummaryOf ) where import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ provURI :: URI provURI = fromMaybe (error "Internal error processing PROV URI") $ parseURI "http://www.w3.org/ns/prov-o/" -- | Maps @prov@ to . namespacePROV :: Namespace namespacePROV = makeNamespace (Just "prov") provURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toS :: LName -> ScopedName toS = makeNSScopedName namespacePROV -- Classes -- | @prov:Activity@ from . provActivity :: ScopedName provActivity = toS "Activity" -- | @prov:Agent@ from . provAgent :: ScopedName provAgent = toS "Agent" -- | @prov:Control@ from . provControl :: ScopedName provControl = toS "Control" -- | @prov:Entity@ from . provEntity :: ScopedName provEntity = toS "Entity" -- | @prov:Generation@ from . provGeneration :: ScopedName provGeneration = toS "Generation" -- | @prov:Location@ from . provLocation :: ScopedName provLocation = toS "Location" -- | @prov:Participation@ from . provParticipation :: ScopedName provParticipation = toS "Participation" -- | @prov:ProvenanceContainer@ from . provProvenanceContainer :: ScopedName provProvenanceContainer = toS "ProvenanceContainer" -- | @prov:QualifiedInvolvement@ from . provQualifiedInvolvement :: ScopedName provQualifiedInvolvement = toS "QualifiedInvolvement" -- | @prov:Recipe@ from . provRecipe :: ScopedName provRecipe = toS "Recipe" -- | @prov:Role@ from . provRole :: ScopedName provRole = toS "Role" -- | @prov:Usage@ from . provUsage :: ScopedName provUsage = toS "Usage" -- Properties -- | @prov:dependedOn@ from . provdependedOn :: ScopedName provdependedOn = toS "dependedOn" -- | @prov:endedAt@ from . provendedAt :: ScopedName provendedAt = toS "endedAt" -- | @prov:hadLocation@ from . provhadLocation :: ScopedName provhadLocation = toS "hadLocation" -- | @prov:hadOriginalSource@ from . provhadOriginalSource :: ScopedName provhadOriginalSource = toS "hadOriginalSource" -- | @prov:hadParticipant@ from . provhadParticipant :: ScopedName provhadParticipant = toS "hadParticipant" -- | @prov:hadQualifiedControl@ from . provhadQualifiedControl :: ScopedName provhadQualifiedControl = toS "hadQualifiedControl" -- | @prov:hadQualifiedEntity@ from . provhadQualifiedEntity :: ScopedName provhadQualifiedEntity = toS "hadQualifiedEntity" -- | @prov:hadQualifiedGeneration@ from . provhadQualifiedGeneration :: ScopedName provhadQualifiedGeneration = toS "hadQualifiedGeneration" -- | @prov:hadQualifiedParticipation@ from . provhadQualifiedParticipation :: ScopedName provhadQualifiedParticipation = toS "hadQualifiedParticipation" -- | @prov:hadQualifiedUsage@ from . provhadQualifiedUsage :: ScopedName provhadQualifiedUsage = toS "hadQualifiedUsage" -- | @prov:hadRecipe@ from . provhadRecipe :: ScopedName provhadRecipe = toS "hadRecipe" -- | @prov:hadRole@ from . provhadRole :: ScopedName provhadRole = toS "hadRole" -- | @prov:hadTemporalValue@ from . provhadTemporalValue :: ScopedName provhadTemporalValue = toS "hadTemporalValue" -- | @prov:startedAt@ from . provstartedAt :: ScopedName provstartedAt = toS "startedAt" -- | @prov:used@ from . provused :: ScopedName provused = toS "used" -- | @prov:wasAttributedTo@ from . provwasAttributedTo :: ScopedName provwasAttributedTo = toS "wasAttributedTo" -- | @prov:wasComplementOf@ from . provwasComplementOf :: ScopedName provwasComplementOf = toS "wasComplementOf" -- | @prov:wasControlledBy@ from . provwasControlledBy :: ScopedName provwasControlledBy = toS "wasControlledBy" -- | @prov:wasDerivedFrom@ from . provwasDerivedFrom :: ScopedName provwasDerivedFrom = toS "wasDerivedFrom" -- | @prov:wasEventuallyDerivedFrom@ from . provwasEventuallyDerivedFrom :: ScopedName provwasEventuallyDerivedFrom = toS "wasEventuallyDerivedFrom" -- | @prov:wasGeneratedAt@ from . provwasGeneratedAt :: ScopedName provwasGeneratedAt = toS "wasGeneratedAt" -- | @prov:wasGeneratedBy@ from . provwasGeneratedBy :: ScopedName provwasGeneratedBy = toS "wasGeneratedBy" -- | @prov:wasInformedBy@ from . provwasInformedBy :: ScopedName provwasInformedBy = toS "wasInformedBy" -- | @prov:wasQuoteOf@ from . provwasQuoteOf :: ScopedName provwasQuoteOf = toS "wasQuoteOf" -- | @prov:wasRevisionOf@ from . provwasRevisionOf :: ScopedName provwasRevisionOf = toS "wasRevisionOf" -- | @prov:wasScheduledAfter@ from . provwasScheduledAfter :: ScopedName provwasScheduledAfter = toS "wasScheduledAfter" -- | @prov:wasSummaryOf@ from . provwasSummaryOf :: ScopedName provwasSummaryOf = toS "wasSummaryOf" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/RDF.hs0000644000000000000000000002462013543702315016641 0ustar0000000000000000{-# Language OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.RDF -- 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 commonly used vocabulary terms from the -- RDF () and -- RDF Schema () documents. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.RDF ( -- * Namespaces namespaceRDF , namespaceRDFS -- * 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. -- , rdfRDF , rdfDescription , rdfID , rdfAbout , rdfParseType , rdfResource , rdfLi , rdfNodeID , rdfDatatype , rdf1, rdf2, rdfn -- * 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. , rdfsResource , rdfsClass , rdfsLiteral , rdfsDatatype , rdfXMLLiteral , rdfProperty -- ** Properties -- -- | See the \"Properties\" section at for more information. , rdfsRange , rdfsDomain , rdfType , rdfsSubClassOf , rdfsSubPropertyOf , rdfsLabel , rdfsComment -- ** Containers -- -- | See the \"Container Classes and Properties\" section at . , rdfsContainer , rdfBag , rdfSeq , rdfAlt , rdfsContainerMembershipProperty , rdfsMember -- ** Collections -- -- | See the \"Collections\" section at . , rdfList , rdfFirst , rdfRest , rdfNil -- ** Reification Vocabulary -- -- | See the \"Reification Vocabulary\" section at . , rdfStatement , rdfSubject , rdfPredicate , rdfObject -- ** Utility Properties -- -- | See the \"Utility Properties\" section at . , rdfsSeeAlso , rdfsIsDefinedBy , rdfValue ) where import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) import Swish.QName (LName, newLName) import Data.Maybe (fromMaybe, fromJust) import Data.Word (Word32) import Network.URI (URI, parseURI) import qualified Data.Text as T ------------------------------------------------------------ -- Namespaces ------------------------------------------------------------ rdfURI, rdfsURI :: URI rdfURI = fromMaybe (error "Internal error processing RDF URI") $ parseURI "http://www.w3.org/1999/02/22-rdf-syntax-ns#" rdfsURI = fromMaybe (error "Internal error processing RDFS URI") $ parseURI "http://www.w3.org/2000/01/rdf-schema#" -- | Maps @rdf@ to . namespaceRDF :: Namespace namespaceRDF = makeNamespace (Just "rdf") rdfURI -- | Maps @rdfs@ to . namespaceRDFS :: Namespace namespaceRDFS = makeNamespace (Just "rdfs") rdfsURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toRDF, toRDFS :: LName -> ScopedName toRDF = makeNSScopedName namespaceRDF toRDFS = makeNSScopedName namespaceRDFS -- | @rdf:RDF@. rdfRDF :: ScopedName rdfRDF = toRDF "RDF" -- | @rdf:Description@. rdfDescription :: ScopedName rdfDescription = toRDF "Description" -- | @rdf:datatype@. rdfDatatype :: ScopedName rdfDatatype = toRDF "datatype" -- | @rdf:resource@. rdfResource :: ScopedName rdfResource = toRDF "resource" -- | @rdf:about@. rdfAbout :: ScopedName rdfAbout = toRDF "about" -- | @rdf:ID@. rdfID :: ScopedName rdfID = toRDF "ID" -- | @rdf:parseType@. rdfParseType :: ScopedName rdfParseType = toRDF "parseType" -- | @rdf:li@. rdfLi :: ScopedName rdfLi = toRDF "li" -- | @rdf:nodeID@. rdfNodeID :: ScopedName rdfNodeID = toRDF "nodeID" -- | Create a @rdf:_n@ entity. -- -- 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 rdf1 = toRDF "_1" -- | @rdf:_2@. rdf2 :: ScopedName rdf2 = toRDF "_2" -- | @rdf:first@ from . rdfFirst :: ScopedName rdfFirst = toRDF "first" -- | @rdf:rest@ from . rdfRest :: ScopedName rdfRest = toRDF "rest" -- | @rdf:nil@ from . rdfNil :: ScopedName rdfNil = toRDF "nil" -- | @rdf:type@ from . rdfType :: ScopedName rdfType = toRDF "type" -- | @rdf:Property@ from . rdfProperty :: ScopedName rdfProperty = toRDF "Property" -- | @rdf:XMLLiteral@ from . rdfXMLLiteral :: ScopedName rdfXMLLiteral = toRDF "XMLLiteral" -- | @rdfs:Resource@ from . rdfsResource :: ScopedName rdfsResource = toRDFS "Resource" -- | @rdfs:Class@ from . rdfsClass :: ScopedName rdfsClass = toRDFS "Class" -- | @rdfs:Literal@ from . rdfsLiteral :: ScopedName rdfsLiteral = toRDFS "Literal" -- | @rdfs:Datatype@ from . rdfsDatatype :: ScopedName rdfsDatatype = toRDFS "Datatype" -- | @rdfs:label@ from . rdfsLabel :: ScopedName rdfsLabel = toRDFS "label" -- | @rdfs:comment@ from . rdfsComment :: ScopedName rdfsComment = toRDFS "comment" -- | @rdfs:range@ from . rdfsRange :: ScopedName rdfsRange = toRDFS "range" -- | @rdfs:domain@ from . rdfsDomain :: ScopedName rdfsDomain = toRDFS "domain" -- | @rdfs:subClassOf@ from . rdfsSubClassOf :: ScopedName rdfsSubClassOf = toRDFS "subClassOf" -- | @rdfs:subPropertyOf@ from . rdfsSubPropertyOf :: ScopedName rdfsSubPropertyOf = toRDFS "subPropertyOf" -- | @rdfs:Container@ from . rdfsContainer :: ScopedName rdfsContainer = toRDFS "Container" -- | @rdf:Bag@ from . rdfBag :: ScopedName rdfBag = toRDF "Bag" -- | @rdf:Seq@ from . rdfSeq :: ScopedName rdfSeq = toRDF "Seq" -- | @rdf:Alt@ from . rdfAlt :: ScopedName rdfAlt = toRDF "Alt" -- | @rdfs:ContainerMembershipProperty@ from . rdfsContainerMembershipProperty :: ScopedName rdfsContainerMembershipProperty = toRDFS "ContainerMembershipProperty" -- | @rdfs:member@ from . rdfsMember :: ScopedName rdfsMember = toRDFS "member" -- | @rdf:List@ from . rdfList :: ScopedName rdfList = toRDF "List" -- | @rdf:Statement@ from . rdfStatement :: ScopedName rdfStatement = toRDF "Statement" -- | @rdf:subject@ from . rdfSubject :: ScopedName rdfSubject = toRDF "subject" -- | @rdf:predicate@ from . rdfPredicate :: ScopedName rdfPredicate = toRDF "subject" -- | @rdf:object@ from . rdfObject :: ScopedName rdfObject = toRDF "object" -- | @rdfs:seeAlso@ from . rdfsSeeAlso :: ScopedName rdfsSeeAlso = toRDFS "seeAlso" -- | @rdfs:isDefinedBy@ from . rdfsIsDefinedBy :: ScopedName rdfsIsDefinedBy = toRDFS "isDefinedBy" -- | @rdf:value@ from . rdfValue :: ScopedName rdfValue = toRDF "value" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/SIOC.hs0000644000000000000000000003536413543702315016772 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.SIOC -- Copyright : (c) 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines some commonly used vocabulary terms from the SIOC -- project (). -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.SIOC ( -- | The version used for this module is Revison 1.35 of the -- \"SIOC Core Ontology Specification\", dated 25 March 2010, -- . namespaceSIOC -- * Classes , siocCommunity , siocContainer , siocForum , siocItem , siocPost , siocRole , siocSite , siocSpace , siocThread , siocUserAccount , siocUsergroup -- * Properties , siocabout , siocaccount_of , siocaddressed_to , siocadministrator_of , siocattachment , siocavatar , sioccontainer_of , sioccontent , sioccreator_of , siocearlier_version , siocemail , siocemail_sha1 , siocembeds_knowledge , siocfeed , siocfollows , siocfunction_of , siochas_administrator , siochas_container , siochas_creator , siochas_discussion , siochas_function , siochas_host , siochas_member , siochas_moderator , siochas_modifier , siochas_owner , siochas_parent , siochas_reply , siochas_scope , siochas_space , siochas_subscriber , siochas_usergroup , siochost_of , siocid , siocip_address , sioclast_activity_date , sioclast_item_date , sioclast_reply_date , sioclater_version , sioclatest_version , sioclink , sioclinks_to , siocmember_of , siocmoderator_of , siocmodifier_of , siocname , siocnext_by_date , siocnext_version , siocnote , siocnum_authors , siocnum_items , siocnum_replies , siocnum_threads , siocnum_views , siocowner_of , siocparent_of , siocprevious_by_date , siocprevious_version , siocrelated_to , siocreply_of , siocscope_of , siocsibling , siocspace_of , siocsubscriber_of , sioctopic , siocusergroup_of ) where import Swish.Namespace (Namespace, makeNamespace, ScopedName, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ siocURI :: URI siocURI = fromMaybe (error "Internal error processing SIOC URI") $ parseURI "http://rdfs.org/sioc/ns#" -- | Maps @sioc@ to . namespaceSIOC :: Namespace namespaceSIOC = makeNamespace (Just "sioc") siocURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ toS :: LName -> ScopedName toS = makeNSScopedName namespaceSIOC -- Classes -- | @sioc:Community@ from . siocCommunity :: ScopedName siocCommunity = toS "Community" -- | @sioc:Container@ from . siocContainer :: ScopedName siocContainer = toS "Container" -- | @sioc:Forum@ from . siocForum :: ScopedName siocForum = toS "Forum" -- | @sioc:Item@ from . siocItem :: ScopedName siocItem = toS "Item" -- | @sioc:Post@ from . siocPost :: ScopedName siocPost = toS "Post" -- | @sioc:Role@ from . siocRole :: ScopedName siocRole = toS "Role" -- | @sioc:Site@ from . siocSite :: ScopedName siocSite = toS "Site" -- | @sioc:Space@ from . siocSpace :: ScopedName siocSpace = toS "Space" -- | @sioc:Thread@ from . siocThread :: ScopedName siocThread = toS "Thread" -- | @sioc:UserAccount@ from . siocUserAccount :: ScopedName siocUserAccount = toS "UserAccount" -- | @sioc:Usergroup@ from . siocUsergroup :: ScopedName siocUsergroup = toS "Usergroup" -- Properties -- | @sioc:about@ from . siocabout :: ScopedName siocabout = toS "about" -- | @sioc:account_of@ from . siocaccount_of :: ScopedName siocaccount_of = toS "account_of" -- | @sioc:addressed_to@ from . siocaddressed_to :: ScopedName siocaddressed_to = toS "addressed_to" -- | @sioc:administrator_of@ from . siocadministrator_of :: ScopedName siocadministrator_of = toS "administrator_of" -- | @sioc:attachment@ from . siocattachment :: ScopedName siocattachment = toS "attachment" -- | @sioc:avatar@ from . siocavatar :: ScopedName siocavatar = toS "avatar" -- | @sioc:container_of@ from . sioccontainer_of :: ScopedName sioccontainer_of = toS "container_of" -- | @sioc:content@ from . sioccontent :: ScopedName sioccontent = toS "content" -- | @sioc:creator_of@ from . sioccreator_of :: ScopedName sioccreator_of = toS "creator_of" -- | @sioc:earlier_version@ from . siocearlier_version :: ScopedName siocearlier_version = toS "earlier_version" -- | @sioc:email@ from . siocemail :: ScopedName siocemail = toS "email" -- | @sioc:email_sha1@ from . siocemail_sha1 :: ScopedName siocemail_sha1 = toS "email_sha1" -- | @sioc:embeds_knowledge@ from . siocembeds_knowledge :: ScopedName siocembeds_knowledge = toS "embeds_knowledge" -- | @sioc:feed@ from . siocfeed :: ScopedName siocfeed = toS "feed" -- | @sioc:follows@ from . siocfollows :: ScopedName siocfollows = toS "follows" -- | @sioc:function_of@ from . siocfunction_of :: ScopedName siocfunction_of = toS "function_of" -- | @sioc:has_administrator@ from . siochas_administrator :: ScopedName siochas_administrator = toS "has_administrator" -- | @sioc:has_container@ from . siochas_container :: ScopedName siochas_container = toS "has_container" -- | @sioc:has_creator@ from . siochas_creator :: ScopedName siochas_creator = toS "has_creator" -- | @sioc:has_discussion@ from . siochas_discussion :: ScopedName siochas_discussion = toS "has_discussion" -- | @sioc:has_function@ from . siochas_function :: ScopedName siochas_function = toS "has_function" -- | @sioc:has_host@ from . siochas_host :: ScopedName siochas_host = toS "has_host" -- | @sioc:has_member@ from . siochas_member :: ScopedName siochas_member = toS "has_member" -- | @sioc:has_moderator@ from . siochas_moderator :: ScopedName siochas_moderator = toS "has_moderator" -- | @sioc:has_modifier@ from . siochas_modifier :: ScopedName siochas_modifier = toS "has_modifier" -- | @sioc:has_owner@ from . siochas_owner :: ScopedName siochas_owner = toS "has_owner" -- | @sioc:has_parent@ from . siochas_parent :: ScopedName siochas_parent = toS "has_parent" -- | @sioc:has_reply@ from . siochas_reply :: ScopedName siochas_reply = toS "has_reply" -- | @sioc:has_scope@ from . siochas_scope :: ScopedName siochas_scope = toS "has_scope" -- | @sioc:has_space@ from . siochas_space :: ScopedName siochas_space = toS "has_space" -- | @sioc:has_subscriber@ from . siochas_subscriber :: ScopedName siochas_subscriber = toS "has_subscriber" -- | @sioc:has_usergroup@ from . siochas_usergroup :: ScopedName siochas_usergroup = toS "has_usergroup" -- | @sioc:host_of@ from . siochost_of :: ScopedName siochost_of = toS "host_of" -- | @sioc:id@ from . siocid :: ScopedName siocid = toS "id" -- | @sioc:ip_address@ from . siocip_address :: ScopedName siocip_address = toS "ip_address" -- | @sioc:last_activity_date@ from . sioclast_activity_date :: ScopedName sioclast_activity_date = toS "last_activity_date" -- | @sioc:last_item_date@ from . sioclast_item_date :: ScopedName sioclast_item_date = toS "last_item_date" -- | @sioc:last_reply_date@ from . sioclast_reply_date :: ScopedName sioclast_reply_date = toS "last_reply_date" -- | @sioc:later_version@ from . sioclater_version :: ScopedName sioclater_version = toS "later_version" -- | @sioc:latest_version@ from . sioclatest_version :: ScopedName sioclatest_version = toS "latest_version" -- | @sioc:link@ from . sioclink :: ScopedName sioclink = toS "link" -- | @sioc:links_to@ from . sioclinks_to :: ScopedName sioclinks_to = toS "links_to" -- | @sioc:member_of@ from . siocmember_of :: ScopedName siocmember_of = toS "member_of" -- | @sioc:moderator_of@ from . siocmoderator_of :: ScopedName siocmoderator_of = toS "moderator_of" -- | @sioc:modifier_of@ from . siocmodifier_of :: ScopedName siocmodifier_of = toS "modifier_of" -- | @sioc:name@ from . siocname :: ScopedName siocname = toS "name" -- | @sioc:next_by_date@ from . siocnext_by_date :: ScopedName siocnext_by_date = toS "next_by_date" -- | @sioc:next_version@ from . siocnext_version :: ScopedName siocnext_version = toS "next_version" -- | @sioc:note@ from . siocnote :: ScopedName siocnote = toS "note" -- | @sioc:num_authors@ from . siocnum_authors :: ScopedName siocnum_authors = toS "num_authors" -- | @sioc:num_items@ from . siocnum_items :: ScopedName siocnum_items = toS "num_items" -- | @sioc:num_replies@ from . siocnum_replies :: ScopedName siocnum_replies = toS "num_replies" -- | @sioc:num_threads@ from . siocnum_threads :: ScopedName siocnum_threads = toS "num_threads" -- | @sioc:num_views@ from . siocnum_views :: ScopedName siocnum_views = toS "num_views" -- | @sioc:owner_of@ from . siocowner_of :: ScopedName siocowner_of = toS "owner_of" -- | @sioc:parent_of@ from . siocparent_of :: ScopedName siocparent_of = toS "parent_of" -- | @sioc:previous_by_date@ from . siocprevious_by_date :: ScopedName siocprevious_by_date = toS "previous_by_date" -- | @sioc:previous_version@ from . siocprevious_version :: ScopedName siocprevious_version = toS "previous_version" -- | @sioc:related_to@ from . siocrelated_to :: ScopedName siocrelated_to = toS "related_to" -- | @sioc:reply_of@ from . siocreply_of :: ScopedName siocreply_of = toS "reply_of" -- | @sioc:scope_of@ from . siocscope_of :: ScopedName siocscope_of = toS "scope_of" -- | @sioc:sibling@ from . siocsibling :: ScopedName siocsibling = toS "sibling" -- | @sioc:space_of@ from . siocspace_of :: ScopedName siocspace_of = toS "space_of" -- | @sioc:subscriber_of@ from . siocsubscriber_of :: ScopedName siocsubscriber_of = toS "subscriber_of" -- | @sioc:topic@ from . sioctopic :: ScopedName sioctopic = toS "topic" -- | @sioc:usergroup_of@ from . siocusergroup_of :: ScopedName siocusergroup_of = toS "usergroup_of" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Vocabulary/XSD.hs0000644000000000000000000001465713543702315016675 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Swish.RDF.Vocabulary.XSD -- Copyright : (c) 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines vocabulary terms from the XSD document. -- -------------------------------------------------------------------------------- module Swish.RDF.Vocabulary.XSD ( namespaceXSD -- * XSD data types -- -- | See the XSD Schema Part 2 documentation at ; -- the version used is \"W3C Recommendation 28 October 2004\", -- . , xsdType -- ** Primitive datatypes -- -- | See the section \"Primitive datatypes\" at -- . , xsdString , xsdBoolean , xsdDecimal , xsdFloat , xsdDouble , xsdDateTime , xsdTime , xsdDate , xsdAnyURI -- ** Derived datatypes -- -- | See the section \"Derived datatypes\" at -- . , xsdInteger , xsdNonPosInteger , xsdNegInteger , xsdLong , xsdInt , xsdShort , xsdByte , xsdNonNegInteger , xsdUnsignedLong , xsdUnsignedInt , xsdUnsignedShort , xsdUnsignedByte , xsdPosInteger ) where import Swish.Namespace (Namespace, ScopedName, makeNamespace, makeNSScopedName) import Swish.QName (LName) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURI) ------------------------------------------------------------ -- Namespace ------------------------------------------------------------ xsdURI :: URI xsdURI = fromMaybe (error "Internal error processing XSD URI") $ parseURI "http://www.w3.org/2001/XMLSchema#" -- | Maps @xsd@ to . namespaceXSD :: Namespace namespaceXSD = makeNamespace (Just "xsd") xsdURI ------------------------------------------------------------ -- Terms ------------------------------------------------------------ -- | Create a scoped name for an XSD datatype with the given name. xsdType :: LName -> ScopedName xsdType = makeNSScopedName namespaceXSD -- | @xsd:string@ from . xsdString :: ScopedName xsdString = xsdType "string" -- | @xsd:boolean@ from . xsdBoolean :: ScopedName xsdBoolean = xsdType "boolean" -- | @xsd:decimal@ from . xsdDecimal :: ScopedName xsdDecimal = xsdType "decimal" -- | @xsd:integer@ from . xsdInteger :: ScopedName xsdInteger = xsdType "integer" -- | @xsd:nonNegativeInteger@ from . xsdNonNegInteger :: ScopedName xsdNonNegInteger = xsdType "nonNegativeInteger" -- | @xsd:nonPositiveInteger@ from . xsdNonPosInteger :: ScopedName xsdNonPosInteger = xsdType "nonPositiveInteger" -- | @xsd:positiveInteger@ from . xsdPosInteger :: ScopedName xsdPosInteger = xsdType "positiveInteger" -- | @xsd:negativeInteger@ from . xsdNegInteger :: ScopedName xsdNegInteger = xsdType "negativeInteger" -- | @xsd:float@ from . xsdFloat :: ScopedName xsdFloat = xsdType "float" -- | @xsd:double@ from . xsdDouble :: ScopedName xsdDouble = xsdType "double" -- | @xsd:long@ from . xsdLong :: ScopedName xsdLong = xsdType "long" -- | @xsd:int@ from . xsdInt :: ScopedName xsdInt = xsdType "int" -- | @xsd:short@ from . xsdShort :: ScopedName xsdShort = xsdType "short" -- | @xsd:byte@ from . xsdByte :: ScopedName xsdByte = xsdType "byte" -- | @xsd:unsignedLong@ from . xsdUnsignedLong :: ScopedName xsdUnsignedLong = xsdType "unsignedLong" -- | @xsd:unsignedInt@ from . xsdUnsignedInt :: ScopedName xsdUnsignedInt = xsdType "unsignedInt" -- | @xsd:unsignedShort@ from . xsdUnsignedShort :: ScopedName xsdUnsignedShort = xsdType "unsignedShort" -- | @xsd:unsignedByte@ from . xsdUnsignedByte :: ScopedName xsdUnsignedByte = xsdType "unsignedByte" -- | @xsd:date@ from . xsdDate :: ScopedName xsdDate = xsdType "date" -- | @xsd:dateTime@ from . xsdDateTime :: ScopedName xsdDateTime = xsdType "dateTime" -- | @xsd:time@ from . xsdTime :: ScopedName xsdTime = xsdType "time" -- | @xsd:anyURI@ from . xsdAnyURI :: ScopedName xsdAnyURI = xsdType "anyURI" -------------------------------------------------------------------------------- -- -- Copyright (c) 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Rule.hs0000644000000000000000000002100114220136201014365 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Rule -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies, 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.Maybe (fromJust) import Data.String.ShowLines (ShowLines(..)) import Network.URI (URI, parseURI) import qualified Data.Map as M ------------------------------------------------------------ -- 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 #if (__GLASGOW_HASKELL__ >= 802) stock #endif 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 -- | 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) -- | A set of rules labelled with their name. type RuleMap ex = M.Map ScopedName (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 = const [] , bwdApply = const [] , 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, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Ruleset.hs0000644000000000000000000001225413543702315015127 0ustar0000000000000000-------------------------------------------------------------------------------- -- 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 : H98 -- -- 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.Maybe (fromMaybe, listToMaybe, mapMaybe) import qualified Data.Map as M -- | 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 -- | A set of Rulesets labelled by their Namespace. type RulesetMap ex = M.Map Namespace (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 = M.lookup nam $ M.fromList $ map (\f -> (formName f, f)) (rsAxioms rset) -- | Find a named rule in a ruleset. getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) getRulesetRule nam rset = M.lookup nam $ M.fromList $ map (\r -> (ruleName r, r)) (rsRules 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) -- | 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) -- | 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Script.hs0000644000000000000000000014437614220136201014747 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- {- | Module : Script Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2014, 2018, 2020 Douglas Burke License : GPL V2 Maintainer : Douglas Burke Stability : experimental Portability : CPP, 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(..)) 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, getRulesetNamespace, 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 (flist) import Text.ParserCombinators.Poly.StateText import Control.Monad (unless, when, void) import Control.Monad.State (modify, gets, lift) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif #if MIN_VERSION_base(4, 7, 0) import Data.Functor (($>)) #endif import Network.URI (URI(..)) import qualified Control.Exception as CE import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.IO as LIO import qualified System.IO.Error as IO #if !MIN_VERSION_base(4, 7, 0) ($>) :: Functor f => f a -> b -> f b ($>) = flip (<$) #endif ------------------------------------------------------------ -- -- 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 ; ssWriteList muri gs <$> commentText } -- @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" ; ssCheckProof pn sns igf sts <$> formulaExpr } 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 $> () 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 <|> fmap (fmap formExpr) <$> formulaExpr 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 $ fmap (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 (M.insert nam gs) ; modify fgs } ssGetGraph :: ScopedName -> SwishStateIO (Either String RDFGraph) ssGetGraph nam = fmap 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 `fmap` 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 (M.insert 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) -> when (S.fromList gr1 /= S.fromList 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 -> let nr = newRule vm in modRules (M.insert (ruleName nr) nr) 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 (M.insert (getRulesetNamespace rs) 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 (M.insert (getRulesetNamespace rs) 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 (M.insert 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 (M.insert 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 = maybe fromStdin fromUri where fromStdin = Right <$> lift LIO.getContents 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, 2014, 2018, 2020 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/Utils/ListHelpers.hs0000644000000000000000000000421513543702315017040 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : ListHelpers -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -------------------------------------------------------------------------------- module Swish.Utils.ListHelpers (flist) where -- |Apply list of functions to some value, returning list of results. -- It's kind of like an converse map. -- -- This is similar to the 'ap' function in the Monad library. -- flist :: [a->b] -> a -> [b] flist fs a = map ($ a) fs {- flisttest = flist [(1*),(2*),(3*)] 5 -- [5,10,15] -} {- -- |A more generalized form of flist that works with arbitrary Monads. -- (Suggested by Derek Elkin.) fmonad :: Monad m => m (a->b) -> a -> m b fmonad fm a = do { f <- fm ; return $ f a } -} {- fmonadtest = fmonad [(1*),(2*),(3*)] 3 -- [3,6,9] -} -------------------------------------------------------------------------------- -- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/VarBinding.hs0000644000000000000000000005205514220136201015516 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : VarBinding -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2014, 2015, 2016, 2018, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, FlexibleInstances, 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. -- -------------------------------------------------------------------------------- module Swish.VarBinding ( VarBinding(..), nullVarBinding , boundVars, subBinding, makeVarBinding , applyVarBinding, joinVarBindings, addVarBinding , VarBindingModify(..), OpenVarBindingModify , openVbmName , 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 (flist) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Control.Applicative ((<$>), (<*>)) import Data.Monoid (Monoid(..), mconcat) #endif #if !(MIN_VERSION_base(4, 11, 0)) import Data.Semigroup #endif import Control.Monad (mplus) import Data.Function (on) import Data.List (find, intersect, union, (\\), foldl', permutations) import Data.Maybe (mapMaybe, fromMaybe, isJust, fromJust, listToMaybe) import Data.Ord (comparing) import qualified Data.Map as M import qualified Data.Set as S -- import Prelude ------------------------------------------------------------ -- Query variable bindings ------------------------------------------------------------ -- |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 :: S.Set (a,b) , vbNull :: Bool } -- | The Eq instance is defined as the set equivalence of the -- pairs of variables in the binding. -- instance (Ord a, Ord b) => Eq (VarBinding a b) where (==) = (==) `on` vbEnum -- | The Ord instance is defined only on the pairs of -- variables in the binding. instance (Ord a, Ord b) => Ord (VarBinding a b) where compare = comparing vbEnum -- | When combining instances, if there is an overlapping binding then -- the value from the first instance is used. instance (Ord a, Ord b) => Semigroup (VarBinding a b) where (<>) = joinVarBindings instance (Ord a, Ord b) => Monoid (VarBinding a b) where mempty = nullVarBinding #if !(MIN_VERSION_base(4, 11, 0)) mappend = (<>) #endif -- | The Show instance only displays the pairs of variables -- in the binding. -- instance (Show a, Show b) => Show (VarBinding a b) where show = show . S.toList . vbEnum -- | The null, or empty, binding maps no query variables. -- This is the 'mempty' instance of the Monoid. -- nullVarBinding :: VarBinding a b nullVarBinding = VarBinding { vbMap = const Nothing , vbEnum = S.empty , vbNull = True } -- |Return a list of the variables bound by a supplied variable binding -- -- The Ord instance on b is not needed (it was circa GHC 7.6) but is -- kept in to avoid the need to increase the minor version number. boundVars :: (Ord a, Ord b) => VarBinding a b -> S.Set a boundVars = S.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 :: (Ord a, Ord b) => VarBinding a b -> VarBinding a b -> Bool subBinding = S.isSubsetOf `on` vbEnum -- |Function to make a variable binding from a list of -- pairs of variable and corresponding assigned value. -- makeVarBinding :: (Ord a, Ord b) => [(a,b)] -> VarBinding a b makeVarBinding [] = nullVarBinding makeVarBinding vrbs = VarBinding { vbMap = flip M.lookup (M.fromList vrbs) , vbEnum = S.fromList 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. -- joinVarBindings :: (Ord a, Ord b) => VarBinding a b -> VarBinding a b -> VarBinding a b joinVarBindings vb1 vb2 | vbNull vb1 = vb2 | vbNull vb2 = vb1 | otherwise = VarBinding { vbMap = mv12 , vbEnum = S.map (\v -> (v,fromJust (mv12 v))) bv12 , vbNull = False } where mv12 n = vbMap vb1 n `mplus` vbMap vb2 n bv12 = boundVars vb1 `S.union` boundVars vb2 -- |Add a single new value to a variable binding and return the resulting -- new variable binding. -- addVarBinding :: (Ord a, Ord 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. } -- |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")) -- | Displays the name of the modifier. 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 -> maybe False vtest (vbMap vb var) } -- |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 -> Just True == (vcomp <$> vbMap vb v1 <*> vbMap vb v2) } ------------------------------------------------------------ -- 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, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/src/Swish/RDF/Formatter/Internal.hs0000644000000000000000000005636414220136201017634 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} #if (__GLASGOW_HASKELL__ >= 802) {-# LANGUAGE DerivingStrategies #-} #endif -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : Internal -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2016, 2018, 2020, 2022 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, DerivingStrategies, OverloadedStrings -- -- Utility routines. -- -------------------------------------------------------------------------------- module Swish.RDF.Formatter.Internal ( NodeGenLookupMap , SLens(..) , SubjTree , PredTree , LabelContext(..) , NodeGenState(..) , changeState , hasMore , emptyNgs , getBNodeLabel , findMaxBnode , splitOnLabel , getCollection , processArcs , findPrefix -- N3-like formatting , quoteB , quoteText , showScopedName , formatScopedName , formatPrefixLines , formatPlainLit , formatLangLit , formatTypedLit , insertList , nextLine_ , mapBlankNode_ , formatPrefixes_ , formatGraph_ , formatSubjects_ , formatProperties_ , formatObjects_ , insertBnode_ , extractList_ ) where import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B import Swish.GraphClass (Arc(..), ArcSet) import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI) import Swish.QName (getLName) import Swish.RDF.Graph (RDFGraph, RDFLabel(..), NamespaceMap) import Swish.RDF.Graph (labels, getArcs , getNamespaces , resRdfFirst, resRdfRest, resRdfNil , quote , quoteT ) import Swish.RDF.Vocabulary (LanguageTag, fromLangTag, xsdBoolean, xsdDecimal, xsdInteger, xsdDouble) import Control.Monad.State (State, get, gets, modify, put) import Data.List (foldl', groupBy, intersperse, partition) import Data.Maybe (isJust) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..), mconcat) #endif import Data.Tuple (swap) import Data.Word import Network.URI (URI) findPrefix :: URI -> M.Map a URI -> Maybe a findPrefix u = M.lookup u . M.fromList . map swap . M.assocs {- Playing around with ideas to reduce the amount of duplicated code without (for instance) deciding on one of the many lens packages available. It does not seem worth further re-factoring until we have another formatter using a turtle-like syntax (e.g. TriG http://www4.wiwiss.fu-berlin.de/bizer/trig/). -} data SLens a b = SLens (a -> b) (a -> b -> a) -- | Extract the setter. slens :: SLens a b -> a -> b -> a slens (SLens _ s) = s -- | Extract the getter. glens :: SLens a b -> a -> b glens (SLens g _) = g -- | Node name generation state information that carries through -- and is updated by nested formulae. type NodeGenLookupMap = M.Map RDFLabel Word32 {- TODO: look at using Swish.Graphpartition instead. -} type SubjTree lb = [(lb,PredTree lb)] type PredTree lb = [(lb,[lb])] -- | The context for label creation. -- data LabelContext = SubjContext | PredContext | ObjContext deriving #if (__GLASGOW_HASKELL__ >= 802) stock #endif (Eq, Show) -- | A generator for BNode labels. data NodeGenState = Ngs { nodeMap :: NodeGenLookupMap , nodeGen :: Word32 } -- | Create an empty node generator. emptyNgs :: NodeGenState emptyNgs = Ngs M.empty 0 {-| Get the label text for the blank node, creating a new one if it has not been seen before. The label text is currently _:swish where number is 1 or higher. This format may be changed in the future. -} getBNodeLabel :: RDFLabel -> NodeGenState -> (B.Builder, Maybe NodeGenState) getBNodeLabel lab ngs = let cmap = nodeMap ngs cval = nodeGen ngs (lnum, mngs) = case M.findWithDefault 0 lab cmap of 0 -> let nval = succ cval nmap = M.insert lab nval cmap in (nval, Just (ngs { nodeGen = nval, nodeMap = nmap })) n -> (n, Nothing) in ("_:swish" `mappend` B.fromString (show lnum), mngs) {-| Process the state, returning a value extracted from it after updating the state. -} changeState :: (a -> (b, a)) -> State a b changeState f = do st <- get let (rval, nst) = f st put nst return rval {-| Apply the function to the state and return True if the result is not empty. -} hasMore :: (a -> [b]) -> State a Bool hasMore lens = gets (not . null . lens) {-| 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 {-| 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], []) <- removeItem pList2 resRdfRest go sl' pNext (pFirst : cs, l : ss) ---------------------------------------------------------------------- -- Graph-related helper functions ---------------------------------------------------------------------- -- partiton up the graph; should this be replaced by Swish.GraphPartition? -- Also extracts a list of bnodes in the graph -- processArcs :: RDFGraph -> (SubjTree RDFLabel, [RDFLabel]) processArcs gr = let arcs = sortArcs $ getArcs gr in (arcTree arcs, countBnodes arcs) newtype SortedArcs lb = SA [Arc lb] sortArcs :: ArcSet lb -> SortedArcs lb sortArcs = SA . S.toAscList -- 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 = S.findMax . S.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 splitOnLabel :: (Eq a) => a -> SubjTree a -> (SubjTree a, PredTree a) splitOnLabel lbl osubjs = let (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs rprops = case bsubj of [(_, rs)] -> rs _ -> [] in (rsubjs, rprops) {- Return a list of blank nodes that can not be converted to "[]" format by Turtle/N3: - any blank node that is a predicate - any blank node that is an object position multiple times - any blank node that is both a subject and object Note, really need to partition the graph since the last check means that we can not convert _:a :knows _:b . _:b :knows _:a . to _:a :knows [ :knows _:a ] . -} countBnodes :: SortedArcs RDFLabel -> [RDFLabel] countBnodes (SA as) = let -- This is only ever used if a label already exists, -- so we know that in this case the value to store is True upd _ _ = True -- Only want to process the subject after processing all the -- arcs that it is the subject of. It could be included into -- procPO by passing around the previous subject and processing -- it when it changes, but separate out for now. procPO oMap (Arc _ p o) = addNode False o $ addNode True p oMap procS oMap s = addNode False s oMap -- Take advantage of the fact that the arcs are sorted -- isBlank (Blank _) = True isBlank _ = False subjects = S.filter isBlank $ S.fromList $ map arcSubj as -- not bothering about lazy/strict insert here addNode f l@(Blank _) m = M.insertWith upd l f m addNode _ _ m = m map1 = foldl' procPO M.empty as map2 = S.foldl' procS map1 subjects in M.keys $ M.filter id map2 -- N3-like output -- temporary conversion, also note that it is not obvious that all -- the uses of quoteB are valid (e.g. when formatting a URL for use -- in a prefix statement). TODO: review -- quoteB :: Bool -> String -> B.Builder quoteB f v = B.fromString $ quote f v -- Force the "basic" display, that is act as if it is to be -- surrounded by "...". quoteBString :: String -> B.Builder quoteBString = quoteB True {-| 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. Turtle supports 4 ways of quoting text, (1) @\'...\'@ (2) @\'\'\'...\'\'\'@ (3) @\"...\"@ (4) @\"\"\"...\"\"\"@ where there are slightly-different constraints on @...@ for each one. At present we assume that the string is to be quoted as 3 or 4; this could be extended to allow for 1 or 2 as well. For now option 4 is only used when the contents contain a @\n@ character and does not contain @\"\"\"@. -} -- The original thinking was that a scan of the string is worthwhile -- if it avoids having to quote characters, but we always need to -- scan through to protect certain characters. -- quoteText :: T.Text -> B.Builder quoteText txt = let -- assume the magical ghc pixie will fuse all these loops -- (the docs say that T.findIndex can fuse, but that -- T.isInfixOf doesn't) hasNL = isJust $ T.findIndex (== '\n') txt hasSQ = isJust $ T.findIndex (== '"') txt has3Q = "\"\"\"" `T.isInfixOf` txt n = if has3Q || (not hasNL && not hasSQ) then 1 else 3 qch = B.fromString (replicate n '"') qst = B.fromText $ quoteT (n == 1) txt in mconcat [qch, qst, qch] -- 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 = quoteBString . show formatScopedName :: ScopedName -> M.Map (Maybe T.Text) URI -> B.Builder formatScopedName sn prmap = let nsuri = getScopeURI sn local = getLName $ getScopeLocal sn in case findPrefix nsuri prmap of Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] _ -> mconcat [ "<" , quoteBString (show nsuri ++ T.unpack local) , ">" ] formatPlainLit :: T.Text -> B.Builder formatPlainLit = quoteText formatLangLit :: T.Text -> LanguageTag -> B.Builder formatLangLit lit lcode = mconcat [quoteText lit, "@", B.fromText (fromLangTag lcode)] -- 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. -- -- However, I am moving away from storing a canonical representation -- of a datatyped literal in the resource since it is messy and makes -- some comparisons difficult, in particular for the W3C Turtle test -- suite [I think] (unless equality of RDFLabels is made dependent on -- types, and then it gets messy). I am also not as concerned about -- issues in the N3 parser/formatter as in the Turtle one. -- formatTypedLit :: Bool -> T.Text -> ScopedName -> B.Builder formatTypedLit n3flag lit dtype | dtype == xsdDouble = B.fromText $ if n3flag then T.toLower lit else lit | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = B.fromText lit | otherwise = mconcat [quoteText lit, "^^", showScopedName dtype] {- 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 -> State a B.Builder) -> [RDFLabel] -> State a B.Builder insertList _ [] = return "()" -- QUS: can this happen in a valid graph? insertList f xs = do ls <- mapM f xs return $ mconcat ("( " : intersperse " " ls) `mappend` " )" nextLine_ :: (a -> B.Builder) -- ^ indentation -> SLens a Bool -- ^ line break lens -> B.Builder -> State a B.Builder nextLine_ indent _lineBreak str = do ind <- gets indent brk <- gets $ glens _lineBreak if brk then return $ ind `mappend` str else do -- After first line, always insert line break modify $ \st -> slens _lineBreak st True return str mapBlankNode_ :: SLens a NodeGenState -> RDFLabel -> State a B.Builder mapBlankNode_ _nodeGen lab = do ngs <- gets $ glens _nodeGen let (lval, mngs) = getBNodeLabel lab ngs case mngs of Just ngs' -> modify $ \st -> slens _nodeGen st ngs' _ -> return () return lval formatPrefixLines :: NamespaceMap -> [B.Builder] formatPrefixLines = map pref . M.assocs where pref (Just p,u) = mconcat ["@prefix ", B.fromText p, ": <", quoteBString (show u), "> ."] pref (_,u) = mconcat ["@prefix : <", quoteBString (show u), "> ."] formatPrefixes_ :: (B.Builder -> State a B.Builder) -- ^ Create a new line -> NamespaceMap -> State a B.Builder formatPrefixes_ nextLine pmap = mconcat `fmap` mapM nextLine (formatPrefixLines pmap) formatGraph_ :: (B.Builder -> State a ()) -- set indent -> (Bool -> State a ()) -- set line-break flag -> (RDFGraph -> a -> a) -- create a new state from the graph -> (NamespaceMap -> State a B.Builder) -- format prefixes -> (a -> SubjTree RDFLabel) -- get the subjects -> State a B.Builder -- format the subjects -> 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 -> State a B.Builder formatGraph_ setIndent setLineBreak newState formatPrefixes subjs formatSubjects ind end dobreak dopref gr = do setIndent ind setLineBreak dobreak modify (newState gr) fp <- if dopref then formatPrefixes (getNamespaces gr) else return mempty more <- hasMore subjs if more then do fr <- formatSubjects return $ mconcat [fp, fr, end] else return fp formatSubjects_ :: State a RDFLabel -- ^ next subject -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ convert label into text -> (a -> PredTree RDFLabel) -- ^ extract properties -> (RDFLabel -> B.Builder -> State a B.Builder) -- ^ format properties -> (a -> SubjTree RDFLabel) -- ^ extract subjects -> (B.Builder -> State a B.Builder) -- ^ next line -> State a B.Builder formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine = do sb <- nextSubject sbstr <- formatLabel SubjContext sb flagP <- hasMore props if flagP then do prstr <- formatProperties sb sbstr flagS <- hasMore subjs if flagS then do fr <- formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine return $ mconcat [prstr, " .", fr] else return prstr else do txt <- nextLine sbstr flagS <- hasMore subjs if flagS then do fr <- formatSubjects_ nextSubject formatLabel props formatProperties subjs nextLine 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 -> State a RDFLabel) -- ^ next property for the given subject -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ convert label into text -> (RDFLabel -> RDFLabel -> B.Builder -> State a B.Builder) -- ^ format objects -> (a -> PredTree RDFLabel) -- ^ extract properties -> (B.Builder -> State a B.Builder) -- ^ next line -> RDFLabel -- ^ property being processed -> B.Builder -- ^ current output -> State a B.Builder formatProperties_ nextProperty formatLabel formatObjects props nextLine sb sbstr = do pr <- nextProperty sb prstr <- formatLabel PredContext pr obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] more <- hasMore props let sbindent = hackIndent -- mkIndent sbstr if more then do fr <- formatProperties_ nextProperty formatLabel formatObjects props nextLine sb sbindent nl <- nextLine $ obstr `mappend` " ;" return $ nl `mappend` fr else nextLine obstr formatObjects_ :: (RDFLabel -> RDFLabel -> State a RDFLabel) -- ^ get the next object for the (subject,property) pair -> (LabelContext -> RDFLabel -> State a B.Builder) -- ^ format a label -> (a -> [RDFLabel]) -- ^ extract objects -> (B.Builder -> State a B.Builder) -- ^ insert a new line -> RDFLabel -- ^ subject -> RDFLabel -- ^ property -> B.Builder -- ^ current text -> State a B.Builder formatObjects_ nextObject formatLabel objs nextLine sb pr prstr = do ob <- nextObject sb pr obstr <- formatLabel ObjContext ob more <- hasMore objs if more then do let prindent = hackIndent -- mkIndent prstr fr <- formatObjects_ nextObject formatLabel objs nextLine sb pr prindent nl <- nextLine $ mconcat [prstr, " ", obstr, ","] return $ nl `mappend` fr else return $ mconcat [prstr, " ", obstr] {- Processing a Bnode when not a subject. -} insertBnode_ :: (a -> SubjTree RDFLabel) -- ^ extract subjects -> (a -> PredTree RDFLabel) -- ^ extract properties -> (a -> [RDFLabel]) -- ^ extract objects -> (a -> SubjTree RDFLabel -> PredTree RDFLabel -> [RDFLabel] -> a) -- ^ update state to new settings -> (RDFLabel -> B.Builder -> State a B.Builder) -- ^ format properties -> RDFLabel -> State a B.Builder insertBnode_ subjs props objs updateState formatProperties lbl = do ost <- get let osubjs = subjs ost (rsubjs, rprops) = splitOnLabel lbl osubjs put $ updateState ost rsubjs rprops [] flag <- hasMore props txt <- if flag then (`mappend` "\n") `fmap` formatProperties lbl "" else return "" -- restore the original data (where appropriate) nst <- get let slist = map fst $ subjs nst nsubjs = filter (\(l,_) -> l `elem` slist) osubjs put $ updateState nst nsubjs (props ost) (objs ost) -- TODO: handle indentation? return $ mconcat ["[", txt, "]"] maybeExtractList :: SubjTree RDFLabel -> PredTree RDFLabel -> LabelContext -> RDFLabel -> Maybe ([RDFLabel], SubjTree RDFLabel, PredTree RDFLabel) maybeExtractList osubjs oprops lctxt ln = 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 in case mlst of Just (sl, ls, _) -> let oprops' = if lctxt == SubjContext then filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops else oprops in Just (ls, sl, oprops') _ -> Nothing extractList_ :: (a -> SubjTree RDFLabel) -- ^ extract subjects -> (a -> PredTree RDFLabel) -- ^ extract properties -> (SubjTree RDFLabel -> State a ()) -- ^ set subjects -> (PredTree RDFLabel -> State a ()) -- ^ set properties -> LabelContext -> RDFLabel -> State a (Maybe [RDFLabel]) extractList_ subjs props setSubjs setProps lctxt ln = do osubjs <- gets subjs oprops <- gets props case maybeExtractList osubjs oprops lctxt ln of Just (ls, osubjs', oprops') -> do setSubjs osubjs' setProps oprops' return (Just ls) _ -> return Nothing -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2016, 2018, 2020, 2022 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/app/RunW3CTests.hs0000644000000000000000000003022313543702315014500 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RunW3CTests -- Copyright : (c) 2013 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings, RecordWildCards -- -- Run the W3C Turtle tests using the supplied manifest file (Turtle format). -- It requires that the tests are installed locally (i.e. it will /not/ -- download from the Turtle test suite at ). -- -- Possible improvements: -- -- - add an @--enable-roundtrip@ flag which would do a round-trip test -- on all the valid files, to check the formatter as well as the parser -- (or just for those tests with a NTriples version, since that can be -- used to create the output graph, but may miss a few edge cases). -- -- - create an EARL report (), for -- . -- See also . -- -- - option to download the tests from the W3C site. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.IO as L import qualified Swish.RDF.Parser.Turtle as TTL import qualified Swish.RDF.Parser.NTriples as NT import Control.Monad (forM_) import Data.Maybe (catMaybes) import Data.Version (showVersion) import Network.URI (URI, parseURI, parseURIReference, relativeTo, uriPath, uriScheme) import Swish.RDF.Graph import Swish.Namespace (ScopedName, getScopeURI) import Swish.RDF.Query import Swish.RDF.Vocabulary.RDF (rdfType) import Swish.RDF.Vocabulary.XSD (xsdString) import System.Directory (canonicalizePath) import System.Environment import System.Exit (exitFailure, exitSuccess) import System.FilePath (splitFileName) import System.IO (hFlush, hPutStr, hPutStrLn, stderr, stdout) import Paths_swish (version) -- | The base URI for the tests. base :: Maybe URI base = parseURI "http://www.w3.org/2013/TurtleTests/" -- Could include the language type for the Parse version. -- | I have decided to treat @rdf:type rdft:TestTurtleNegativeEval@ -- tests the same as @rdf:TestTurtleNegativeSyntax@. data TestType = NTriplesParse Bool -- ^ Should the NTriples file parse successfully? | TurtleParse Bool -- ^ Should the Turtle file parse successfully? | TurtleCompare -- ^ The Turtle and NTriples files should match. _showBool :: Bool -> String _showBool True = "pass" _showBool _ = "fail" instance Show TestType where show (NTriplesParse a) = "" show (TurtleParse a) = "" show TurtleCompare = "" data Test = Test { _tName :: String , _tAction :: IO (Maybe String) -- ^ If the test fails a string reporting the error is returned. } -- | Returns the name of the test if it failed. runTest :: Test -> IO (Maybe String) runTest Test {..} = _tAction >>= \r -> hFlush stdout >> return r runTests :: [Test] -> IO () runTests ts = do putStrLn $ "Running " ++ show (length ts) ++ " tests" hFlush stdout fails <- catMaybes `fmap` mapM runTest ts putStrLn "" case fails of [] -> putStrLn "All tests passed." >> exitSuccess [f] -> hPutStrLn stderr ("One test failed: " ++ f) >> exitFailure _ -> do let nf = show $ length fails hPutStrLn stderr $ "There were " ++ nf ++ " failures:" forM_ (zip [(1::Int)..] fails) $ \(n,m) -> do hPutStr stderr $ "# [" ++ show n ++ "/" ++ nf ++ "] " hPutStrLn stderr m exitFailure mfEntries, mfName :: ScopedName mfEntries = "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#entries" mfName = "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#name" mfAction, mfResult :: ScopedName mfAction = "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#action" mfResult = "http://www.w3.org/2001/sw/DataAccess/tests/test-manifest#result" rdftTestTurtleEval, rdftTestTurtleNegativeEval, rdftTestTurtlePositiveSyntax, rdftTestTurtleNegativeSyntax :: ScopedName rdftTestTurtleEval = "http://www.w3.org/ns/rdftest#TestTurtleEval" rdftTestTurtleNegativeEval = "http://www.w3.org/ns/rdftest#TestTurtleNegativeEval" rdftTestTurtlePositiveSyntax ="http://www.w3.org/ns/rdftest#TestTurtlePositiveSyntax" rdftTestTurtleNegativeSyntax = "http://www.w3.org/ns/rdftest#TestTurtleNegativeSyntax" rdftTestNTriplesPositiveSyntax, rdftTestNTriplesNegativeSyntax :: ScopedName rdftTestNTriplesPositiveSyntax = "http://www.w3.org/ns/rdftest#rdftTestNTriplesPositiveSyntax" rdftTestNTriplesNegativeSyntax = "http://www.w3.org/ns/rdftest#rdftTestNTriplesNegativeSyntax" {- rdftApproval :: RDFLabel rdftApproval = u2L "http://www.w3.org/ns/rdftest#approval" -} -- | Extract out the object from the list of triples, -- erroring out if there is not a single match. getVal :: ScopedName -- ^ predicate to search for -> [RDFTriple] -> Either String RDFLabel -- ^ object, if found getVal p ts = let ns = filter ((== Res p) . arcPred) ts in case ns of [n] -> Right $ arcObj n [] -> Left $ "No " ++ show p ++ " predicate found" _ -> Left $ "Found multiple " ++ show p ++ " attributes" -- | Note: assuming that the literals are untyped at the moment. toString :: RDFLabel -> Either String String toString (Lit s) = Right $ T.unpack s toString (LangLit s _) = Right $ T.unpack s toString (TypedLit s dt) | dt == xsdString = Right $ T.unpack s | otherwise = Left $ "Not a string, but " ++ show dt toString v = Left $ "Not a string literal, but " ++ show v toTestType :: RDFLabel -> Either String TestType toTestType (Res r) | r == rdftTestTurtleEval = Right TurtleCompare | r == rdftTestTurtlePositiveSyntax = Right $ TurtleParse True | r == rdftTestTurtleNegativeSyntax = Right $ TurtleParse False | r == rdftTestTurtleNegativeEval = Right $ TurtleParse False | r == rdftTestNTriplesPositiveSyntax = Right $ NTriplesParse True | r == rdftTestNTriplesNegativeSyntax = Right $ NTriplesParse False | otherwise = Left $ "Unrecognized test type: " ++ show r toTestType x = Left $ "Not a resource, but " ++ show x getScheme, getPath :: ScopedName -> String getScheme = uriScheme . getScopeURI getPath = uriPath . getScopeURI toFilePath :: RDFLabel -> Either String FilePath toFilePath (Res r) | getScheme r == "file:" = Right $ getPath r | otherwise = Left $ "Not a file URL: " ++ show r toFilePath x = Left $ "Not a resource, but " ++ show x -- | Indicates that the details of the test in the manifest graph -- do not contain the required details. failedAction :: String -> IO (Maybe String) failedAction = return . Just pass :: IO (Maybe String) pass = putStrLn "[PASS]" >> return Nothing nopass :: String -> IO (Maybe String) nopass e = putStrLn "[FAIL]" >> failedAction e -- Ensure that the string ends in a space; it may exceed -- 60 characters (ASCII) wide. ljust :: String -> IO () ljust m = putStr $ m ++ replicate (59 - length m) ' ' ++ " " -- | Compare the two files. evalAction :: String -- ^ test name -> FilePath -- ^ turtle file (to test) -> FilePath -- ^ NTriples file (to compare against) -> IO (Maybe String) -- ^ If the test fpasses return @Nothing@, otherwise -- a string descibing the error evalAction name tFile nFile = do ljust $ "*** " ++ name cts1 <- L.readFile tFile cts2 <- L.readFile nFile let filename = snd $ splitFileName tFile Just frag = parseURIReference filename nbase = (frag `relativeTo`) `fmap` base let res = do tgr <- TTL.parseTurtle cts1 nbase ngr <- NT.parseNT cts2 return $ if tgr == ngr then Nothing else -- should look at Swish.Commands.swishOutputDiffs -- but that is quite involved, so just dump the -- two graphs, which should be small let f = concatMap show . S.toList . getArcs in Just $ name ++ "\nDoes not compare equal.\nExpected:\n" ++ f ngr ++ "\nTurtle:\n" ++ f tgr case res of Left e -> nopass (name ++ "\nParse failure:\n" ++ e) Right Nothing -> pass Right (Just e) -> nopass e -- | Does the file parse? -- -- TODO: should we ensure the graph is evaluated to make sure -- that laziness does not catch us out here? evalSyntaxPass :: (L.Text -> Either String a) -- ^ parser to test -> String -- ^ test name -> FilePath -- ^ turtle file (to test) -> IO (Maybe String) evalSyntaxPass parser name tFile = do ljust $ "*** " ++ name cts <- L.readFile tFile case parser cts of Left e -> nopass (name ++ "\n" ++ e) Right _ -> pass -- | Does the file fail to parse? -- -- TODO: should we ensure the graph is evaluated to make sure -- that laziness does not catch us out here? evalSyntaxFail :: (L.Text -> Either String a) -- ^ parser to test -> String -- ^ test name -> FilePath -- ^ turtle file (to test) -> IO (Maybe String) evalSyntaxFail parser name tFile = do ljust $ "*** " ++ name cts <- L.readFile tFile case parser cts of Left _ -> pass Right _ -> nopass (name ++ "\nShould not have parsed, but it did!") -- | Create a test for the given label. For now ignore the -- approved field. makeTest :: RDFGraph -> RDFLabel -> Test makeTest gr lbl = let arcs = rdfFindArcs (rdfSubjEq lbl) gr getMetaData = do testName <- getVal mfName arcs >>= toString testType <- getVal rdfType arcs >>= toTestType return (testName, testType) getAction name (NTriplesParse b) = do inFile <- getVal mfAction arcs >>= toFilePath return $ if b then evalSyntaxPass NT.parseNT name inFile else evalSyntaxFail NT.parseNT name inFile getAction name (TurtleParse b) = do inFile <- getVal mfAction arcs >>= toFilePath return $ if b then evalSyntaxPass TTL.parseTurtlefromText name inFile else evalSyntaxFail TTL.parseTurtlefromText name inFile getAction name TurtleCompare = do inFile <- getVal mfAction arcs >>= toFilePath outFile <- getVal mfResult arcs >>= toFilePath return $ evalAction name inFile outFile in case getMetaData of Left e -> Test "Failed to build test" $ failedAction $ "No test data found: " ++ e Right (n,t) -> case getAction n t of Left e -> Test n $ failedAction $ "Failed to build test " ++ n ++ ": " ++ e Right a -> Test n a makeTests :: RDFGraph -> [Test] makeTests gr = let [Arc _ _ ehead] = rdfFindArcs (rdfPredEq (Res mfEntries)) gr in map (makeTest gr) $ rdfFindList gr ehead readManifest :: FilePath -> IO [Test] readManifest fname = do putStrLn $ "Reading manifest: " ++ fname cts <- L.readFile fname path <- canonicalizePath fname let (dName, _) = splitFileName path baseName = parseURI $ "file://" ++ dName case baseName of Just bn -> putStrLn $ "Using as base: " ++ show bn _ -> hPutStrLn stderr ("Unable to convert " ++ dName ++ " to a base URI!") >> exitFailure case TTL.parseTurtle cts baseName of Left e -> hPutStrLn stderr ("Error parsing " ++ fname) >> hPutStrLn stderr ("--> " ++ e) >> exitFailure Right gr -> return $ makeTests gr main :: IO () main = do -- As there's no command-line options, always display the version putStrLn $ "Swish library: " ++ showVersion version args <- getArgs case args of [fname] -> readManifest fname >>= runTests _ -> do pName <- getProgName hPutStrLn stderr $ "Usage: " ++ pName ++ " " exitFailure swish-0.10.4.0/app/SwishApp.hs0000644000000000000000000000614513543702315014140 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : SwishApp -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -- This module is a wrapper for the main program of Swish. -- -------------------------------------------------------------------------------- module Main where import Paths_swish (version) import Data.Version (showVersion) import System.Environment (getArgs) import System.Exit (ExitCode(ExitFailure), exitWith, exitSuccess) import Control.Monad (unless) import System.IO (stderr, hPutStrLn) import Swish ------------------------------------------------------------ -- Swish main program ------------------------------------------------------------ -- -- This is a minimal wrapper for the real main program, to facilitate -- interactive execution (e.g. in HUGS) of different command lines. -- -- execStateT runs the monad with a supplied initial state, -- then separates the resulting state from the IO monad. main :: IO () main = do args <- getArgs let (flags, cmds) = splitArguments args doHelp = "-h" `elem` flags doVersion = "-v" `elem` flags doQuiet = "-q" `elem` flags if doHelp || doVersion then if doHelp then displaySwishHelp else displayVersion >> exitSuccess else do unless doQuiet $ displayVersion >> putStrLn "\n" case validateCommands cmds of Left (emsg, ecode) -> do hPutStrLn stderr $ "Swish: " ++ emsg exitWith $ ExitFailure $ fromEnum ecode Right acts -> do code <- runSwishActions acts case code of SwishSuccess -> exitSuccess _ -> hPutStrLn stderr ("Swish: "++show code) >> exitWith (ExitFailure $ fromEnum code) displayVersion :: IO () displayVersion = putStrLn $ "Swish " ++ showVersion version -------------------------------------------------------------------------------- -- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/QNameTest.hs0000644000000000000000000003244613543702315014630 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : QNameTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module defines test cases for QName data. It also throws in a few -- tests for the Namespace module. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Text as T import qualified Test.Framework as TF import Swish.Namespace (makeQNameScopedName, getQName, getScopedNameURI) import Swish.QName ( QName , LName , newQName , qnameFromURI , getNamespace , getLocalName , getQNameURI , getLName ) import Data.Maybe (fromJust) import Network.URI (URI, parseURIReference) import Test.HUnit (Test(TestList)) import TestHelpers (conv, testCompare, testCompareEq) ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ toURI :: String -> URI toURI = fromJust . parseURIReference base1, base2, base3, base4, base5, base6, base7 :: URI base1 = toURI "http://id.ninebynine.org/wip/2003/test/graph1/node#" base2 = toURI "http://id.ninebynine.org/wip/2003/test/graph2/node/" base3 = toURI "http://id.ninebynine.org/wip/2003/test/graph3/node" base4 = toURI "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" base5 = toURI "http://id.ninebynine.org/wip/2003/test/graph5/" base6 = toURI "file://home/swish/" base7 = toURI "urn:long:separator:path" -- should this really be "urn:"? qb1s1, qb2s2, qb3s3, qb3, qb3bm, qb4m, qb5, qb5s5, qb6, qb7 :: QName qb1s1 = newQName base1 "s1" qb2s2 = newQName base2 "s2" qb3s3 = newQName base3 "s3" qb3 = newQName base3 "" qb3bm = newQName base3 "basemore" qb4m = newQName base4 "more" qb5 = newQName base5 "" qb5s5 = newQName base5 "s5" qb6 = newQName base6 "file.dat" qb7 = newQName base7 "" qb1st1, qb2st2, qb3st3 :: QName qb1st1 = newQName base1 "st1" qb2st2 = newQName base2 "st2" qb3st3 = newQName base3 "st3" ------------------------------------------------------------ -- QName equality tests ------------------------------------------------------------ testQNameEq :: String -> Bool -> QName -> QName -> Test testQNameEq = testCompareEq "QNameEq" -- testQNameEq lbl eq n1 n2 = testIsEq "QNameEq" lbl eq (n1==n2) qnlist :: [(String, QName)] qnlist = [ ("qb1s1", qb1s1) , ("qb2s2", qb2s2) , ("qb3s3", qb3s3) , ("qb3", qb3) , ("qb3bm", qb3bm) , ("qb4m", qb4m) , ("qb5", qb5) , ("qb5s5", qb5s5) , ("qb1st1",qb1st1) , ("qb2st2",qb2st2) , ("qb3st3",qb3st3) ] qneqlist :: [(String, String)] qneqlist = [ ("qb3bm","qb4m") ] testQNameEqSuite :: Test testQNameEqSuite = TestList [ testQNameEq (testLab l1 l2) (testEq l1 l2) n1 n2 | (l1,n1) <- qnlist , (l2,n2) <- qnlist ] where testLab l1 l2 = l1 ++ ("-"::String) ++ l2 testEq l1 l2 = (l1 == l2) || (l1,l2) `elem` qneqlist || (l2,l1) `elem` qneqlist ------------------------------------------------------------ -- Alternative constructors ------------------------------------------------------------ nq1, nq2 :: QName nq1 = newQName base1 "s1" nq2 = newQName base1 "s2" toQN :: String -> QName toQN = fromJust . qnameFromURI . toURI qu1, qu2, qu3, qu4, qu5, qu6, qu7 :: QName 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" qu6 = "file://home/swish/file.dat" qu7 = "urn:long:separator:path" testMakeQNameSuite :: Test testMakeQNameSuite = TestList [ testQNameEq "testnq01" True nq1 qb1s1 , testQNameEq "testnq02" False nq2 qb1s1 , testQNameEq "testqu01" True qb1s1 qu1 , testQNameEq "testqu02" True qb2s2 qu2 , testQNameEq "testqu03" True qb3 qu3 , testQNameEq "testqu04" True qb5 qu4 , testQNameEq "testqu05" True qb5s5 qu5 , testQNameEq "testqu06" True qb6 qu6 , testQNameEq "testqu07" True qb7 qu7 ] ------------------------------------------------------------ -- Extract components ------------------------------------------------------------ testStringEq :: String -> String -> String -> Test testStringEq = testCompare "StringEq" testTextEq :: String -> T.Text -> T.Text -> Test testTextEq = testCompare "TextEq" testURIEq :: String -> String -> URI -> Test testURIEq lbl uri = testCompare "URIEq" lbl (toURI uri) testPartQNameSuite :: Test testPartQNameSuite = TestList [ testURIEq "testGetNamespace01" "http://id.ninebynine.org/wip/2003/test/graph1/node#" (getNamespace qb1s1) , testURIEq "testGetNamespace02" "http://id.ninebynine.org/wip/2003/test/graph2/node/" (getNamespace qb2s2) , testURIEq "testGetNamespace03" "http://id.ninebynine.org/wip/2003/test/graph3/node" (getNamespace qb3s3) , testURIEq "testGetNamespace04" "http://id.ninebynine.org/wip/2003/test/graph3/node" (getNamespace qb3) , testTextEq "testGetLocalName01" "s1" (getLName (getLocalName qb1s1)) , testTextEq "testGetLocalName02" "s2" (getLName (getLocalName qb2s2)) , testTextEq "testGetLocalName03" "s3" (getLName (getLocalName qb3s3)) , testTextEq "testGetLocalName04" "" (getLName (getLocalName qb3)) , testURIEq "testGetQNameURI01" "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" (getQNameURI qb1s1) , testURIEq "testGetQNameURI02" "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" (getQNameURI qb2s2) , testURIEq "testGetQNameURI03" "http://id.ninebynine.org/wip/2003/test/graph3/nodes3" (getQNameURI qb3s3) , testURIEq "testGetQNameURI04" "http://id.ninebynine.org/wip/2003/test/graph3/node" (getQNameURI qb3) ] ------------------------------------------------------------ -- Maybe Qname comparison ------------------------------------------------------------ testMaybeQNameEq :: String -> Bool -> Maybe QName -> Maybe QName -> Test testMaybeQNameEq = testCompareEq "MaybeQName" testMaybeQNameEqSuite :: Test testMaybeQNameEqSuite = TestList [ testMaybeQNameEq "testMaybeQNameEq01" True (Just qb1s1) (Just qb1s1) , testMaybeQNameEq "testMaybeQNameEq02" False (Just qb1s1) (Just qb2s2) , testMaybeQNameEq "testMaybeQNameEq03" False (Just qb1s1) Nothing , testMaybeQNameEq "testMaybeQNameEq04" False Nothing (Just qb1s1) , testMaybeQNameEq "testMaybeQNameEq05" True Nothing Nothing ] ------------------------------------------------------------ -- QName ordering ------------------------------------------------------------ testQNameLe :: String -> Bool -> QName -> QName -> Test testQNameLe lbl le n1 n2 = testCompare "QNameLE" lbl le (n1 <= n2) testQNameLeSuite :: Test testQNameLeSuite = TestList [testQNameLe "testQNameLe01" True qb3bm qb4m , testQNameLe "testQNameLe02" True qb4m qb3bm , testQNameLe "testQNameLe03" True qb1s1 qb2s2 , testQNameLe "testQNameLe04" False qb2s2 qb1s1 ] ------------------------------------------------------------ -- Show QName ------------------------------------------------------------ testShowQNameSuite :: Test testShowQNameSuite = TestList [testStringEq "testShowQName01" "" (show qb1s1) , testStringEq "testShowQName02" "" (show qb2s2) , testStringEq "testShowQName03" "" (show qb3) , testStringEq "testShowQName04" "" (show qb5) , testStringEq "testShowQName06" "" (show qb6) , testStringEq "testShowQName07" "" (show qb7) ] ------------------------------------------------------------ -- Split URI string into QName parts ------------------------------------------------------------ -- splitURI :: String -> ( String, String ) -- splitURI "http://example.org/aaa#bbb" = ("http://example.org/aaa#","bbb") -- splitURI "http://example.org/aaa/bbb" = ("http://example.org/aaa/","bbb") -- splitURI "http://example.org/aaa/" = ("http://example.org/aaa/","") {- testSplitURI :: String -> String -> ( String, String ) -> Test testSplitURI label input ans = TestCase ( assertEqual label ans ( splitURI input ) ) as splitURI has now been moved into qnameFromURI we change the test somewhat and also include a check of the URI combination done by newQName (may be tested elsewhere). -} testSplitURI :: String -> String -> (String, LName) -> Test testSplitURI lbl input (a,b) = let qn = newQName (toURI a) b in TestList [ testCompare lbl ":split" qn ((fromJust . qnameFromURI . toURI) input) , testCompare lbl ":show" input (show (getQNameURI qn)) ] testSplitURISuite :: Test testSplitURISuite = TestList [ testSplitURI "testSplitURI01" "http://example.org/aaa#bbb" ( "http://example.org/aaa#", "bbb" ) , testSplitURI "testSplitURI02" "http://example.org/aaa/bbb" ( "http://example.org/aaa/", "bbb" ) , testSplitURI "testSplitURI03" "http://example.org/aaa#" ( "http://example.org/aaa#", "" ) , testSplitURI "testSplitURI04" "http://example.org/aaa/" ( "http://example.org/aaa/", "" ) {- REMOVE the relative URI tests since it is not clear they make sense for QNames. , testSplitURI "testSplitURI05" "//example.org/aaa#bbb" ( "//example.org/aaa#", "bbb" ) , testSplitURI "testSplitURI06" "aaa/bbb" ( "aaa/", "bbb" ) , testSplitURI "testSplitURI07" "aaa/bbb/" ( "aaa/bbb/", "" ) -- Thanks to Ian Dickinson of the HP Jena team for spotting this one: -- So what *is* the correct split here? , testSplitURI "testSplitURI08" "mortal" ( "", "mortal" ) -} ] ------------------------------------------------------------ -- Scoped Name tests, via QName and URI -- In reality this is testing qnameFromURI (or at least -- that was the original motivation). ------------------------------------------------------------ -- simple round-trip tests testSQRoundTrip :: String -> String -> Test testSQRoundTrip lbl uri = let u = (fromJust . parseURIReference) uri qn = (fromJust . qnameFromURI) u sn = makeQNameScopedName Nothing qn in TestList [ testCompare "SQ:URI" lbl u (getScopedNameURI sn) , testCompare "SQ:Qname" lbl qn (getQName sn) ] testSNameTTSuite :: Test testSNameTTSuite = TestList [ testSQRoundTrip "null" "" , testSQRoundTrip "frag1" "/" -- Should relative fragments be supported? , testSQRoundTrip "frag2a" "/foo" , testSQRoundTrip "frag2b" "/foo/" , testSQRoundTrip "frag3" "/foo/bar" , testSQRoundTrip "frag4a" "/foo/bar#" , testSQRoundTrip "frag4b" "/foo/bar#fragid" , testSQRoundTrip "http1a" "http://example.com" , testSQRoundTrip "http1b" "http://example.com/" , testSQRoundTrip "http2" "http://example.com/foo/bar/" , testSQRoundTrip "http3" "http://example.com/foo/bar/bar" , testSQRoundTrip "http4a" "http://example.com/foo/bar/bar#" , testSQRoundTrip "http4b" "http://example.com/foo/bar/bar#fragid" , testSQRoundTrip "https1" "https://joeuser@example.com/foo/bar" , testSQRoundTrip "file1" "file:///dev/null" , testSQRoundTrip "urn1" "URN:foo:a123,456" , testSQRoundTrip "urn2" "urn:foo:a123%2C456" ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "QNameEq" testQNameEqSuite , conv "MakeQName" testMakeQNameSuite , conv "PartQName" testPartQNameSuite , conv "MaybeQNameEq" testMaybeQNameEqSuite , conv "QNameLe" testQNameLeSuite , conv "ShowQName" testShowQNameSuite , conv "SplitURI" testSplitURISuite , conv "SNameTT" testSNameTTSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/TestHelpers.hs0000644000000000000000000001721513543702315015226 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : TestHelpers -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2018 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -- This module contains test case helper functions, providing a range of -- commonly-used test cases. -- -------------------------------------------------------------------------------- -- TODO: move to using test-framework module TestHelpers ( conv , test , testCompare, testCompareEq , testEq, testNe, testLe, testGe , testElem , testJust, testNothing , testJe, testJl, testNo , testEqv, testNotEqv, testEqv2, testHasEqv, testMaybeEqv , testMaker ) where import qualified Data.Set as S import qualified Test.Framework as TF import qualified Test.Framework.Providers.HUnit as TF import Control.Monad (unless) import Data.Maybe (isJust, isNothing, fromJust) import Test.HUnit (Test(TestCase, TestList) , Assertion , assertBool, assertEqual, assertFailure ) -- quick conversion from a set of HUnit tests to -- a labelled test-framework group. -- conv :: String -> Test -> TF.Test conv lbl = TF.testGroup lbl . TF.hUnitTestToTests ------------------------------------------------------------ -- Test case helpers ------------------------------------------------------------ assertMember :: (Eq a, Show a) => String -> a -> [a] -> Assertion assertMember preface expected actual = unless (expected `elem` actual ) (assertFailure msg) where msg = (if null preface then "" else preface ++ "\n") ++ "expected: " ++ show expected ++ "\nbut got: " ++ show actual test :: String -> Bool -> Test test lab = TestCase . assertBool ("test:"++lab) testCompare :: (Eq a, Show a) => String -> String -> a -> a -> Test testCompare typ lab a1 a2 = TestCase ( assertEqual (typ++lab) a1 a2 ) testCompareEq :: (Eq a, Show a) => String -> String -> Bool -> a -> a -> Test testCompareEq typ lab eq a1 a2 = TestCase ( assertEqual (typ++lab) eq (a1==a2) ) testMaker :: (Show b, Eq b) => (a -> b) -> String -> String -> a -> a -> Test testMaker f l1 l2 x y = TestCase (assertEqual (l1 ++ ":" ++ l2) (f x) (f y)) testEq :: (Eq a, Show a) => String -> a -> a -> Test testEq = testCompare "testEq:" testNe :: (Eq a, Show a) => String -> a -> a -> Test testNe lab a1 a2 = TestCase ( assertBool ("testNe:"++lab) (a1 /= a2) ) testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test testLe lab eq a1 a2 = TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) testGe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test testGe lab eq a1 a2 = TestCase ( assertEqual ("testGe:"++lab) eq (a1>=a2) ) -- Test for Just x or Nothing testJust :: String -> Maybe a -> Test testJust lab = TestCase . assertBool ("testJust:"++lab) . isJust testNothing :: String -> Maybe a -> Test testNothing lab = TestCase . assertBool ("testJust:"++lab) . isNothing testJe :: (Eq a, Show a) => String -> a -> Maybe a -> Test testJe lab e a = TestList [ TestCase $ assertBool lab (isJust a) , TestCase $ assertEqual lab e (fromJust a) ] testJl :: (Eq a, Show a) => String -> Int -> Maybe [a] -> Test testJl lab e a = TestList [ TestCase $ assertBool lab (isJust a) , TestCase $ assertEqual lab e (length (fromJust a)) ] testNo :: (Eq a, Show a) => String -> [[a]] -> Test testNo lab a = TestCase $ assertBool lab (null a) -- Test for list membership testElem :: (Eq a, Show a) => String -> a -> [a] -> Test testElem lab a1 as = TestCase ( assertMember ("testElem:"++lab) a1 as ) -- Compare lists and lists of lists and Maybe lists for set equivalence: newtype MaybeListTest a = MaybeListTest (Maybe (S.Set a)) instance (Ord a) => Eq (MaybeListTest a) where MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 == a2 MaybeListTest Nothing == MaybeListTest Nothing = True _ == _ = False instance (Show a) => Show (MaybeListTest a) where show (MaybeListTest a) = show a testEqv :: (Ord a, Show a) => String -> [a] -> [a] -> Test testEqv = testMaker S.fromList "testEqv" testNotEqv :: (Ord a, Show a) => String -> [a] -> [a] -> Test testNotEqv lab a1 a2 = TestCase ( assertBool ("testNotEqv:"++lab) (S.fromList a1 /= S.fromList a2) ) testEqv2 :: (Ord a, Show a) => String -> [[a]] -> [[a]] -> Test testEqv2 = testMaker (S.fromList . map S.fromList) "testEqv2" testHasEqv :: (Ord a, Show a) => String -> [a] -> [[a]] -> Test testHasEqv lab a1 a2 = TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) where ma1 = S.fromList a1 ma2 = map S.fromList a2 testMaybeEqv :: (Ord a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test testMaybeEqv = testMaker (MaybeListTest . fmap S.fromList) "testMaybeEqv" {- ------------------------------------------------------------ -- Test suites for the above ------------------------------------------------------------ testSuccessSuite = TestList [ test "01" True , testEq "02" 2 2 , testLe "03" 1 2 , testLe "04" 2 2 , testGe "05" 3 2 , testGe "07" 2 2 , testJust "08" (Just "08") , testNothing "09" (Nothing :: Maybe String) , testElem "10" 'b' "abc" , testEqv "11" "abc" "bca" , testEqv "12" "abc" "bbccaa" , testEqv2 "13" ["abc","def","ghi"] ["fed","ghi","bca"] , testHasEqv "14" "abc" ["fed","ghi","bca"] , testHasEqv "15" "ghi" ["fed","ghi","bca"] , testHasEqv "16" "def" ["fed","ghi","bca"] , testMaybeEqv "17" (Just "abc") (Just "bca") , testMaybeEqv "18" Nothing (Nothing :: Maybe String) ] -- All of these tests should be failures: -- Look for number of failures == total number of tests testFailureSuite = TestList [ test "01" False , testEq "02" 2 22 , testLe "03" 2 1 , testGe "04" 2 3 , testJust "05" (Nothing :: Maybe String) , testNothing "06" (Just "09") , testElem "07" 'd' "abc" , testEqv "08" "abd" "bca" , testEqv2 "09" ["abd","def","ghi"] ["fed","ghi","bca"] , testHasEqv "10" "abd" ["fed","ghi","bca"] , testMaybeEqv "11" (Just "abc") (Just "bda") , testMaybeEqv "12" Nothing (Just "bda") ] -} -------------------------------------------------------------------------------- -- -- 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/VarBindingTest.hs0000644000000000000000000007327614163107250015654 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : VarBindingTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2013, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module contains test cases for variable binding values and -- variable binding modifier values. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Test.Framework as TF import Swish.VarBinding ( VarBinding(..) , subBinding, nullVarBinding, makeVarBinding , boundVars, subBinding, makeVarBinding , applyVarBinding, joinVarBindings , VarBindingModify(..) , vbmCompatibility, vbmCompose , findCompositions, findComposition , makeVarFilterModify , makeVarTestFilter , varBindingId, varFilterDisjunction, varFilterConjunction , varFilterEQ, varFilterNE ) import Swish.RDF.Vocabulary (swishName) import Data.List (union, intersect) import Data.Maybe (isJust, isNothing, fromJust) import Test.HUnit (Test(TestList)) import TestHelpers ( conv, test , testEq , testEqv, testEqv2, testHasEqv, testMaybeEqv , testJust, testNothing ) ------------------------------------------------------------ -- Define and variable bindings ------------------------------------------------------------ vb1 :: VarBinding Int String vb1 = makeVarBinding [(1,"a"),(2,"b"),(3,"c")] vb1str :: String vb1str = "[(1,\"a\"),(2,\"b\"),(3,\"c\")]" vb2 :: VarBinding Int String vb2 = makeVarBinding [(3,"c"),(2,"b"),(1,"a")] vb2str :: String vb2str = vb1str vb3 :: VarBinding Int String vb3 = makeVarBinding [(1,"a"),(2,"b"),(3,"c"),(4,"d"),(5,"e")] vb3str :: String vb3str = "[(1,\"a\"),(2,\"b\"),(3,\"c\"),(4,\"d\"),(5,\"e\")]" vb4 :: VarBinding Int String vb4 = nullVarBinding vb4str :: String vb4str = "[]" vb5 :: VarBinding Int Int vb5 = makeVarBinding [(1,11),(2,22),(3,33)] vb6 :: VarBinding Int String vb6 = makeVarBinding [(3,"cc"),(4,"dd"),(5,"ee")] vb12, vb13, vb14, vb16, vb21, vb44 :: VarBinding Int String vb12 = joinVarBindings vb1 vb2 vb13 = joinVarBindings vb1 vb3 vb14 = joinVarBindings vb1 vb4 vb16 = joinVarBindings vb1 vb6 vb21 = joinVarBindings vb2 vb1 vb44 = joinVarBindings vb4 vb4 vb12str, vb13str, vb14str, vb16str, vb21str, vb44str :: String vb12str = vb1str vb13str = vb3str vb14str = vb1str vb16str = "[(1,\"a\"),(2,\"b\"),(3,\"c\"),(4,\"dd\"),(5,\"ee\")]" vb21str = vb2str vb44str = vb4str vbFull :: VarBinding a b -> Bool vbFull = not . vbNull testVarBindingSuite :: Test testVarBindingSuite = TestList [ test "testVarBinding01" (vb1==vb2) , test "testVarBinding02" (vb1/=vb3) , test "testVarBinding03" (vb1/=vb4) , testEq "testVarBinding04" vb1str $ show vb1 , testEq "testVarBinding05" vb2str $ show vb2 , testEq "testVarBinding06" vb4str $ show vb4 , testEq "testVarBinding10" (S.fromList [1,2,3]) $ boundVars vb1 , testEq "testVarBinding11" (S.fromList [3,2,1]) $ boundVars vb2 , testEq "testVarBinding12" S.empty $ boundVars vb4 , test "testVarBinding20" (subBinding vb1 vb2) , test "testVarBinding21" (subBinding vb1 vb3) , test "testVarBinding22" $ not (subBinding vb1 vb4) , test "testVarBinding23" (subBinding vb2 vb1) , test "testVarBinding24" $ not (subBinding vb3 vb1) , test "testVarBinding25" (subBinding vb4 vb1) , test "testVarBinding26" (subBinding vb4 vb4) , testEq "testVarBinding30" 0 $ applyVarBinding vb5 0 , testEq "testVarBinding31" 11 $ applyVarBinding vb5 1 , testEq "testVarBinding32" 22 $ applyVarBinding vb5 2 , testEq "testVarBinding33" 33 $ applyVarBinding vb5 3 , testEq "testVarBinding34" 4 $ applyVarBinding vb5 4 , testEq "testVarBinding35" 11 $ applyVarBinding vb5 11 , test "testVarBinding40" (vbFull vb12) , test "testVarBinding41" (vbFull vb13) , test "testVarBinding42" (vbFull vb14) , test "testVarBinding43" (vbFull vb16) , test "testVarBinding44" (vbFull vb21) , test "testVarBinding45" (vbNull vb44) , test "testVarBinding50" (subBinding vb12 vb13) , test "testVarBinding51" (subBinding vb12 vb14) , test "testVarBinding52" (subBinding vb12 vb16) , test "testVarBinding53" (subBinding vb12 vb21) , test "testVarBinding54" $ not (subBinding vb12 vb44) , test "testVarBinding55" $ not (subBinding vb13 vb12) , test "testVarBinding56" (subBinding vb14 vb12) , test "testVarBinding57" (subBinding vb44 vb12) , test "testVarBinding58" $ not (subBinding vb16 vb12) , testEq "testVarBinding60" vb12str $ show vb12 , testEq "testVarBinding61" vb13str $ show vb13 , testEq "testVarBinding62" vb14str $ show vb14 , testEq "testVarBinding63" vb16str $ show vb16 , testEq "testVarBinding64" vb21str $ show vb21 , testEq "testVarBinding65" vb44str $ show vb44 , testEq "testVarBinding70" (Just "a") $ vbMap vb16 1 , testEq "testVarBinding71" (Just "c") $ vbMap vb16 3 , testEq "testVarBinding72" (Just "ee") $ vbMap vb16 5 , testEq "testVarBinding73" Nothing $ vbMap vb16 7 ] ------------------------------------------------------------ -- Variable binding modifier tests ------------------------------------------------------------ vb1m :: VarBinding String Int vb1m = makeVarBinding [("a",1)] vb2m :: VarBinding String Int vb2m = makeVarBinding [("a",1),("b",2)] vb3m :: VarBinding String Int vb3m = makeVarBinding [("a",1),("c",3)] vb4m :: VarBinding String Int vb4m = makeVarBinding [("b",2),("c",3)] vb5m :: VarBinding String Int vb5m = makeVarBinding [("a",1),("b",2),("c",3)] vb6m :: VarBinding String Int vb6m = makeVarBinding [("a",1),("b",2),("c",4)] vb9m :: VarBinding String Int vb9m = makeVarBinding [("i",9)] -- Add new bindings per vb9m vbm1 :: VarBindingModify String Int vbm1 = let vcb = S.toList (boundVars vb9m) in VarBindingModify { vbmName = swishName "vbm1" , vbmApply = map (`joinVarBindings` vb9m) , vbmVocab = vcb , vbmUsage = [vcb] } -- Avoid pattern-match errors from ghc 9.2 get1 :: [a] -> a get1 [x] = x get1 _ = error "Expected single-element list" vb1m1, vb2m1 :: VarBinding String Int vb1m1 = get1 $ vbmApply vbm1 [vb1m] vb2m1 = get1 $ vbmApply vbm1 [vb2m] -- Filter for bindings that define a vbm2 :: VarBindingModify String Int vbm2 = VarBindingModify { vbmName = swishName "vbm2" , vbmApply = filter (\vb -> isJust $ vbMap vb "a") , vbmVocab = ["a"] , vbmUsage = [[]] } vb12m2 :: [VarBinding String Int] vb12m2 = vbmApply vbm2 [vb1m,vb2m,vb9m] -- Filter or add bindings so that a+b=c vbm3 :: VarBindingModify String Int vbm3 = VarBindingModify { vbmName = swishName "vbm3" , vbmApply = sumBinding "a" "b" "c" , vbmVocab = ["a","b","c"] , vbmUsage = [[],["a"],["b"],["c"]] } sumBinding :: String -> String -> String -> [VarBinding String Int] -> [VarBinding String Int] sumBinding va vb vc = concatMap abSumc where abSumc :: VarBinding String Int -> [VarBinding String Int] abSumc vbind = abSumc1 (vbMap vbind va) (vbMap vbind vb) (vbMap vbind vc) vbind abSumc1 (Just a) (Just b) (Just c) vbind | (a+b) == c = [vbind] | otherwise = [] abSumc1 (Just a) (Just b) Nothing vbind = [ joinVarBindings vbind $ makeVarBinding [(vc,a+b)] ] abSumc1 (Just a) Nothing (Just c) vbind = [ joinVarBindings vbind $ makeVarBinding [(vb,c-a)] ] abSumc1 Nothing (Just b) (Just c) vbind = [ joinVarBindings vbind $ makeVarBinding [(va,c-b)] ] abSumc1 _ _ _ _ = [] vb16m3 :: [VarBinding String Int] vb16m3 = vbmApply vbm3 [vb1m,vb2m,vb3m,vb4m,vb5m,vb6m] testVarModifySuite :: Test testVarModifySuite = TestList [ testEq "testVarModifyName01" (swishName "vbm1") $ vbmName vbm1 , testEq "testVarModify01" (Just 1) $ vbMap vb1m1 "a" , testEq "testVarModify02" Nothing $ vbMap vb1m1 "b" , testEq "testVarModify03" Nothing $ vbMap vb2m1 "c" , testEq "testVarModify04" (Just 9) $ vbMap vb1m1 "i" , testEq "testVarModify05" (Just 1) $ vbMap vb2m1 "a" , testEq "testVarModify06" (Just 2) $ vbMap vb2m1 "b" , testEq "testVarModify07" Nothing $ vbMap vb2m1 "c" , testEq "testVarModify08" (Just 9) $ vbMap vb2m1 "i" , testEq "testVarModify10" (Just ["i"]) $ vbmCompatibility vbm1 ["a","b"] , testEq "testVarModify11" Nothing $ vbmCompatibility vbm1 ["a","b","i"] , testEq "testVarModifyName02" (swishName "vbm2") $ vbmName vbm2 , testEq "testVarModify20" 2 $ length vb12m2 , testEq "testVarModify21" vb1m $ head vb12m2 , testEq "testVarModify22" vb2m $ vb12m2!!1 , testEq "testVarModify23" (Just []) $ vbmCompatibility vbm2 ["a","b"] , testEq "testVarModify24" (Just []) $ vbmCompatibility vbm2 ["a","b"] , testEq "testVarModify25" (Just []) $ vbmCompatibility vbm2 ["a","b","i"] , testEq "testVarModify26" Nothing $ vbmCompatibility vbm2 ["i"] , testEq "testVarModifyName03" (swishName "vbm3") $ vbmName vbm3 , testEq "testVarModify30" 4 $ length vb16m3 , testEq "testVarModify31" vb5m (head vb16m3) , testEq "testVarModify32" vb5m (vb16m3!!1) , testEq "testVarModify33" vb5m (vb16m3!!2) , testEq "testVarModify34" vb5m (vb16m3!!3) , testEq "testVarModify35" (Just ["c"]) $ vbmCompatibility vbm3 ["a","b"] , testEq "testVarModify36" (Just ["b"]) $ vbmCompatibility vbm3 ["a","c"] , testEq "testVarModify37" (Just ["a"]) $ vbmCompatibility vbm3 ["b","c","i"] , testEq "testVarModify38" (Just []) $ vbmCompatibility vbm3 ["i","c","a","b"] , testEq "testVarModify39" Nothing $ vbmCompatibility vbm3 ["i","a"] , testEq "testVarModify40" Nothing $ vbmCompatibility vbm3 ["i","b"] , testEq "testVarModify41" Nothing $ vbmCompatibility vbm3 ["i","c"] , testEq "testVarModify42" Nothing $ vbmCompatibility vbm3 ["i","d"] ] ------------------------------------------------------------ -- Variable binding modifier composition tests ------------------------------------------------------------ -- Given (1) a+b=c and (2) a+c=d, then: -- a=1 b=2 => c=3 d=4 by (1) then (2) -- a=1 c=3 => b=2 d=4 by (1) then (2) or (2) then (1) -- a=1 d=4 => b=2 c=3 by (2) then (1) -- b=2 c=3 => a=1 d=4 by (1) then (2) -- b=2 d=4 => insufficient data -- c=3 d=4 => a=1 b=2 by (2) then (1) -- Filter or add bindings so that a+b=c vbm4 :: VarBindingModify String Int vbm4 = VarBindingModify { vbmName = swishName "vbm4" , vbmApply = sumBinding "a" "c" "d" , vbmVocab = ["a","c","d"] , vbmUsage = [[],["a"],["c"],["d"]] } getJust :: Maybe x -> x getJust (Just x) = x getJust _ = error "Expected something, got Nothing" vbm34, vbm43 :: VarBindingModify String Int vbm34 = getJust $ vbmCompose vbm3 vbm4 vbm43 = getJust $ vbmCompose vbm4 vbm3 vbm34vocab, vbm43vocab :: [String] vbm34vocab = [ "a", "b", "c", "d"] vbm43vocab = [ "a", "b", "c", "d"] vbm34usage, vbm43usage :: [[String]] vbm34usage = [ ["a","d"], ["b","d"], ["c","d"] , ["a"], ["b"], ["c"], ["d"], [] ] vbm43usage = [ ["a","b"], ["b","c"], ["b","d"] , ["a"], ["b"], ["c"], ["d"], [] ] vbab :: VarBinding String Int vbab = makeVarBinding [("a",1),("b",2)] vbac :: VarBinding String Int vbac = makeVarBinding [("a",1),("c",3)] vbad :: VarBinding String Int vbad = makeVarBinding [("a",1),("d",4)] vbbc :: VarBinding String Int vbbc = makeVarBinding [("b",2),("c",3)] vbbd :: VarBinding String Int vbbd = makeVarBinding [("b",2),("d",4)] vbcd :: VarBinding String Int vbcd = makeVarBinding [("c",3),("d",4)] vbabcd :: VarBinding String Int vbabcd = makeVarBinding [("a",1),("b",2),("c",3),("d",4)] -- [[[need test for incompatible composition]]] -- -- Three ways to be incompatible: -- (a) both modifers define same new output -- (b) output from second modifier is input to first modifier vbm5 :: VarBindingModify String Int vbm5 = VarBindingModify { vbmName = swishName "vbm5" , vbmApply = id -- incorrect: dummy for testing only , vbmVocab = ["a","b","c"] , vbmUsage = [["a"],["b"]] } vbm6 :: VarBindingModify String Int vbm6 = VarBindingModify { vbmName = swishName "vbm6" , vbmApply = id -- incorrect: dummy for testing only , vbmVocab = ["a","b","c"] , vbmUsage = [["a","b"],["b","c"],["a","c"]] } vbm7 :: VarBindingModify String Int vbm7 = VarBindingModify { vbmName = swishName "vbm7" , vbmApply = id -- incorrect: dummy for testing only , vbmVocab = ["a","b","c"] , vbmUsage = [["a"]] } vbm8 :: VarBindingModify String Int vbm8 = VarBindingModify { vbmName = swishName "vbm8" , vbmApply = id -- incorrect: dummy for testing only , vbmVocab = ["b","c","d"] , vbmUsage = [["b"],["c"],["b","c"]] } vbm56, vbm65, vbm78, vbm87 :: Maybe (VarBindingModify String Int) vbm56 = vbmCompose vbm5 vbm6 vbm65 = vbmCompose vbm6 vbm5 vbm78 = vbmCompose vbm7 vbm8 vbm87 = vbmCompose vbm8 vbm7 vbm87usage :: [[String]] vbm87usage = [["a","b"],["a","c"],["a","b","c"]] jvbm1id, jvbmid1 :: Maybe (VarBindingModify String Int) jvbm1id = vbmCompose vbm1 varBindingId jvbmid1 = vbmCompose varBindingId vbm1 vb1m1id, vb2m1id, vb1mid1, vb2mid1 :: VarBinding String Int vb1m1id = get1 $ vbmApply (fromJust jvbm1id) [vb1m] vb2m1id = get1 $ vbmApply (fromJust jvbm1id) [vb2m] vb1mid1 = get1 $ vbmApply (fromJust jvbmid1) [vb1m] vb2mid1 = get1 $ vbmApply (fromJust jvbmid1) [vb2m] testVarComposeSuite :: Test testVarComposeSuite = TestList [ testEq "testVarModifyName04" (swishName "vbm4") $ vbmName vbm4 , testEq "testVarModifyName05" (swishName "_vbm4_vbm3_") $ vbmName vbm43 , testEq "testVarModifyName06" (swishName "_vbm3_vbm4_") $ vbmName vbm34 , testEq "testVarModifyName07" (swishName "_vbm1_varBindingId_") $ vbmName (fromJust jvbm1id) , testEq "testVarModifyName08" (swishName "_varBindingId_vbm1_") $ vbmName (fromJust jvbmid1) , testEqv "testVarCompose01" vbm34vocab $ vbmVocab vbm34 , testEqv2 "testVarCompose02" vbm34usage $ vbmUsage vbm34 , testMaybeEqv "testVarCompose03" (Just ["c","d"]) $ vbmCompatibility vbm34 ["a","b"] , testMaybeEqv "testVarCompose04" (Just ["b","d"]) $ vbmCompatibility vbm34 ["a","c"] , testMaybeEqv "testVarCompose05" Nothing $ vbmCompatibility vbm34 ["a","d"] , testMaybeEqv "testVarCompose06" (Just ["a","d"]) $ vbmCompatibility vbm34 ["b","c"] , testMaybeEqv "testVarCompose07" Nothing $ vbmCompatibility vbm34 ["b","d"] , testMaybeEqv "testVarCompose08" Nothing $ vbmCompatibility vbm34 ["c","d"] , testMaybeEqv "testVarCompose09" (Just ["a"]) $ vbmCompatibility vbm34 ["b","c","d"] , testMaybeEqv "testVarCompose10" (Just ["b"]) $ vbmCompatibility vbm34 ["a","c","d"] , testMaybeEqv "testVarCompose11" (Just ["c"]) $ vbmCompatibility vbm34 ["a","b","d"] , testMaybeEqv "testVarCompose12" (Just ["d"]) $ vbmCompatibility vbm34 ["a","b","c"] , testMaybeEqv "testVarCompose13" (Just []) $ vbmCompatibility vbm34 ["a","b","c","d"] , testEqv "testVarCompose14" [vbabcd,vbabcd,vbabcd] $ vbmApply vbm34 [vbab,vbac,vbbc] , testEqv "testVarCompose15" [] $ vbmApply vbm34 [vbad,vbbd,vbcd] , testEqv "testVarCompose21" vbm43vocab $ vbmVocab vbm43 , testEqv2 "testVarCompose22" vbm43usage $ vbmUsage vbm43 , testMaybeEqv "testVarCompose23" Nothing $ vbmCompatibility vbm43 ["a","b"] , testMaybeEqv "testVarCompose24" (Just ["b","d"]) $ vbmCompatibility vbm43 ["a","c"] , testMaybeEqv "testVarCompose25" (Just ["b","c"]) $ vbmCompatibility vbm43 ["a","d"] , testMaybeEqv "testVarCompose26" Nothing $ vbmCompatibility vbm43 ["b","c"] , testMaybeEqv "testVarCompose27" Nothing $ vbmCompatibility vbm43 ["b","d"] , testMaybeEqv "testVarCompose28" (Just ["a","b"]) $ vbmCompatibility vbm43 ["c","d"] , testMaybeEqv "testVarCompose29" (Just ["a"]) $ vbmCompatibility vbm43 ["b","c","d"] , testMaybeEqv "testVarCompose30" (Just ["b"]) $ vbmCompatibility vbm43 ["a","c","d"] , testMaybeEqv "testVarCompose31" (Just ["c"]) $ vbmCompatibility vbm43 ["a","b","d"] , testMaybeEqv "testVarCompose32" (Just ["d"]) $ vbmCompatibility vbm43 ["a","b","c"] , testMaybeEqv "testVarCompose33" (Just []) $ vbmCompatibility vbm43 ["a","b","c","d"] , testEqv "testVarCompose34" [] $ vbmApply vbm43 [vbab,vbbc,vbbd] , testEqv "testVarCompose35" [vbabcd,vbabcd,vbabcd] $ vbmApply vbm43 [vbac,vbad,vbcd] , test "testVarCompose41" (isNothing vbm56) , test "testVarCompose42" (isNothing vbm65) , test "testVarCompose43" (isNothing vbm78) , test "testVarCompose44" (isJust vbm87) , testEqv2 "testVarCompose45" vbm87usage $ vbmUsage (fromJust vbm87) , test "testVarCompose51" $ isJust jvbm1id , test "testVarCompose52" $ isJust jvbmid1 , testEq "testVarCompose61" (Just 1) $ vbMap vb1m1id "a" , testEq "testVarCompose62" Nothing $ vbMap vb1m1id "b" , testEq "testVarCompose63" Nothing $ vbMap vb2m1id "c" , testEq "testVarCompose64" (Just 9) $ vbMap vb1m1id "i" , testEq "testVarCompose65" (Just 1) $ vbMap vb2m1id "a" , testEq "testVarCompose66" (Just 2) $ vbMap vb2m1id "b" , testEq "testVarCompose67" Nothing $ vbMap vb2m1id "c" , testEq "testVarCompose68" (Just 9) $ vbMap vb2m1id "i" , testEq "testVarCompose71" (Just 1) $ vbMap vb1mid1 "a" , testEq "testVarCompose72" Nothing $ vbMap vb1mid1 "b" , testEq "testVarCompose73" Nothing $ vbMap vb2mid1 "c" , testEq "testVarCompose74" (Just 9) $ vbMap vb1mid1 "i" , testEq "testVarCompose75" (Just 1) $ vbMap vb2mid1 "a" , testEq "testVarCompose76" (Just 2) $ vbMap vb2mid1 "b" , testEq "testVarCompose77" Nothing $ vbMap vb2mid1 "c" , testEq "testVarCompose78" (Just 9) $ vbMap vb2mid1 "i" ] ------------------------------------------------------------ -- Modifier composition discovery tests ------------------------------------------------------------ -- vbm3: a+b=c (1) -- vbm4: a+c=d (2) -- vbm9: c+d=e (3) -- -- a,b -> c,d,e by (1,2,3) -- a,c -> b,d,e by (1,2,3) -- d,b,e by (2,1,3) -- d,e,b by (2,3,1) -- a,d -> c,b,e by (2,1,3) -- c,e,b by (2,3,1) -- a,e -> None -- b,c -> a,d,e by (1,2,3) -- b,d -> None -- b,e -> None -- c,d -> a,b,e by (2,1,3) -- -> a,e,a by (2,3,1) -- -> e,a,b by (3,2,1) -- c,e -> d,a,b by (3,2,1) -- d,e -> c,a,b by (3,2,1) vbm9 :: VarBindingModify String Int vbm9 = VarBindingModify { vbmName = swishName "vbm9" , vbmApply = sumBinding "c" "d" "e" , vbmVocab = ["c","d","e"] , vbmUsage = [[],["c"],["d"],["e"]] } compab, compac, compad, compae, compba, compbc, compbd, compbe, compca, compcd, compce, compde :: [VarBindingModify String Int] compab = findCompositions [vbm3,vbm4,vbm9] ["a","b"] -- 1 compac = findCompositions [vbm3,vbm4,vbm9] ["a","c"] -- 3 compad = findCompositions [vbm3,vbm4,vbm9] ["a","d"] -- 2 compae = findCompositions [vbm3,vbm4,vbm9] ["a","e"] -- 0 compba = findCompositions [vbm3,vbm4,vbm9] ["b","a"] -- 1 compbc = findCompositions [vbm3,vbm4,vbm9] ["b","c"] -- 1 compbd = findCompositions [vbm3,vbm4,vbm9] ["b","d"] -- 0 compbe = findCompositions [vbm3,vbm4,vbm9] ["b","e"] -- 0 compca = findCompositions [vbm3,vbm4,vbm9] ["c","a"] -- 3 compcd = findCompositions [vbm3,vbm4,vbm9] ["c","d"] -- 3 compce = findCompositions [vbm3,vbm4,vbm9] ["c","e"] -- 1 compde = findCompositions [vbm3,vbm4,vbm9] ["d","e"] -- 1 compvocab :: [String] compvocab = ["a","b","c","d","e"] compBindings :: [VarBinding String Int] compBindings = map makeVarBinding [ [ ("a",1), ("b",2) ] , [ ("a",1), ("c",3) ] , [ ("a",1), ("d",4) ] , [ ("a",1), ("e",7) ] , [ ("b",2), ("c",3) ] , [ ("b",2), ("d",4) ] , [ ("b",2), ("e",7) ] , [ ("c",3), ("d",4) ] , [ ("c",3), ("e",7) ] , [ ("d",4), ("e",7) ] ] compResult :: [VarBinding String Int] compResult = map makeVarBinding [ [ ("a",1), ("b",2), ("c",3), ("d",4), ("e",7) ] ] compApply :: [VarBindingModify String Int] -> [VarBinding String Int] compApply vbms = vbmApply (head vbms) compBindings jcompab, jcompac, jcompad, jcompae, jcompba, jcompbc, jcompbd, jcompbe, jcompca, jcompcd, jcompce, jcompde :: Maybe (VarBindingModify String Int) jcompab = findComposition [vbm3,vbm4,vbm9] ["a","b"] -- 1 jcompac = findComposition [vbm3,vbm4,vbm9] ["a","c"] -- 3 jcompad = findComposition [vbm3,vbm4,vbm9] ["a","d"] -- 1 jcompae = findComposition [vbm3,vbm4,vbm9] ["a","e"] -- 0 jcompba = findComposition [vbm3,vbm4,vbm9] ["b","a"] -- 1 jcompbc = findComposition [vbm3,vbm4,vbm9] ["b","c"] -- 1 jcompbd = findComposition [vbm3,vbm4,vbm9] ["b","d"] -- 0 jcompbe = findComposition [vbm3,vbm4,vbm9] ["b","e"] -- 0 jcompca = findComposition [vbm3,vbm4,vbm9] ["c","a"] -- 3 jcompcd = findComposition [vbm3,vbm4,vbm9] ["c","d"] -- 3 jcompce = findComposition [vbm3,vbm4,vbm9] ["c","e"] -- 1 jcompde = findComposition [vbm3,vbm4,vbm9] ["d","e"] -- 1 testFindCompSuite :: Test testFindCompSuite = TestList [ testEq "testVarModifyName08" (swishName "__vbm4_vbm3__vbm9_") $ vbmName (head compad) , testEq "testVarModifyName08" (swishName "__vbm4_vbm9__vbm3_") $ vbmName (compad!!1) , testEq "testFindComp01" 1 (length compab) , testEq "testFindComp02" 3 (length compac) , testEq "testFindComp03" 2 (length compad) , testEq "testFindComp04" 0 (length compae) , testEq "testFindComp05" 1 (length compba) , testEq "testFindComp06" 1 (length compbc) , testEq "testFindComp07" 0 (length compbd) , testEq "testFindComp08" 0 (length compbe) , testEq "testFindComp09" 3 (length compca) , testEq "testFindComp10" 3 (length compcd) , testEq "testFindComp11" 1 (length compce) , testEq "testFindComp12" 1 (length compde) , testEqv "testFindComp21" compvocab $ vbmVocab (head compab) , testEqv "testFindComp22" compvocab $ vbmVocab (head compac) , testEqv "testFindComp23" compvocab $ vbmVocab (head compad) , testEqv "testFindComp24" compvocab $ vbmVocab (head compba) , testEqv "testFindComp25" compvocab $ vbmVocab (head compbc) , testEqv "testFindComp26" compvocab $ vbmVocab (head compca) , testEqv "testFindComp27" compvocab $ vbmVocab (head compcd) , testEqv "testFindComp28" compvocab $ vbmVocab (head compce) , testEqv "testFindComp29" compvocab $ vbmVocab (head compde) , testHasEqv "testFindComp31" ["c","d","e"] $ vbmUsage (head compab) , testHasEqv "testFindComp32" ["b","d","e"] $ vbmUsage (head compac) , testHasEqv "testFindComp33" ["b","c","e"] $ vbmUsage (head compad) , testHasEqv "testFindComp34" ["c","d","e"] $ vbmUsage (head compba) , testHasEqv "testFindComp35" ["a","d","e"] $ vbmUsage (head compbc) , testHasEqv "testFindComp36" ["b","d","e"] $ vbmUsage (head compca) , testHasEqv "testFindComp37" ["a","b","e"] $ vbmUsage (head compcd) , testHasEqv "testFindComp38" ["a","b","d"] $ vbmUsage (head compce) , testHasEqv "testFindComp39" ["a","b","c"] $ vbmUsage (head compde) , testEqv "testFindComp41" compResult (compApply compab) , testEqv "testFindComp42" compResult (compApply compac) , testEqv "testFindComp43" compResult (compApply compad) , testEqv "testFindComp44" compResult (compApply compba) , testEqv "testFindComp45" compResult (compApply compbc) , testEqv "testFindComp46" compResult (compApply compca) , testEqv "testFindComp47" compResult (compApply compcd) , testEqv "testFindComp48" compResult (compApply compce) , testEqv "testFindComp49" compResult (compApply compde) , testJust "testFindComp51" jcompab , testJust "testFindComp52" jcompac , testJust "testFindComp53" jcompad , testNothing "testFindComp54" jcompae , testJust "testFindComp55" jcompba , testJust "testFindComp56" jcompbc , testNothing "testFindComp57" jcompbd , testNothing "testFindComp58" jcompbe , testJust "testFindComp59" jcompca , testJust "testFindComp60" jcompcd , testJust "testFindComp61" jcompce , testJust "testFindComp62" jcompde ] ------------------------------------------------------------ -- Variable binding filters ------------------------------------------------------------ testFilterBindings :: [VarBinding String Int] testFilterBindings = map makeVarBinding [ [ ("a",0), ("b",2), ("c",2) ] , [ ("a",0), ("b",2), ("c",3) ] , [ ("a",1), ("b",2), ("c",2) ] , [ ("a",1), ("b",2), ("c",3) ] , [ ("a",1), ("b",2), ("c",0) ] , [ ("a",0), ("b",2), ("c",0) ] , [ ("a",4), ("b",2), ("c",4) ] , [ ("x",4), ("y",2), ("z",4) ] ] filtertesta0 :: VarBindingModify String Int filtertesta0 = makeVarFilterModify $ makeVarTestFilter (swishName "filtertesta0") (==0) "a" vba0 :: [VarBinding String Int] vba0 = map makeVarBinding [ [ ("a",0), ("b",2), ("c",2) ] , [ ("a",0), ("b",2), ("c",3) ] , [ ("a",0), ("b",2), ("c",0) ] ] filtertestc0 :: VarBindingModify String Int filtertestc0 = makeVarFilterModify $ makeVarTestFilter (swishName "filtertestc0") (==0) "c" vbc0 :: [VarBinding String Int] vbc0 = map makeVarBinding [ [ ("a",1), ("b",2), ("c",0) ] , [ ("a",0), ("b",2), ("c",0) ] ] filtercompabeq :: VarBindingModify String Int filtercompabeq = makeVarFilterModify $ varFilterEQ "a" "b" vbabeq :: [VarBinding String Int] vbabeq = map makeVarBinding [ ] filtercompaceq :: VarBindingModify String Int filtercompaceq = makeVarFilterModify $ varFilterEQ "a" "c" vbaceq :: [VarBinding String Int] vbaceq = map makeVarBinding [ [ ("a",0), ("b",2), ("c",0) ] , [ ("a",4), ("b",2), ("c",4) ] ] filtercompbceq :: VarBindingModify String Int filtercompbceq = makeVarFilterModify $ varFilterEQ "b" "c" vbbceq :: [VarBinding String Int] vbbceq = map makeVarBinding [ [ ("a",0), ("b",2), ("c",2) ] , [ ("a",1), ("b",2), ("c",2) ] ] filtercompbcne :: VarBindingModify String Int filtercompbcne = makeVarFilterModify $ varFilterNE "b" "c" vbbcne :: [VarBinding String Int] vbbcne = map makeVarBinding [ [ ("a",0), ("b",2), ("c",3) ] , [ ("a",1), ("b",2), ("c",3) ] , [ ("a",1), ("b",2), ("c",0) ] , [ ("a",0), ("b",2), ("c",0) ] , [ ("a",4), ("b",2), ("c",4) ] ] filterdisjunct :: VarBindingModify String Int filterdisjunct = makeVarFilterModify $ varFilterDisjunction [ makeVarTestFilter (swishName "isZero") (==0) "a" , varFilterEQ "a" "c"] filterconjunct :: VarBindingModify String Int filterconjunct = makeVarFilterModify $ varFilterConjunction [ makeVarTestFilter (swishName "isZero") (==0) "a" , varFilterEQ "a" "c"] vbdisj, vbconj :: [VarBinding String Int] vbdisj = vbaceq `union` vba0 vbconj = vbaceq `intersect` vba0 testFilterSuite :: Test testFilterSuite = TestList [ testEq "testFilterName01" (swishName "filtertesta0") $ vbmName filtertesta0 , testEq "testFilterName02" (swishName "filtertestc0") $ vbmName filtertestc0 , testEq "testFilterName03" (swishName "varFilterEQ") $ vbmName filtercompabeq , testEq "testFilterName04" (swishName "varFilterNE") $ vbmName filtercompbcne , testEq "testFilterName05" (swishName "varFilterDisjunction") $ vbmName filterdisjunct , testEq "testFilterName06" (swishName "varFilterConjunction") $ vbmName filterconjunct , testEqv "testFilter01" vba0 $ vbmApply filtertesta0 testFilterBindings , testEqv "testFilter02" vbc0 $ vbmApply filtertestc0 testFilterBindings , testEqv "testFilter03" vbabeq $ vbmApply filtercompabeq testFilterBindings , testEqv "testFilter04" vbaceq $ vbmApply filtercompaceq testFilterBindings , testEqv "testFilter05" vbbceq $ vbmApply filtercompbceq testFilterBindings , testEqv "testFilter06" vbbcne $ vbmApply filtercompbcne testFilterBindings , testEqv "testFilter07" vbdisj $ vbmApply filterdisjunct testFilterBindings , testEqv "testFilter08" vbconj $ vbmApply filterconjunct testFilterBindings , testEqv "testFilter10" testFilterBindings $ vbmApply varBindingId testFilterBindings ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "VarBinding" testVarBindingSuite , conv "VarModify" testVarModifySuite , conv "VarCompose" testVarComposeSuite , conv "FindComp" testFindCompSuite , conv "Filter" testFilterSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2013, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFRulesetTest.hs0000644000000000000000000003067513543702315015610 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFRulesetTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module contains test cases for ruleset data. -- -- Note that the proof-related methods defined in RDFRuleset are tested -- by RDFProofTest and/or RDFProofCheck. -- module Main where import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF import qualified TestHelpers as TH 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 , graphClosureFwdApply, graphClosureBwdApply ) import Swish.RDF.Query (rdfQueryBack, rdfQueryBackModify) import Swish.RDF.VarBinding ( RDFVarBinding , RDFVarBindingModify , RDFVarBindingFilter , rdfVarBindingXMLLiteral ) import Swish.RDF.Graph ( Label (..), RDFLabel(..), RDFGraph , RDFArcSet , getArcs , allLabels , toRDFGraph ) import Swish.RDF.Vocabulary (namespaceRDF, namespaceRDFS, namespaceOWL, scopeRDF) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.List (sort) import Data.Maybe (isJust, fromJust) import Data.Text (Text) import Test.HUnit ( Test(TestCase,TestList) , assertBool ) import Network.URI (URI, parseURI) import TestHelpers ( conv, test , testLe , testCompare , testCompareEq , testMaker ) ------------------------------------------------------------ -- Test case helpers ------------------------------------------------------------ testVal :: (Eq a, Show a) => String -> a -> a -> Test testVal = testCompare "testVal:" testEq :: (Eq a, Show a) => String -> Bool -> a -> a -> Test testEq = testCompareEq "testIsEq:" testEqual :: (Eq a, Show a) => String -> a -> a -> Test testEqual = TH.testEq testStringEq :: String -> String -> String -> Test testStringEq = testCompare "testStringEq:" testSameNamespace :: String -> Namespace -> Namespace -> Test testSameNamespace = testMaker getNamespaceTuple "testSameNamespace:" testScopedNameEq :: String -> Bool -> ScopedName -> ScopedName -> Test testScopedNameEq = testCompareEq "testScopedNameEq:" testSameAs :: (Ord a) => String -> String -> [a] -> [a] -> Test testSameAs l1 l2 x y = let z = sort x == sort y in TestCase (assertBool ("testSameAs:" ++ l1 ++ ":" ++ l2) z) testSameAxioms :: String -> [RDFFormula] -> [RDFFormula] -> Test testSameAxioms = testSameAs "Axioms" testSameRules :: String -> [RDFRule] -> [RDFRule] -> Test testSameRules = testSameAs "Rules" ------------------------------------------------------------ -- Common values ------------------------------------------------------------ pref_rdf, pref_owl :: URI pref_rdf = getNamespaceURI namespaceRDF pref_owl = getNamespaceURI namespaceOWL toURI :: String -> URI toURI = fromJust . parseURI toNS :: Maybe Text -> String -> Namespace toNS p = makeNamespace p . toURI ------------------------------------------------------------ -- Define and manipulate rulesets ------------------------------------------------------------ -- -- A ruleset is essentially a collection of axioms and rules -- associated with a namespace. -- -- Rulesets for RDF, RDFS and basic datatyping are predefined: -- see RDFRuleset, RDFSRuleset and RDFDRuleset. -- Additional rulesets may be defined for specific datatypes. -- -- A proof context is a list of rulesets, -- which may be cited by a proof. rn1 :: Namespace rn1 = toNS (Just "r1") "http://id.ninebynine.org/wip/2003/rulesettest/r1" -- Common prefix declarations for graph expressions mkPrefix :: Namespace -> B.Builder mkPrefix = namespaceToBuilder prefix :: B.Builder prefix = mconcat [ mkPrefix namespaceRDF , mkPrefix namespaceRDFS , mkPrefix (toNS (Just "ex") "http://example.org/") ] a11, a12 :: RDFFormula a11 = makeRDFFormula rn1 "a11" $ prefix `mappend` "ex:R1 rdf:type ex:C1 ." a12 = makeRDFFormula rn1 "a12" $ prefix `mappend` "ex:R2 rdf:type ex:C2 ." r11, r12 :: RDFRule r11 = makeN3ClosureSimpleRule rn1 "r11" ( prefix `mappend` "?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) ( prefix `mappend` "?r1 ex:P1 ?r2 ." ) r12 = makeN3ClosureSimpleRule rn1 "r12" ( prefix `mappend` "?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) ( prefix `mappend` "?r2 ex:P2 ?r1 ." ) -- Basic formula and rule comparison tests -- (tests support code added in module Proof.hs) testFormulaSuite :: Test testFormulaSuite = TestList [ testEq "testCmpAX01" True a11 a11 , testEq "testCmpAX02" False a11 a12 , testLe "testCmpAX03" True a11 a11 , testLe "testCmpAX04" True a11 a12 , testLe "testCmpAX05" False a12 a11 ] testRuleSuite :: Test testRuleSuite = TestList [ testEq "testCmpRU01" True r11 r11 , testEq "testCmpRU02" False r11 r12 , testLe "testCmpRU03" True r11 r11 , testLe "testCmpRU04" True r11 r12 , testLe "testCmpRU05" False r12 r11 ] -- Test simple ruleset construction and access a1s :: [RDFFormula] a1s = [ a11, a12 ] r1s :: [RDFRule] r1s = [ r11, r12 ] r1 :: RDFRuleset r1 = makeRuleset rn1 a1s r1s testRulesetSuite :: Test testRulesetSuite = TestList [ testSameNamespace "testNS01" rn1 (getRulesetNamespace r1) , testSameAxioms "testAX01" a1s (getRulesetAxioms r1) , testSameRules "testRU01" r1s (getRulesetRules r1) , testEqual "testGeta11" (Just a11) $ getRulesetAxiom (makeNSScopedName rn1 "a11") r1 , testEqual "testGeta11" (Just a12) $ getRulesetAxiom (makeNSScopedName rn1 "a12") r1 , testEqual "testGetr11" (Just r11) $ getRulesetRule (makeNSScopedName rn1 "r11") r1 , testEqual "testGetr12" (Just r12) $ getRulesetRule (makeNSScopedName rn1 "r12") r1 , testEqual "testGetnone" Nothing $ getRulesetRule (makeNSScopedName rn1 "none") r1 ] ------------------------------------------------------------ -- Component tests for RDF proof context ------------------------------------------------------------ scopeex :: Namespace scopeex = toNS (Just "ex") "http://id.ninebynine.org/wip/2003/RDFProofCheck#" makeFormula :: Namespace -> LName -> B.Builder -> RDFFormula makeFormula scope local gr = makeRDFFormula scope local $ prefix `mappend` gr allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify allocateTo bv av = makeNodeAllocTo (Var bv) (Var av) isXMLLit :: String -> RDFVarBindingFilter isXMLLit = rdfVarBindingXMLLiteral . Var queryBack :: RDFArcSet -> RDFGraph -> [[RDFVarBinding]] queryBack qas = rdfQueryBack (toRDFGraph qas) -- Backward chaining rdf:r2 rdfr2ant, rdfr2con :: RDFGraph rdfr2ant = makeRDFGraphFromN3Builder "?x ?a ?l . " rdfr2con = makeRDFGraphFromN3Builder "?x ?a ?b . ?b rdf:type rdf:XMLLiteral ." rdfr2modv :: RDFVarBindingModify rdfr2modv = allocateTo "b" "l" $ S.toList $ allLabels labelIsVar rdfr2ant rdfr2modc :: Maybe RDFVarBindingModify rdfr2modc = vbmCompose (makeVarFilterModify $ isXMLLit "l") rdfr2modv rdfr2grc :: RDFClosure rdfr2grc = GraphClosure { nameGraphRule = makeNSScopedName scopeRDF "r2" , ruleAnt = getArcs rdfr2ant , ruleCon = getArcs rdfr2con , ruleModify = fromJust rdfr2modc } rdfr2rul :: RDFRule rdfr2rul = Rule { ruleName = nameGraphRule rdfr2grc , fwdApply = graphClosureFwdApply rdfr2grc , bwdApply = graphClosureBwdApply rdfr2grc , checkInference = fwdCheckInference rdfr2rul } con03 :: RDFGraph con03 = formExpr $ makeFormula scopeex "con03" $ "ex:s ex:p1 _:l1 ; ex:p2a _:l2; ex:p2b _:l2 ." `mappend` "_:l1 rdf:type rdf:XMLLiteral ." `mappend` "_:l2 rdf:type rdf:XMLLiteral ." v_a, v_b, v_x :: RDFLabel v_a = Var "a" v_b = Var "b" v_x = Var "x" exURI :: URI exURI = toURI "http://example.org/" u_s, u_p1, u_p2a, u_p2b, u_rt, u_rx :: RDFLabel u_s = Res $ makeScopedName Nothing exURI "s" u_p1 = Res $ makeScopedName Nothing exURI "p1" u_p2a = Res $ makeScopedName Nothing exURI "p2a" u_p2b = Res $ makeScopedName Nothing exURI "p2b" u_rt = Res $ makeScopedName Nothing pref_rdf "type" u_rx = Res $ makeScopedName Nothing pref_rdf "XMLLiteral" b_l1, b_l2 :: RDFLabel b_l1 = Blank "l1" b_l2 = Blank "l2" -- could look at S.Set (S.Set RDFVarBinding) which would make -- comparison easier to write -- rdfr2v1, rdfr2b1, rdfr2v2 :: [[RDFVarBinding]] rdfr2v1 = queryBack (ruleCon rdfr2grc) con03 rdfr2b1 = [ [ makeVarBinding [ (v_b,b_l2) ] , makeVarBinding [ (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] , [ makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] , [ makeVarBinding [ (v_b,b_l2) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] , [ makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] ] rdfr2v2 = rdfQueryBackModify (ruleModify rdfr2grc) rdfr2v1 -- as rdfr2v2 is empty no point in the following -- rdfr2v3 :: [[RDFVarBinding]] -- rdfr2v3 = map nub rdfr2v2 testRDFSuite :: Test testRDFSuite = TestList [ test "testRDF01" (isJust rdfr2modc) , testVal "testRDF02" rdfr2b1 rdfr2v1 , test "testRDF03" $ null rdfr2v2 -- , test "testRDF04" $ null rdfr2v3 , testEq "testRDF09" True [] $ bwdApply rdfr2rul con03 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "Formula" testFormulaSuite , conv "Rule" testRuleSuite , conv "Ruleset" testRulesetSuite , conv "RDF" testRDFSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFQueryTest.hs0000644000000000000000000014331014163107250015255 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFQueryTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2018, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module defines test cases 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 tests some primitive graph access functions. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF 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 ) import Swish.RDF.VarBinding ( RDFVarBinding , RDFVarBindingFilter , rdfVarBindingUriRef, rdfVarBindingBlank , rdfVarBindingLiteral , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped , rdfVarBindingMemberProp ) import Swish.RDF.Graph (RDFGraph, RDFLabel(..), merge) import Swish.RDF.Vocabulary (namespaceRDF, toLangTag, swishName, rdfType, rdfXMLLiteral) import Swish.RDF.Parser.N3 (parseN3) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Maybe (fromJust) import Network.URI (URI, parseURI) import Test.HUnit ( Test(TestList) ) import TestHelpers ( conv, test , testEq , testElem , testEqv ) ------------------------------------------------------------ -- misc helpers ------------------------------------------------------------ testGr :: String -> B.Builder -> [RDFGraph] -> Test testGr lab e = testElem lab (graphFromBuilder mempty e) graphFromBuilder :: B.Builder -> B.Builder -> RDFGraph graphFromBuilder prefix body = let txt = B.toLazyText $ prefix `mappend` body in case parseN3 txt Nothing of Right gr -> gr Left msg -> error msg ------------------------------------------------------------ -- test1: simple query qith URI, literal and blank nodes. ------------------------------------------------------------ prefix1 :: B.Builder prefix1 = "@prefix ex: . \n" gr1 :: B.Builder -> RDFGraph gr1 = graphFromBuilder prefix1 graph1 :: RDFGraph graph1 = gr1 $ mconcat [ "ex:s1 ex:p ex:o1 . \n" , "ex:s2 ex:p \"lit1\" . \n" , "[ ex:p ex:o3 ] . \n" ] query11 :: RDFGraph query11 = gr1 "?s ex:p ?o . \n" result11 :: RDFGraph result11 = gr1 "?s ex:r ?o . \n" result11a, result11b, result11c :: B.Builder result11a = prefix1 `mappend` "ex:s1 ex:r ex:o1 . \n" result11b = prefix1 `mappend` "ex:s2 ex:r \"lit1\" . \n" result11c = prefix1 `mappend` "[ ex:r ex:o3 ] . \n" -- Avoid incomplete-coverage warnings from ghc 9.2 get1 :: [x] -> x get1 [x] = x get1 _ = error "Invalid response - not a singleton" get2 :: [x] -> (x, x) get2 [x, y] = (x, y) get2 _ = error "Invalid response - not a pair" var11 :: [RDFVarBinding] var11 = rdfQueryFind query11 graph1 res11 :: [RDFGraph] res11 = rdfQuerySubs var11 result11 test1 :: Test test1 = TestList [ test "testQuery11" (not $ null var11) , testEq "testResult11" 3 (length res11) , testGr "testResult11a" result11a res11 , testGr "testResult11b" result11b res11 , testGr "testResult11c" result11c res11 ] ------------------------------------------------------------ -- test2: a range of more complex queries based on a -- single relationship graph. ------------------------------------------------------------ prefix2 :: B.Builder prefix2 = "@prefix pers: . \n" `mappend` "@prefix rel: . \n" gr2 :: B.Builder -> RDFGraph gr2 = graphFromBuilder prefix2 graph2 :: RDFGraph graph2 = gr2 $ mconcat [ "pers:St1 rel:wife pers:Do1 ; \n" , " rel:daughter pers:Ma2 ; \n" , " rel:daughter pers:An2 . \n" , "pers:Pa2 rel:wife pers:Ma2 ; \n" , " rel:son pers:Gr3 ; \n" , " rel:son pers:La3 ; \n" , " rel:son pers:Si3 ; \n" , " rel:son pers:Al3 . \n" , "pers:Br2 rel:wife pers:Ri2 ; \n" , " rel:daughter pers:Ma3 ; \n" , " rel:son pers:Wi3 . \n" , "pers:Gr3 rel:wife pers:Ma3 ; \n" , " rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" , "pers:Si3 rel:wife pers:Jo3 ; \n" , " rel:son pers:Ol4 ; \n" , " rel:son pers:Lo4 . \n" , "pers:Al3 rel:wife pers:Su3 ; \n" , " rel:son pers:Ha4 ; \n" , " rel:son pers:El4 . \n" ] query21 :: RDFGraph query21 = gr2 "?a rel:wife ?b . \n" result21 :: RDFGraph result21 = gr2 "?b rel:husband ?a . \n" result21a, result21b, result21c, result21d, result21e, result21f :: B.Builder result21a = prefix2 `mappend` "pers:Do1 rel:husband pers:St1 . \n" result21b = prefix2 `mappend` "pers:Ma2 rel:husband pers:Pa2 . \n" result21c = prefix2 `mappend` "pers:Ri2 rel:husband pers:Br2 . \n" result21d = prefix2 `mappend` "pers:Ma3 rel:husband pers:Gr3 . \n" result21e = prefix2 `mappend` "pers:Jo3 rel:husband pers:Si3 . \n" result21f = prefix2 `mappend` "pers:Su3 rel:husband pers:Al3 . \n" var21 :: [RDFVarBinding] var21 = rdfQueryFind query21 graph2 res21 :: [RDFGraph] res21 = rdfQuerySubs var21 result21 query22 :: RDFGraph query22 = gr2 $ "?a rel:son ?b . \n" `mappend` "?b rel:son ?c . \n" result22 :: RDFGraph result22 = gr2 "?a rel:grandparent ?c . \n" result22a, result22b, result22c, result22d, result22e :: B.Builder result22a = prefix2 `mappend` "pers:Pa2 rel:grandparent pers:Ro4 . \n" result22b = prefix2 `mappend` "pers:Pa2 rel:grandparent pers:Ol4 . \n" result22c = prefix2 `mappend` "pers:Pa2 rel:grandparent pers:Lo4 . \n" result22d = prefix2 `mappend` "pers:Pa2 rel:grandparent pers:Ha4 . \n" result22e = prefix2 `mappend` "pers:Pa2 rel:grandparent pers:El4 . \n" var22 :: [RDFVarBinding] var22 = rdfQueryFind query22 graph2 res22 :: [RDFGraph] res22 = rdfQuerySubs var22 result22 query23 :: RDFGraph query23 = gr2 $ "?a rel:son ?b . \n" `mappend` "?a rel:son ?c . \n" result23 :: RDFGraph result23 = gr2 "?b rel:brother ?c . \n" result23a, result23b, result23c, result23d, result23e, result23f, result23g, result23h, result23i, result23j, result23k, result23l, result23m, result23n, result23o, result23p, result23q, result23r, result23s, result23t, result23u, result23v, result23w, result23x, result23y, result23z :: B.Builder result23a = prefix2 `mappend` "pers:Gr3 rel:brother pers:Gr3 . \n" result23b = prefix2 `mappend` "pers:Gr3 rel:brother pers:La3 . \n" result23c = prefix2 `mappend` "pers:Gr3 rel:brother pers:Si3 . \n" result23d = prefix2 `mappend` "pers:Gr3 rel:brother pers:Al3 . \n" result23e = prefix2 `mappend` "pers:La3 rel:brother pers:Gr3 . \n" result23f = prefix2 `mappend` "pers:La3 rel:brother pers:La3 . \n" result23g = prefix2 `mappend` "pers:La3 rel:brother pers:Si3 . \n" result23h = prefix2 `mappend` "pers:La3 rel:brother pers:Al3 . \n" result23i = prefix2 `mappend` "pers:Si3 rel:brother pers:Gr3 . \n" result23j = prefix2 `mappend` "pers:Si3 rel:brother pers:La3 . \n" result23k = prefix2 `mappend` "pers:Si3 rel:brother pers:Si3 . \n" result23l = prefix2 `mappend` "pers:Si3 rel:brother pers:Al3 . \n" result23m = prefix2 `mappend` "pers:Al3 rel:brother pers:Gr3 . \n" result23n = prefix2 `mappend` "pers:Al3 rel:brother pers:La3 . \n" result23o = prefix2 `mappend` "pers:Al3 rel:brother pers:Si3 . \n" result23p = prefix2 `mappend` "pers:Al3 rel:brother pers:Al3 . \n" result23q = prefix2 `mappend` "pers:Wi3 rel:brother pers:Wi3 . \n" result23r = prefix2 `mappend` "pers:Ro4 rel:brother pers:Ro4 . \n" result23s = prefix2 `mappend` "pers:Ol4 rel:brother pers:Lo4 . \n" result23t = prefix2 `mappend` "pers:Ol4 rel:brother pers:Ol4 . \n" result23u = prefix2 `mappend` "pers:Lo4 rel:brother pers:Lo4 . \n" result23v = prefix2 `mappend` "pers:Lo4 rel:brother pers:Ol4 . \n" result23w = prefix2 `mappend` "pers:Ha4 rel:brother pers:El4 . \n" result23x = prefix2 `mappend` "pers:Ha4 rel:brother pers:Ha4 . \n" result23y = prefix2 `mappend` "pers:El4 rel:brother pers:El4 . \n" result23z = prefix2 `mappend` "pers:El4 rel:brother pers:Ha4 . \n" var23 :: [RDFVarBinding] var23 = rdfQueryFind query23 graph2 res23 :: [RDFGraph] res23 = rdfQuerySubs var23 result23 -- apply filtering to result: filter23 :: RDFVarBindingFilter filter23 = varFilterNE (Var "b") (Var "c") var23F :: [RDFVarBinding] var23F = rdfQueryFilter filter23 var23 res23F :: [RDFGraph] res23F = rdfQuerySubs var23F result23 query24 :: RDFGraph query24 = gr2 $ "?a rel:daughter ?b . \n" `mappend` "?a rel:daughter ?c . \n" result24 :: RDFGraph result24 = gr2 "?b rel:sister ?c . \n" result24a, result24b, result24c, result24d, result24e, result24f :: B.Builder result24a = prefix2 `mappend` "pers:Ma2 rel:sister pers:Ma2 . \n" result24b = prefix2 `mappend` "pers:Ma2 rel:sister pers:An2 . \n" result24c = prefix2 `mappend` "pers:An2 rel:sister pers:Ma2 . \n" result24d = prefix2 `mappend` "pers:An2 rel:sister pers:An2 . \n" result24e = prefix2 `mappend` "pers:Ma3 rel:sister pers:Ma3 . \n" result24f = prefix2 `mappend` "pers:Rh4 rel:sister pers:Rh4 . \n" var24 :: [RDFVarBinding] var24 = rdfQueryFind query24 graph2 res24 :: [RDFGraph] res24 = rdfQuerySubs var24 result24 query25 :: RDFGraph query25 = gr2 $ "?a rel:son ?b . \n" `mappend` "?a rel:daughter ?c . \n" result25 :: RDFGraph result25 = gr2 $ "?b rel:sister ?c . \n" `mappend` "?c rel:brother ?b . \n" result25a, result25b :: B.Builder result25a = mconcat [ prefix2 , "pers:Wi3 rel:sister pers:Ma3 . \n" , "pers:Ma3 rel:brother pers:Wi3 . \n" ] result25b = mconcat [ prefix2 , "pers:Ro4 rel:sister pers:Rh4 . \n" , "pers:Rh4 rel:brother pers:Ro4 . \n" ] var25 :: [RDFVarBinding] var25 = rdfQueryFind query25 graph2 res25 :: [RDFGraph] res25 = rdfQuerySubs var25 result25 test2 :: Test test2 = TestList [ test "testQuery21" (not $ null var21) , testEq "testResult21" 6 (length res21) , testGr "testResult21a" result21a res21 , testGr "testResult21b" result21b res21 , testGr "testResult21c" result21c res21 , testGr "testResult21d" result21d res21 , testGr "testResult21e" result21e res21 , testGr "testResult21f" result21f res21 , test "testQuery22" (not $ null var22) , testEq "testResult22" 5 (length res22) , testGr "testResult22a" result22a res22 , testGr "testResult22b" result22b res22 , testGr "testResult22c" result22c res22 , testGr "testResult22d" result22d res22 , testGr "testResult22e" result22e res22 , test "testQuery23" (not $ null var23) , testEq "testResult23" 26 (length res23) , testGr "testResult23a" result23a res23 , testGr "testResult23b" result23b res23 , testGr "testResult23c" result23c res23 , testGr "testResult23d" result23d res23 , testGr "testResult23e" result23e res23 , testGr "testResult23f" result23f res23 , testGr "testResult23g" result23g res23 , testGr "testResult23h" result23h res23 , testGr "testResult23i" result23i res23 , testGr "testResult23j" result23j res23 , testGr "testResult23k" result23k res23 , testGr "testResult23l" result23l res23 , testGr "testResult23m" result23m res23 , testGr "testResult23n" result23n res23 , testGr "testResult23o" result23o res23 , testGr "testResult23p" result23p res23 , testGr "testResult23q" result23q res23 , testGr "testResult23r" result23r res23 , testGr "testResult23s" result23s res23 , testGr "testResult23t" result23t res23 , testGr "testResult23u" result23u res23 , testGr "testResult23v" result23v res23 , testGr "testResult23w" result23w res23 , testGr "testResult23x" result23x res23 , testGr "testResult23y" result23y res23 , testGr "testResult23z" result23z res23 , testEq "testResult23" 16 (length res23F) , testGr "testResult23b" result23b res23F , testGr "testResult23c" result23c res23F , testGr "testResult23d" result23d res23F , testGr "testResult23e" result23e res23F , testGr "testResult23g" result23g res23F , testGr "testResult23h" result23h res23F , testGr "testResult23i" result23i res23F , testGr "testResult23j" result23j res23F , testGr "testResult23l" result23l res23F , testGr "testResult23m" result23m res23F , testGr "testResult23n" result23n res23F , testGr "testResult23o" result23o res23F , testGr "testResult23s" result23s res23F , testGr "testResult23v" result23v res23F , testGr "testResult23w" result23w res23F , testGr "testResult23z" result23z res23F , test "testQuery24" (not $ null var24) , testEq "testResult24" 6 (length res24) , testGr "testResult24a" result24a res24 , testGr "testResult24b" result24b res24 , testGr "testResult24c" result24c res24 , testGr "testResult24d" result24d res24 , testGr "testResult24e" result24e res24 , testGr "testResult24f" result24f res24 , test "testQuery25" (not $ null var25) , testEq "testResult25" 2 (length res25) , testGr "testResult25a" result25a res25 , testGr "testResult25b" result25b res25 ] ------------------------------------------------------------ -- test handling of unsubstituted variables, and -- rdfQuerySubsAll, rdfQuerySubsBlank ------------------------------------------------------------ graph3 :: RDFGraph graph3 = gr2 $ "pers:Pa2 rel:grandparent pers:Ro4 . \n" `mappend` "pers:Pa2 rel:grandparent pers:Ol4 . \n" query31 :: RDFGraph query31 = gr2 "?a rel:grandparent ?c . \n" result31 :: RDFGraph result31 = gr2 $ "?a rel:son ?b . \n" `mappend` "?b rel:son ?c . \n" result31a, result31b :: B.Builder result31a = mconcat [ prefix2 , "pers:Pa2 rel:son ?b . \n" , "?b rel:son pers:Ro4 . \n" ] result31b = mconcat [ prefix2 , "pers:Pa2 rel:son ?b . \n" , "?b rel:son pers:Ol4 . \n" ] var31 :: [RDFVarBinding] var31 = rdfQueryFind query31 graph3 res31pairs :: [(RDFGraph, [RDFLabel])] res31pairs = rdfQuerySubsAll var31 result31 res31 :: [RDFGraph] res31v :: [[RDFLabel]] (res31,res31v) = unzip res31pairs query32 :: RDFGraph query32 = gr2 "?a rel:grandparent ?c . \n" result32 :: RDFGraph result32 = gr2 $ mconcat [ "?a rel:wife _:b . \n" , "?d rel:any _:b0 . \n" , "?a rel:son ?b . \n" , "?b rel:son ?c . \n" ] result32a, result32b :: B.Builder result32a = mconcat [ prefix2 , "pers:Pa2 rel:wife _:b . \n" , "_:d0 rel:any _:b0 . \n" , "pers:Pa2 rel:son _:b1 . \n" , "_:b1 rel:son pers:Ro4 . \n" ] result32b = mconcat [ prefix2 , "pers:Pa2 rel:wife _:b . \n" , "_:d0 rel:any _:b0 . \n" , "pers:Pa2 rel:son _:b1 . \n" , "_:b1 rel:son pers:Ol4 . \n" ] res32, res33 :: [RDFGraph] res32 = rdfQuerySubsBlank var31 result32 res33 = rdfQuerySubs var31 result32 test3 :: Test test3 = TestList [ test "testQuery31" (not $ null var31) , testEq "testUnsubs31" 2 (length res31v) , testEq "testUnsubs31a" [Var "b"] (head res31v) , testEq "testUnsubs31a" [Var "b"] (head . tail $ res31v) , testEq "testResult31" 2 (length res31) , testGr "testResult31a" result31a res31 , testGr "testResult31b" result31b res31 , testEq "testResult32" 2 (length res32) , testGr "testResult32a" result32a res32 , testGr "testResult32b" result32b res32 , testEq "testResult33" 0 (length res33) ] {- -- Debug sequence for rdfQuerySubsBlank -- (using internals of rdfQuerySubsBlank implementation) -- res32 = rdfQuerySubsBlank (fromJust var31) result32 d1 = result32 d2 = rdfQuerySubs2 (head $ var31) d1 d3 = allLabels isBlank (fst d2) d4 = remapLabels (snd d2) d3 makeBlank (fst d2) -} ------------------------------------------------------------ -- test4: test of backward-chaining query ------------------------------------------------------------ prefix4 :: B.Builder prefix4 = "@prefix pers: . \n" `mappend` "@prefix rel: . \n" -- should use gr4l rather than gr gr4 :: B.Builder -> RDFGraph gr4 = graphFromBuilder prefix4 gr4l :: [B.Builder] -> RDFGraph gr4l = graphFromBuilder prefix4 . mconcat b4 :: [B.Builder] -> B.Builder b4 = mconcat . (prefix4 :) graph41 :: RDFGraph graph41 = gr4 "pers:St1 rel:wife pers:Do1 . \n" query41 :: RDFGraph query41 = gr4 "?a rel:wife ?b . \n" result41 :: RDFGraph result41 = gr4 "?b rel:husband ?a . \n" result41a :: B.Builder result41a = prefix4 `mappend` "pers:Do1 rel:husband pers:St1 . \n" var41 :: [[RDFVarBinding]] var41 = rdfQueryBack query41 graph41 res41 :: [[(RDFGraph, [RDFLabel])]] res41 = rdfQueryBackSubs var41 result41 graph42 :: RDFGraph graph42 = gr4 "pers:Pa2 rel:grandparent pers:Ro4 . \n" query42 :: RDFGraph query42 = gr4 "?a rel:grandparent ?c . \n" result42 :: RDFGraph result42 = gr4 $ "?a rel:son ?b . \n" `mappend` "?b rel:son ?c . \n" result42a :: B.Builder result42a = mconcat [ prefix4 , "pers:Pa2 rel:son ?b . \n" , "?b rel:son pers:Ro4 . \n" ] var42 :: [[RDFVarBinding]] var42 = rdfQueryBack query42 graph42 res42 :: [[(RDFGraph, [RDFLabel])]] res42 = rdfQueryBackSubs var42 result42 graph43 :: RDFGraph graph43 = gr4 "pers:Gr3 rel:brother pers:La3 . \n" query43 :: RDFGraph query43 = gr4 "?b rel:brother ?c . \n" result43 :: RDFGraph result43 = gr4 $ "?a rel:son ?b . \n" `mappend` "?a rel:son ?c . \n" result43a :: B.Builder result43a = mconcat [ prefix4 , "?a rel:son pers:Gr3 . \n" , "?a rel:son pers:La3 . \n" ] var43 :: [[RDFVarBinding]] var43 = rdfQueryBack query43 graph43 res43 :: [[(RDFGraph, [RDFLabel])]] res43 = rdfQueryBackSubs var43 result43 graph44 :: RDFGraph graph44 = gr4 "pers:Pa2 rel:grandson pers:Ro4 . \n" query44 :: RDFGraph query44 = gr4 $ "?a rel:grandson ?b . \n" `mappend` "?c rel:grandson ?d . \n" result44 :: RDFGraph result44 = gr4 $ mconcat [ "?a rel:son ?m . \n" , "?m rel:son ?b . \n" , "?c rel:daughter ?n . \n" , "?n rel:son ?d . \n" ] result44a, result44b :: B.Builder result44a = mconcat [ prefix4 , "?a rel:son ?m . \n" , "?m rel:son ?b . \n" , "pers:Pa2 rel:daughter ?n . \n" , "?n rel:son pers:Ro4 . \n" ] result44b = mconcat [ prefix4 , "pers:Pa2 rel:son ?m . \n" , "?m rel:son pers:Ro4 . \n" , "?c rel:daughter ?n . \n" , "?n rel:son ?d . \n" ] unbound44a, unbound44b :: [RDFLabel] unbound44a = [Var "a", Var "b", Var "m", Var "n"] unbound44b = [Var "c", Var "d", Var "m", Var "n"] var44 :: [[RDFVarBinding]] var44 = rdfQueryBack query44 graph44 res44 :: [[(RDFGraph, [RDFLabel])]] res44 = rdfQueryBackSubs var44 result44 res44_1, res44_2 :: [(RDFGraph, [RDFLabel])] (res44_1, res44_2) = get2 res44 -- test45: multiple substitutions used together -- -- (?a daughter ?b, ?a son ?c) => ?b brother ?c -- -- (b1 brother c1, b2 brother c2) if -- (?a daughter b1, ?a son c1) && (?a daughter b2, ?a son c2) graph45 :: RDFGraph graph45 = gr4 $ "pers:Rh4 rel:brother pers:Ro4 . \n" `mappend` "pers:Ma3 rel:brother pers:Wi3 . \n" query45 :: RDFGraph query45 = gr4 "?b rel:brother ?c . \n" result45 :: RDFGraph result45 = gr4 $ "?a rel:daughter ?b . \n" `mappend` "?a rel:son ?c . \n" result45a1, result45a2 :: B.Builder result45a1 = mconcat [ prefix4 , "?a rel:daughter pers:Rh4 . \n" , "?a rel:son pers:Ro4 . \n" ] result45a2 = mconcat [ prefix4 , "?a rel:daughter pers:Ma3 . \n" , "?a rel:son pers:Wi3 . \n" ] unbound45a1, unbound45a2 :: [RDFLabel] unbound45a1 = [Var "a"] unbound45a2 = [Var "a"] var45 :: [[RDFVarBinding]] var45 = rdfQueryBack query45 graph45 res45 :: [[(RDFGraph, [RDFLabel])]] res45 = rdfQueryBackSubs var45 result45 res45_1 :: [(RDFGraph, [RDFLabel])] res45_1 = get1 $ res45 res45_11, res45_12 :: (RDFGraph, [RDFLabel]) (res45_11, res45_12) = get2 $ res45_1 -- test46: multiple ways to get solution -- -- (?c son ?a, ?c stepSon b) => (?a stepBrother ?b, ?b stepBrother ?a) -- -- a stepBrother b if -- (_:c1 son a, _:c1 stepSon b) || (_:c2 stepSon a, _:c2 son b) graph46 :: RDFGraph graph46 = gr4 "pers:Gr3 rel:stepbrother pers:St3 . \n" query46 :: RDFGraph query46 = gr4 $ "?b rel:stepbrother ?c . \n" `mappend` "?c rel:stepbrother ?b . \n" result46 :: RDFGraph result46 = gr4 $ "?a rel:son ?b . \n" `mappend` "?a rel:stepson ?c . \n" result46a, result46b :: B.Builder result46a = mconcat [ prefix4 , "?a rel:son pers:Gr3 . \n" , "?a rel:stepson pers:St3 . \n" ] result46b = mconcat [ prefix4 , "?a rel:son pers:St3 . \n" , "?a rel:stepson pers:Gr3 . \n" ] unbound46a, unbound46b :: [RDFLabel] unbound46a = [Var "a"] unbound46b = [Var "a"] var46 :: [[RDFVarBinding]] var46 = rdfQueryBack query46 graph46 res46 :: [[(RDFGraph, [RDFLabel])]] res46 = rdfQueryBackSubs var46 result46 res46_1, res46_2 :: [(RDFGraph, [RDFLabel])] (res46_1, res46_2) = get2 res46 res46_11, res46_21 :: (RDFGraph, [RDFLabel]) res46_11 = get1 res46_1 res46_21 = get1 res46_2 -- test47: multiple ways to multiple solutions -- -- (?c son ?a, ?c stepSon b) => (?a stepBrother ?b, ?b stepBrother ?a) -- -- (a stepBrother b, c stepBrother d) if -- ((_:e son a, _:e stepSon b) && (_:f son a, _:f stepSon b)) || -- ((_:e son a, _:e stepSon b) && (_:f stepSon a, _:f son b)) || -- ((_:e stepSon a, _:e son b) && (_:f son a, _:f stepSon b)) || -- ((_:e stepSon a, _:e son b) && (_:f stepSon a, _:f son b)) graph47 :: RDFGraph graph47 = gr4 $ "pers:Gr3 rel:stepbrother pers:St3 . \n" `mappend` "pers:St3 rel:stepbrother pers:Gr3 . \n" query47 :: RDFGraph query47 = gr4 $ "?b rel:stepbrother ?c . \n" `mappend` "?c rel:stepbrother ?b . \n" result47 :: RDFGraph result47 = gr4 $ "?a rel:son ?b . \n" `mappend` "?a rel:stepson ?c . \n" result47a1, result47a2, result47b1, result47b2, result47c1, result47c2, result47d1, result47d2 :: B.Builder result47a1 = b4 [ "?a rel:son pers:St3 . \n" , "?a rel:stepson pers:Gr3 . \n"] result47a2 = b4 [ "?a rel:son pers:Gr3 . \n" , "?a rel:stepson pers:St3 . \n"] result47b1 = b4 [ "?a rel:stepson pers:St3 . \n" , "?a rel:son pers:Gr3 . \n"] result47b2 = b4 [ "?a rel:stepson pers:St3 . \n" , "?a rel:son pers:Gr3 . \n"] result47c1 = b4 [ "?a rel:son pers:St3 . \n" , "?a rel:stepson pers:Gr3 . \n"] result47c2 = b4 [ "?a rel:son pers:St3 . \n" , "?a rel:stepson pers:Gr3 . \n"] result47d1 = b4 [ "?a rel:stepson pers:St3 . \n" , "?a rel:son pers:Gr3 . \n"] result47d2 = b4 [ "?a rel:son pers:St3 . \n" , "?a rel:stepson pers:Gr3 . \n"] unbound47a1, unbound47a2, unbound47b1, unbound47b2, unbound47c1, unbound47c2, unbound47d1, unbound47d2 :: [RDFLabel] unbound47a1 = [Var "a"] unbound47a2 = [Var "a"] unbound47b1 = [Var "a"] unbound47b2 = [Var "a"] unbound47c1 = [Var "a"] unbound47c2 = [Var "a"] unbound47d1 = [Var "a"] unbound47d2 = [Var "a"] var47 :: [[RDFVarBinding]] var47 = rdfQueryBack query47 graph47 res47 :: [[(RDFGraph, [RDFLabel])]] res47 = rdfQueryBackSubs var47 result47 res47_1, res47_2, res47_3, res47_4 :: [(RDFGraph, [RDFLabel])] (res47_1, res47_2, res47_3, res47_4) = case res47 of [a, b, c, d] -> (a, b, c, d) _ -> error "Expected 4 answers" res47_11, res47_12, res47_21, res47_22, res47_31, res47_32, res47_41, res47_42 :: (RDFGraph, [RDFLabel]) (res47_11, res47_12) = get2 res47_1 (res47_21, res47_22) = get2 res47_2 (res47_31, res47_32) = get2 res47_3 (res47_41, res47_42) = get2 res47_4 -- test48: redundant multiple ways to get solution -- -- (?a son ?b, ?a son ?c) => (?b brother ?c, ?c brother ?b) -- -- (a brother b) if -- (_:c1 son a, _:c1 son b) || (_:c2 son b, _:c2 son a) graph48 :: RDFGraph graph48 = gr4 "pers:Gr3 rel:brother pers:La3 . \n" query48 :: RDFGraph query48 = gr4 $ "?b rel:brother ?c . \n" `mappend` "?c rel:brother ?b . \n" result48 :: RDFGraph result48 = gr4 $ "?a rel:son ?b . \n" `mappend` "?a rel:son ?c . \n" result48a, result48b :: B.Builder result48a = b4 [ "?a rel:son pers:La3 . \n" , "?a rel:son pers:Gr3 . \n"] result48b = b4 [ "?a rel:son pers:Gr3 . \n" , "?a rel:son pers:La3 . \n"] unbound48a, unbound48b :: [RDFLabel] unbound48a = [Var "a"] unbound48b = [Var "a"] var48 :: [[RDFVarBinding]] var48 = rdfQueryBack query48 graph48 res48 :: [[(RDFGraph, [RDFLabel])]] res48 = rdfQueryBackSubs var48 result48 res48_1, res48_2 :: [(RDFGraph, [RDFLabel])] (res48_1, res48_2) = get2 res48 res48_11, res48_21 :: (RDFGraph, [RDFLabel]) res48_11 = get1 res48_1 res48_21 = get1 res48_2 -- test49: goal not satisfiable by rule -- -- (?a foo ?b, ?b foo ?a) => (?a bar ?a) -- -- (a bar b) cannot be deduced directly graph49 :: RDFGraph graph49 = gr4l ["pers:Gr3 rel:foo pers:La3 . \n"] query49 :: RDFGraph query49 = gr4l ["?a rel:bar ?a . \n"] result49 :: RDFGraph result49 = gr4l [ "?a rel:foo ?b . \n" , "?b rel:foo ?a . \n"] var49 :: [[RDFVarBinding]] var49 = rdfQueryBack query49 graph49 res49 :: [[(RDFGraph, [RDFLabel])]] res49 = rdfQueryBackSubs var49 result49 -- test50: back-chaining with filter -- -- (?a son ?b, ?a son ?c) => (?b brother ?c, ?c brother ?b) -- -- (a brother b) if -- (_:c1 son a, _:c1 son b) || (_:c2 son b, _:c2 son a) graph50 :: RDFGraph graph50 = gr4l ["pers:Gr3 rel:brother pers:Gr3 . \n"] query50 :: RDFGraph query50 = gr4l [ "?b rel:brother ?c . \n" , "?c rel:brother ?b . \n"] result50 :: RDFGraph result50 = gr4l [ "?a rel:son ?b . \n" , "?a rel:son ?c . \n"] result50a, result50b :: B.Builder result50a = b4 [ "?a rel:son pers:Gr3 . \n" , "?a rel:son pers:Gr3 . \n"] result50b = b4 [ "?a rel:son pers:Gr3 . \n" , "?a rel:son pers:Gr3 . \n"] unbound50a, unbound50b :: [RDFLabel] unbound50a = [Var "a"] unbound50b = [Var "a"] var50 :: [[RDFVarBinding]] var50 = rdfQueryBack query50 graph50 res50 :: [[(RDFGraph, [RDFLabel])]] res50 = rdfQueryBackSubs var50 result50 res50_1, res50_2 :: [(RDFGraph, [RDFLabel])] (res50_1, res50_2) = get2 res50 res50_11, res50_21 :: (RDFGraph, [RDFLabel]) res50_11 = get1 res50_1 res50_21 = get1 res50_2 filter50 :: RDFVarBindingFilter filter50 = varFilterNE (Var "b") (Var "c") var50F :: [[RDFVarBinding]] var50F = rdfQueryBackFilter filter50 var50 res50F :: [[(RDFGraph, [RDFLabel])]] res50F = rdfQueryBackSubs var50F result50 -- Backward substitution query test suite test4 :: Test test4 = TestList [ test "testQuery41" (not $ null var41) , testEq "testQuery41a" 1 (length var41) , testEq "testResult41" 1 (length res41) , testGr "testResult41a" result41a (map fst (head res41)) , testEqv "testUnbound41a" [] (snd $ head $ head res41) , test "testQuery42" (not $ null var42) , testEq "testQuery42a" 1 (length var42) , testEq "testResult42" 1 (length res42) , testGr "testResult42a" result42a (map fst (head res42)) , testEqv "testUnbound42a" [Var "b"] (snd $ head $ head res42) , test "testQuery43" (not $ null var43) , testEq "testQuery43a" 1 (length var43) , testEq "testResult43" 1 (length res43) , testGr "testResult43a" result43a (map fst (head res43)) , testEqv "testUnbound43a" [Var "a"] (snd $ head $ head res43) , test "testQuery44" (not $ null var44) , testEq "testQuery44a" 2 (length var44) , testEq "testResult44" 2 (length res44) , testGr "testResult44a" result44a (map fst res44_2) , testEqv "testUnbound44a" unbound44a (snd $ head res44_2) , testGr "testResult44b" result44b (map fst res44_1) , testEqv "testUnbound44b" unbound44b (snd $ head res44_1) , test "testQuery45" (not $ null var45) , testEq "testQuery45a" 1 (length var45) , testEq "testResult45" 1 (length res45) , testEq "testResult45_1" 2 (length res45_1) , testGr "testResult45a1" result45a1 [fst res45_11] , testEqv "testUnbound45a1" unbound45a1 (snd res45_11) , testGr "testResult45a2" result45a2 [fst res45_12] , testEqv "testUnbound45a2" unbound45a2 (snd res45_12) , test "testQuery46" (not $ null var46) , testEq "testQuery46a" 2 (length var46) , testEq "testResult46" 2 (length res46) , testEq "testResult46_1" 1 (length res46_1) , testEq "testResult46_2" 1 (length res46_2) , testGr "testResult46a" result46a [fst res46_11] , testEqv "testUnbound46a" unbound46a (snd res46_11) , testGr "testResult46b" result46b [fst res46_21] , testEqv "testUnbound46b" unbound46b (snd res46_21) , test "testQuery47" (not $ null var47) , testEq "testQuery47a" 4 (length var47) , testEq "testResult47" 4 (length res47) , testEq "testResult47_1" 2 (length res47_1) , testEq "testResult47_2" 2 (length res47_2) , testEq "testResult47_3" 2 (length res47_3) , testEq "testResult47_4" 2 (length res47_4) , testGr "testResult47a1" result47a1 [fst res47_11] , testEqv "testUnbound47a1" unbound47a1 (snd res47_11) , testGr "testResult47a2" result47a2 [fst res47_12] , testEqv "testUnbound47a2" unbound47a2 (snd res47_12) , testGr "testResult47b1" result47b1 [fst res47_21] , testEqv "testUnbound47b1" unbound47b1 (snd res47_21) , testGr "testResult47b2" result47b2 [fst res47_22] , testEqv "testUnbound47b2" unbound47b2 (snd res47_22) , testGr "testResult47c1" result47c1 [fst res47_31] , testEqv "testUnbound47c1" unbound47c1 (snd res47_31) , testGr "testResult47c2" result47c2 [fst res47_32] , testEqv "testUnbound47c2" unbound47c2 (snd res47_32) , testGr "testResult47d1" result47d1 [fst res47_41] , testEqv "testUnbound47d1" unbound47d1 (snd res47_41) , testGr "testResult47d2" result47d2 [fst res47_42] , testEqv "testUnbound47d2" unbound47d2 (snd res47_42) , test "testQuery48" (not $ null var48) , testEq "testQuery48a" 2 (length var48) , testEq "testResult48" 2 (length res48) , testEq "testResult48_1" 1 (length res48_1) , testEq "testResult48_2" 1 (length res48_2) , testGr "testResult48a" result48a [fst res48_11] , testEqv "testUnbound48a" unbound48a (snd res48_11) , testGr "testResult48b" result48b [fst res48_21] , testEqv "testUnbound48b" unbound48b (snd res48_21) , test "testQuery49" (null var49) , testEq "testQuery49a" 0 (length var49) , testEq "testResult49" 0 (length res49) , test "testQuery50" (not $ null var50) , testEq "testQuery50a" 2 (length var50) , testEq "testResult50" 2 (length res50) , testEq "testResult50_1" 1 (length res50_1) , testEq "testResult50_2" 1 (length res50_2) , testGr "testResult50a" result50a [fst res50_11] , testEqv "testUnbound50a" unbound50a (snd res50_11) , testGr "testResult50b" result50b [fst res50_21] , testEqv "testUnbound50b" unbound50b (snd res50_21) , testEq "testResult50F" 0 (length res50F) ] ------------------------------------------------------------ -- Instance query test suite ------------------------------------------------------------ -- -- The test plan is this: -- (1) perform a backward chaining query against some desired result. -- ?f father ?a, ?f father ?b, ?a /= ?b => ?a brother ?b -- against -- Gr3 brother La3, Gr3 brother Si3 -- should yield: -- _:a father Gr3 -- _:a father La3 -- _:b father Gr3 -- _:b father Si3 -- (2) Perform instance query of result against 'graph2' (see above) -- should yield: -- _:a = Pa2 -- _:b = Pa2 -- (3) Substitute this into query, should yield: -- Pa2 father Gr3 -- Pa2 father La3 -- Pa2 father Gr3 -- Pa2 father Si3 -- (4) Use this result in an instance query against 'graph2': it should -- match without any variable substitutions, indicating that it is -- a subgraph graph61 :: RDFGraph graph61 = gr4l [ "pers:Gr3 rel:brother pers:La3 . \n" , "pers:Gr3 rel:brother pers:Si3 . \n"] query61 :: RDFGraph query61 = gr4l ["?b rel:brother ?c . \n"] result61 :: RDFGraph result61 = gr4l [ "?a rel:son ?b . \n" , "?a rel:son ?c . \n"] result61a, result63a :: B.Builder result61a = b4 [ "_:a1 rel:son pers:Gr3 . \n" , "_:a1 rel:son pers:La3 . \n" , "_:a2 rel:son pers:Gr3 . \n" , "_:a2 rel:son pers:Si3 . \n"] result63a = b4 [ "pers:Pa2 rel:son pers:Gr3 . \n" , "pers:Pa2 rel:son pers:La3 . \n" , "pers:Pa2 rel:son pers:Gr3 . \n" , "pers:Pa2 rel:son pers:Si3 . \n"] -- 1. Backchain query with blank substutions var61 :: [[RDFVarBinding]] var61 = rdfQueryBack query61 graph61 res61 :: [[RDFGraph]] res61 = rdfQueryBackSubsBlank var61 result61 res61a1, res61a2, res61a :: RDFGraph (res61a1, res61a2) = get2 $ get1 $ res61 res61a = merge res61a1 res61a2 -- 2. Instance query against 'graph2' var62 :: [RDFVarBinding] var62 = rdfQueryInstance res61a graph2 -- 3. Substitute into instance query graph res63 :: [RDFGraph] res63 = rdfQuerySubs var62 res61a res63a :: RDFGraph res63a = get1 res63 -- 4. Repeat instance query against 'graph2' -- Query bindings should be null. var64 :: [RDFVarBinding] var64 = rdfQueryInstance res63a graph2 var64a :: RDFVarBinding var64a = get1 var64 test6 :: Test test6 = TestList [ test "testQuery61" (not $ null var61) , testEq "testQuery61a" 1 (length var61) , testEq "testResult61" 1 (length res61) , testGr "testResult61a" result61a [res61a] , test "testQuery62" (not $ null var62) , testEq "testQuery62a" 1 (length var62) , test "testQuery63" (not $ null res63) , testEq "testQuery63a" 1 (length res63) , testGr "testResult63a" result63a [res63a] , test "testQuery64" (not $ null var64) , testEq "testQuery64a" 1 (length var64) , test "testQuery64b" (S.null $ vbEnum var64a) ] ------------------------------------------------------------ -- Specific test cases ------------------------------------------------------------ -- Back-chaining query binding modifier -- Set up call of rdfQueryBackModify -- (1) simple filter -- (2) allocate new binding {- rdfQueryBackModify :: RDFVarBindingModify -> [[RDFVarBinding]] -> [[RDFVarBinding]] rdfQueryBackModify qbm qbss = concatMap (rdfQueryBackModify1 qbm) qbss -} toURI :: String -> URI toURI = fromJust . parseURI baseex :: URI baseex = toURI "http://example.org/" baserdf :: URI baserdf = getNamespaceURI namespaceRDF q_dattyp :: ScopedName q_dattyp = makeScopedName Nothing baseex "datatype" v_a, v_b, v_c, v_x, v_y, v_z :: RDFLabel v_a = Var "a" v_b = Var "b" v_c = Var "c" v_x = Var "x" v_y = Var "y" v_z = Var "z" u_s, u_o, u_p, u_p1, u_p2a, u_p2b, u_m1, u_m2, u_rt, u_xt, u_dt :: RDFLabel u_s = Res $ makeScopedName Nothing baseex "s" u_o = Res $ makeScopedName Nothing baseex "o" u_p = Res $ makeScopedName Nothing baseex "p" u_p1 = Res $ makeScopedName Nothing baseex "p1" u_p2a = Res $ makeScopedName Nothing baseex "p2a" u_p2b = Res $ makeScopedName Nothing baseex "p2b" u_m1 = Res $ makeScopedName Nothing baserdf "_1" u_m2 = Res $ makeScopedName Nothing baserdf "_2" u_rt = Res rdfType u_xt = Res rdfXMLLiteral u_dt = Res q_dattyp l_1, l_2, l_3, l_4, l_5 :: RDFLabel 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" b_2 = Blank "2" b_3 = Blank "3" b_l1 = Blank "l1" b_l2 = Blank "l2" vbss01a, vbss01b, vbss01c, vbss01d, vbss01e, vbss01f, vbss01g, vbss01h, vbss01i :: [RDFVarBinding] vbss01a = -- ?a is uri, ?b is uri [ makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,u_o) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,b_1) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_1) ] ] vbss01b = -- ?c is blank [ makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,b_1) ] ] vbss01c = -- ?c is literal [ makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_1) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_2) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_3) ] ] vbss01d = -- ?c is untyped literal [ makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_1) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_2) ] ] vbss01e = -- ?c is typed literal [ makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_3) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_4) ] , makeVarBinding [ (v_a,b_3), (v_b,u_p), (v_c,l_5) ] ] vbss01f = -- ?c is XML literal [ makeVarBinding [ (v_a,b_1), (v_b,u_p), (v_c,l_5) ] ] vbss01g = -- ?b is member property [ makeVarBinding [ (v_a,b_1), (v_b,u_m1), (v_c,u_o) ] , makeVarBinding [ (v_a,u_s), (v_b,u_m2), (v_c,b_1) ] ] vbss01h = -- ?c is datatyped with ?x [ makeVarBinding [ (v_a,b_1), (v_b,u_p), (v_c,l_3), (v_x,u_dt) ] , makeVarBinding [ (v_a,b_2), (v_b,u_p), (v_c,l_4), (v_x,u_dt) ] , makeVarBinding [ (v_a,u_s), (v_b,u_p), (v_c,l_5), (v_x,u_xt) ] ] vbss01i = -- ?c is not datatyped with ?x [ makeVarBinding [ (v_a,b_1), (v_b,u_p), (v_c,l_3), (v_x,u_dt) ] , makeVarBinding [ (v_a,b_2), (v_b,u_p), (v_c,l_4), (v_x,u_xt) ] , makeVarBinding [ (v_a,b_3), (v_b,u_p), (v_c,l_5), (v_x,u_xt) ] ] vbss01 :: [[RDFVarBinding]] vbss01 = [ vbss01a -- ?a is uri, ?b is uri , vbss01b -- ?c is blank , vbss01c -- ?c is literal , vbss01d -- ?c is untyped literal , vbss01e -- ?c is typed literal , vbss01f -- ?c is XML literal , vbss01g -- ?b is member property , vbss01h -- ?c is datatyped with ?x , vbss01i -- ?c is not datatyped with ?x ] vbss02a, vbss02b, vbss02c, vbss02d :: [RDFVarBinding] vbss02a = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_b,b_l1) ] , makeVarBinding [ (v_b,b_l2) ] ] vbss02b = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_xt) ] , makeVarBinding [ (v_b,b_l2) ] ] vbss02c = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_b,b_l1) ] , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_xt) ] ] vbss02d = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_xt) ] , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_xt) ] ] vbss02 :: [[RDFVarBinding]] vbss02 = [ vbss02a , vbss02b , vbss02c , vbss02d ] -- Variable binding modifier that adds new bindings, if certain -- others are present. vbm22 :: VarBindingModify RDFLabel RDFLabel vbm22 = VarBindingModify { vbmName = swishName "vbm22" , vbmApply = concatMap apply1 , vbmVocab = [v_a,v_b,v_x,v_y] , vbmUsage = [[v_y]] } where apply1 :: RDFVarBinding -> [RDFVarBinding] apply1 vb = apply2 vb (vbMap vb v_a) (vbMap vb v_b) (vbMap vb v_x) apply2 vb (Just a) (Just b) (Just _) = [ joinVarBindings nva vb, joinVarBindings nvb vb ] where nva = makeVarBinding [(v_y,a)] nvb = makeVarBinding [(v_y,b)] apply2 _ _ _ _ = [] vbss02dy :: [[RDFVarBinding]] vbss02dy = sequence [ [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1), (v_y,u_p1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1), (v_y,b_l1) ] ] , [ makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2), (v_y,u_p2a) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2), (v_y,b_l2) ] ] , [ makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2), (v_y,u_p2b) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2), (v_y,b_l2) ] ] , [ makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_xt), (v_y,u_rt) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_xt), (v_y,u_xt) ] ] , [ makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_xt), (v_y,u_rt) ] , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_xt), (v_y,u_xt) ] ] ] -- simplified version of above for debugging -- vbss03a :: [RDFVarBinding] vbss03a = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_b,b_l1) ] ] vbss03b :: [RDFVarBinding] vbss03b = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] ] vbss03 :: [[RDFVarBinding]] vbss03 = [ vbss03a , vbss03b ] vbss03by :: [[RDFVarBinding]] vbss03by = sequence [ [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1), (v_y,u_p1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1), (v_y,b_l1) ] ] , [ makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2), (v_y,u_p2a) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2), (v_y,b_l2) ] ] ] test7 :: Test test7 = TestList [ testEq "testBackMod01" vbss01 $ rdfQueryBackModify varBindingId vbss01 , testEq "testBackMod02" [vbss01a,vbss01b,vbss01c,vbss01d] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingUriRef v_a) vbss01 , testEq "testBackMod03" [vbss01f,vbss01i] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingBlank v_a) vbss01 , testEq "testBackMod04" vbss01 $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingUriRef v_b) vbss01 , testEq "testBackMod05" [vbss01c,vbss01d,vbss01e,vbss01f,vbss01h,vbss01i] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingLiteral v_c) vbss01 , testEq "testBackMod06" [vbss01d] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingUntypedLiteral v_c) vbss01 , testEq "testBackMod07" [vbss01e,vbss01f,vbss01h,vbss01i] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingTypedLiteral v_c) vbss01 , testEq "testBackMod08" [vbss01f] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingXMLLiteral v_c) vbss01 , testEq "testBackMod09" [vbss01g] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingMemberProp v_b) vbss01 , testEq "testBackMod10" [vbss01h] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingDatatyped v_x v_c) vbss01 , testEq "testBackMod20" vbss02 $ rdfQueryBackModify varBindingId vbss02 , testEq "testBackMod21" [vbss02d] $ rdfQueryBackModify (makeVarFilterModify $ rdfVarBindingUriRef v_a) vbss02 , testEq "testBackMod22" vbss02dy $ rdfQueryBackModify vbm22 vbss02 , testEq "testBackMod30" vbss03by $ rdfQueryBackModify vbm22 vbss03 ] ------------------------------------------------------------ -- Test simple value and list queries ------------------------------------------------------------ {- TODO: for now remove this from the test since it uses :- namespacetest, namespacelist :: Namespace namespacetest = Namespace "test" "urn:test:" namespacelist = Namespace "list" "urn:list:" qntest, qnlist :: String -> ScopedName qntest loc = ScopedName namespacetest loc qnlist loc = ScopedName namespacelist loc prefixlist :: String prefixlist = "@prefix rdf : <" ++ nsURI namespaceRDF ++ "> . \n" ++ "@prefix xsd : <" ++ nsURI namespaceXSD ++ "> . \n" ++ "@prefix test : <" ++ nsURI namespacetest ++ "> . \n" ++ "@prefix list : <" ++ nsURI namespacelist ++ "> . \n" ++ " \n" graphlist = graphFromBuilder graphliststr graphliststr = prefixlist ++ "test:a rdf:type test:C1 ; " ++ " test:p test:item1 ; " ++ " test:p test:item2 . " ++ "test:b rdf:type test:C1 ; " ++ " test:p \"1\"^^xsd:integer ; " ++ " test:p \"2\"^^xsd:integer ; " ++ " test:p \"3\"^^xsd:integer . " ++ "test:c rdf:type test:C1 ; " ++ " test:q \"1\"^^xsd:integer ; " ++ " test:q \"2\"^^xsd:boolean ; " ++ " test:q \"3\" . " ++ "list:three :- (list:_1 list:_2 list:_3) . \n" ++ "list:empty :- () . \n" testC1 = Res (qntest "C1") testabc = [ Res (qntest "a"),Res (qntest "b"),Res (qntest "c") ] testp = Res (qntest "p") testq = Res (qntest "q") testi12 = [ Res (qntest "item1"),Res (qntest "item2") ] test123 = [ Lit "1" (Just xsd_integer) , Lit "2" (Just xsd_integer) , Lit "3" (Just xsd_integer) ] test1fp = [ Lit "1" (Just xsd_integer) , Lit "2" (Just xsd_boolean) , Lit "3" Nothing ] list01 = [Res (qnlist "_1"),Res (qnlist "_2"),Res (qnlist "_3")] list02 = [] testVal01 = testEqv "testVal01" testabc $ rdfFindValSubj res_rdfType testC1 graphlist testVal02 = testEqv "testVal02" testi12 $ rdfFindPredVal (testabc!!0) testp graphlist testVal03 = testEqv "testVal03" test123 $ rdfFindPredVal (testabc!!1) testp graphlist testVal04 = testEqv "testVal04" test1fp $ rdfFindPredVal (testabc!!2) testq graphlist testVal05 = testEqv "testVal05" [] $ rdfFindPredVal (testabc!!2) testp graphlist testVal06 = testEqv "testVal06" [] $ rdfFindPredInt (testabc!!0) testp graphlist testVal07 = testEqv "testVal07" [1,2,3] $ rdfFindPredInt (testabc!!1) testp graphlist testVal08 = testEqv "testVal08" [1] $ rdfFindPredInt (testabc!!2) testq graphlist testlist01 = testEq "testlist01" list01 $ rdfFindList graphlist (Res $ qnlist "three") testlist02 = testEq "testlist02" list02 $ rdfFindList graphlist (Res $ qnlist "empty") test8 = TestList [ testVal01, testVal02, testVal03, testVal04 , testVal05, testVal06, testVal07, testVal08 , testlist01, testlist02 ] -} {----- queryList :: RDFGraph -> RDFLabel -> [RDFLabel] -- queryList gr res_rdf_nil = [] -- queryList gr hd = findhead g:rdfQueryList gr (findrest g) queryList gr hd | hd == res_rdf_nil = [] | otherwise = (findhead g):(queryList gr (findrest g)) where g = subgr gr hd findhead g = headOrNil [ ob | Arc _ sb ob <- g, sb == res_rdf_first ] findrest g = headOrNil [ ob | Arc _ sb ob <- g, sb == res_rdf_rest ] subgr g h = filter ((==) h . arcSubj) $ getArcs g headOrNil = foldr const res_rdf_nil th1 = (Res $ qnlist "empty") th3 = (Res $ qnlist "three") th3a = subgr graphlist th3 th3b = findhead th3a th3c = findrest th3a tl3c = queryList graphlist th3c th3d = subgr graphlist th3c th3e = findhead th3d th3f = findrest th3d tl3 = queryList graphlist th3 -----} ------------------------------------------------------------ -- Full test suite, main program, -- and useful expressions for interactive use ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "1" test1 , conv "2" test2 , conv "3" test3 , conv "4" test4 , conv "6" test6 , conv "7" test7 -- , test8 ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2018, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFProofTest.hs0000644000000000000000000007416513543702315015254 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFProofTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module tests the RDFproof module, which instantiates the proof -- rule class over RDF graphs. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF 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.Ruleset ( RDFRule , makeRDFGraphFromN3Builder , makeN3ClosureAllocatorRule , makeN3ClosureRule , makeN3ClosureSimpleRule , makeNodeAllocTo ) import Swish.RDF.Query (rdfQueryFind, rdfQuerySubs) import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingModify) import Swish.RDF.Graph ( Label(..), RDFLabel(..), RDFGraph , addGraphs, allLabels, allNodes ) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Maybe (fromJust) import Network.URI (URI, parseURI) import Test.HUnit ( Test(TestList) ) import TestHelpers ( conv, test , testEq, testElem , testNo ) -- misc helpers testIn :: (Eq a, Show a) => String -> a -> [a] -> Test testIn = testElem -- lab eg a = TestCase $ assertBool lab (eg `elem` a) mkGr :: B.Builder -> [B.Builder] -> RDFGraph mkGr pr bdy = makeRDFGraphFromN3Builder $ mconcat (pr : bdy) mkGr1, mkGr2 :: [B.Builder] -> RDFGraph mkGr1 = mkGr prefix1 mkGr2 = mkGr prefix2 toURI :: String -> URI toURI = fromJust . parseURI toNS :: Maybe T.Text -> String -> Namespace toNS p = makeNamespace p . toURI -- test1: simple query with URI, literal and blank nodes. scope1 :: Namespace scope1 = toNS (Just "scope1") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope1" prefix1 :: B.Builder prefix1 = "@prefix ex: . \n" graph1 :: RDFGraph graph1 = mkGr1 ["ex:s1 ex:p ex:o1 . \n" , "ex:s2 ex:p \"lit1\" . \n" , "[ ex:p ex:o3 ] . \n" ] query11 :: RDFGraph query11 = makeRDFGraphFromN3Builder query11str query11str :: B.Builder query11str = prefix1 `mappend` "?s ex:p ?o . \n" result11 :: RDFGraph result11 = makeRDFGraphFromN3Builder result11str result11str :: B.Builder result11str = prefix1 `mappend` "?s ex:r ?o . \n" result11a :: RDFGraph result11a = mkGr1 [ "ex:s1 ex:r ex:o1 . \n" , "ex:s2 ex:r \"lit1\" . \n" , "[ ex:r ex:o3 ] . \n" ] result11b :: RDFGraph result11b = mkGr1 ["ex:s1 ex:r ex:o1 . \n"] result11c :: RDFGraph result11c = mkGr1 ["ex:s2 ex:r \"lit1\" . \n"] backsub11a :: RDFGraph backsub11a = mkGr1 [ "ex:s1 ex:p ex:o1 . \n" , "ex:s2 ex:p \"lit1\" . \n" ] backsub11b :: RDFGraph backsub11b = mkGr1 ["ex:s2 ex:p \"lit1\" . \n"] rul11 :: RDFRule rul11 = makeN3ClosureSimpleRule scope1 "rul11" query11str result11str fwd11 :: [RDFGraph] fwd11 = fwdApply rul11 [graph1] bwd11 :: [[RDFGraph]] bwd11 = bwdApply rul11 (addGraphs result11b result11c) test1 :: Test test1 = TestList [ testEq "testFwd11" 1 (length fwd11) , testIn "testFwd11a" result11a fwd11 , testEq "testBwd11" 1 (length (head bwd11)) , testIn "testBwd11a" backsub11a (head bwd11) ] -- test2: a range of more complex queries based on a -- single relationship graph. scope2 :: Namespace scope2 = toNS (Just "scope2") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope2" prefix2 :: B.Builder prefix2 = "@prefix pers: . \n" `mappend` "@prefix rel: . \n" graph2 :: RDFGraph graph2 = mkGr2 [ "pers:St1 rel:wife pers:Do1 ; \n" , " rel:daughter pers:Ma2 ; \n" , " rel:daughter pers:An2 . \n" , "pers:Pa2 rel:wife pers:Ma2 ; \n" , " rel:son pers:Gr3 ; \n" , " rel:son pers:La3 ; \n" , " rel:son pers:Si3 ; \n" , " rel:son pers:Al3 . \n" , "pers:Br2 rel:wife pers:Ri2 ; \n" , " rel:daughter pers:Ma3 ; \n" , " rel:son pers:Wi3 . \n" , "pers:Gr3 rel:wife pers:Ma3 ; \n" , " rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" , "pers:Si3 rel:wife pers:Jo3 ; \n" , " rel:son pers:Ol4 ; \n" , " rel:son pers:Lo4 . \n" , "pers:Al3 rel:wife pers:Su3 ; \n" , " rel:son pers:Ha4 ; \n" , " rel:son pers:El4 . \n" ] query21 :: RDFGraph query21 = makeRDFGraphFromN3Builder query21str query21str :: B.Builder query21str = prefix2 `mappend` "?a rel:wife ?b . \n" result21 :: RDFGraph result21 = makeRDFGraphFromN3Builder result21str result21str :: B.Builder result21str = prefix2 `mappend` "?b rel:husband ?a . \n" result21a :: RDFGraph result21a = mkGr2 [ "pers:Do1 rel:husband pers:St1 . \n" , "pers:Ma2 rel:husband pers:Pa2 . \n" , "pers:Ri2 rel:husband pers:Br2 . \n" , "pers:Ma3 rel:husband pers:Gr3 . \n" , "pers:Jo3 rel:husband pers:Si3 . \n" , "pers:Su3 rel:husband pers:Al3 . \n" ] result21b :: RDFGraph result21b = mkGr2 [ "pers:Do1 rel:husband pers:St1 . \n" , "pers:Ma2 rel:husband pers:Pa2 . \n" ] bwd21a :: RDFGraph bwd21a = mkGr2 [ "pers:St1 rel:wife pers:Do1 . \n" , "pers:Pa2 rel:wife pers:Ma2 . \n" ] rul21 :: RDFRule rul21 = makeN3ClosureSimpleRule scope2 "rul21" query21str result21str fwd21 :: [RDFGraph] fwd21 = fwdApply rul21 [graph2] bwd21 :: [[RDFGraph]] bwd21 = bwdApply rul21 result21b query22 :: RDFGraph query22 = makeRDFGraphFromN3Builder query22str query22str :: B.Builder query22str = mconcat [ prefix2 , "?a rel:son ?b . \n" , "?b rel:son ?c . \n" ] result22 :: RDFGraph result22 = makeRDFGraphFromN3Builder result22str result22str :: B.Builder result22str = prefix2 `mappend` "?a rel:grandparent ?c . \n" result22a :: RDFGraph result22a = mkGr2 [ "pers:Pa2 rel:grandparent pers:Ro4 . \n" , "pers:Pa2 rel:grandparent pers:Ol4 . \n" , "pers:Pa2 rel:grandparent pers:Lo4 . \n" , "pers:Pa2 rel:grandparent pers:Ha4 . \n" , "pers:Pa2 rel:grandparent pers:El4 . \n" ] result22b :: RDFGraph result22b = mkGr2 [ "pers:Pa2 rel:grandparent pers:Ro4 . \n" , "pers:Pa2 rel:grandparent pers:Ol4 . \n" ] bwd22a :: RDFGraph bwd22a = mkGr2 [ "pers:Pa2 rel:son _:p1 . \n" , "_:p1 rel:son pers:Ro4 . \n" , "pers:Pa2 rel:son _:p2 . \n" , "_:p2 rel:son pers:Ol4 . \n" ] rul22 :: RDFRule rul22 = makeN3ClosureSimpleRule scope2 "rul22" query22str result22str fwd22 :: [RDFGraph] fwd22 = fwdApply rul22 [graph2] bwd22 :: [[RDFGraph]] bwd22 = bwdApply rul22 result22b query23 :: RDFGraph query23 = makeRDFGraphFromN3Builder query23str query23str :: B.Builder query23str = mconcat [ prefix2 , "?a rel:son ?b . \n" , "?a rel:son ?c . \n" ] result23 :: RDFGraph result23 = makeRDFGraphFromN3Builder result23str result23str :: B.Builder result23str = prefix2 `mappend` "?b rel:brother ?c . \n" result23a :: RDFGraph result23a = mkGr2 [ "pers:Gr3 rel:brother pers:Gr3 . \n" , "pers:Gr3 rel:brother pers:La3 . \n" , "pers:Gr3 rel:brother pers:Si3 . \n" , "pers:Gr3 rel:brother pers:Al3 . \n" , "pers:La3 rel:brother pers:Gr3 . \n" , "pers:La3 rel:brother pers:La3 . \n" , "pers:La3 rel:brother pers:Si3 . \n" , "pers:La3 rel:brother pers:Al3 . \n" , "pers:Si3 rel:brother pers:Gr3 . \n" , "pers:Si3 rel:brother pers:La3 . \n" , "pers:Si3 rel:brother pers:Si3 . \n" , "pers:Si3 rel:brother pers:Al3 . \n" , "pers:Al3 rel:brother pers:Gr3 . \n" , "pers:Al3 rel:brother pers:La3 . \n" , "pers:Al3 rel:brother pers:Si3 . \n" , "pers:Al3 rel:brother pers:Al3 . \n" , "pers:Wi3 rel:brother pers:Wi3 . \n" , "pers:Ro4 rel:brother pers:Ro4 . \n" , "pers:Ol4 rel:brother pers:Lo4 . \n" , "pers:Ol4 rel:brother pers:Ol4 . \n" , "pers:Lo4 rel:brother pers:Lo4 . \n" , "pers:Lo4 rel:brother pers:Ol4 . \n" , "pers:Ha4 rel:brother pers:El4 . \n" , "pers:Ha4 rel:brother pers:Ha4 . \n" , "pers:El4 rel:brother pers:El4 . \n" , "pers:El4 rel:brother pers:Ha4 . \n" ] result23b :: RDFGraph result23b = mkGr2 [ "pers:Gr3 rel:brother pers:Gr3 . \n" , "pers:Gr3 rel:brother pers:La3 . \n" ] bwd23a :: RDFGraph bwd23a = mkGr2 [ "_:a1 rel:son pers:Gr3 . \n" , "_:a1 rel:son pers:Gr3 . \n" , "_:a2 rel:son pers:Gr3 . \n" , "_:a2 rel:son pers:La3 . \n" ] rul23 :: RDFRule rul23 = makeN3ClosureSimpleRule scope2 "rul23" query23str result23str fwd23 :: [RDFGraph] fwd23 = fwdApply rul23 [graph2] bwd23 :: [[RDFGraph]] bwd23 = bwdApply rul23 result23b -- Test case to return multiple alternative bindings -- -- (?c on ?a, ?c stepSon b) => (?a stepBrother ?b, ?b stepBrother ?a) -- -- a stepBrother b if -- (_:c1 son a, _:c1 stepSon b) || (_:c2 stepSon a, _:c2 son b) graph24 :: RDFGraph graph24 = mkGr2 [ "pers:Ma2 rel:son pers:Gr3 . \n" , "pers:Ma2 rel:stepson pers:St3 . \n" ] query24 :: RDFGraph query24 = makeRDFGraphFromN3Builder query24str query24str :: B.Builder query24str = mconcat [ prefix2 , "?c rel:son ?a . \n" , "?c rel:stepson ?b . \n" ] result24 :: RDFGraph result24 = makeRDFGraphFromN3Builder result24str result24str :: B.Builder result24str = mconcat [ prefix2 , "?a rel:stepbrother ?b . \n" , "?b rel:stepbrother ?a . \n" ] result24a :: RDFGraph result24a = mkGr2 [ "pers:Gr3 rel:stepbrother pers:St3 . \n" , "pers:St3 rel:stepbrother pers:Gr3 . \n" ] bwd24a1 :: RDFGraph bwd24a1 = mkGr2 ["_:c1 rel:son pers:Gr3 . \n" , "_:c1 rel:stepson pers:St3 . \n" , "_:c2 rel:stepson pers:Gr3 . \n" , "_:c2 rel:son pers:St3 . \n" ] bwd24a2 :: RDFGraph bwd24a2 = mkGr2 [ "_:c1 rel:son pers:Gr3 . \n" , "_:c1 rel:stepson pers:St3 . \n" ] bwd24a3 :: RDFGraph bwd24a3 = mkGr2 [ "_:c2 rel:stepson pers:Gr3 . \n" , "_:c2 rel:son pers:St3 . \n" ] bwd24a4 :: RDFGraph bwd24a4 = mkGr2 [ "_:c1 rel:son pers:Gr3 . \n" , "_:c1 rel:stepson pers:St3 . \n" , "_:c2 rel:stepson pers:Gr3 . \n" , "_:c2 rel:son pers:St3 . \n" ] rul24 :: RDFRule rul24 = makeN3ClosureSimpleRule scope2 "rul24" query24str result24str fwd24 :: [RDFGraph] fwd24 = fwdApply rul24 [graph24] bwd24 :: [[RDFGraph]] bwd24 = bwdApply rul24 result24a -- bwd chain from partial conclusion -- Also, fail because conclusion is more than the rule -- can derive from any input. query25 :: RDFGraph query25 = makeRDFGraphFromN3Builder query25str query25str :: B.Builder query25str = mconcat [ prefix2 , "?a rel:son ?b . \n" , "?a rel:daughter ?c . \n" ] result25 :: RDFGraph result25 = makeRDFGraphFromN3Builder result25str result25str :: B.Builder result25str = mconcat [ prefix2 , "?b rel:sister ?c . \n" , "?c rel:brother ?b . \n" ] result25a :: RDFGraph result25a = mkGr2 [ "pers:Wi3 rel:sister pers:Ma3 . \n" , "pers:Ma3 rel:brother pers:Wi3 . \n" , "pers:Ro4 rel:sister pers:Rh4 . \n" , "pers:Rh4 rel:brother pers:Ro4 . \n" ] {- result25b = makeRDFGraphFromN3Builder result25bstr result25bstr = prefix2 ++ "pers:Ro4 rel:sister pers:Rh4 . \n" ++ "pers:Rh4 rel:brother pers:Ro4 . \n" -} result25c :: RDFGraph result25c = mkGr2 [ "pers:Wi3 rel:sister pers:Ma3 . \n" , "pers:Ma3 rel:brother pers:Wi3 . \n" , "pers:Ro4 rel:sister pers:Rh4 . \n" , "pers:Rh4 rel:brother pers:Ro4 . \n" , "pers:xx3 rel:mother pers:yy3 . \n" , "pers:yy3 rel:brother pers:xx3 . \n" ] result25d :: RDFGraph result25d = mkGr2 [ "pers:Wi3 rel:sister pers:Ma3 . \n" , "pers:Ma3 rel:brother pers:Wi3 . \n" , "pers:Ro4 rel:sister pers:Rh4 . \n" , "pers:Rh4 rel:brother pers:Ro4 . \n" , "pers:xx3 rel:father pers:yy3 . \n" ] conc25 :: RDFGraph conc25 = mkGr2 [ "pers:Wi3 rel:sister pers:Ma3 . \n" , "pers:Rh4 rel:brother pers:Ro4 . \n" ] bwd25a :: RDFGraph bwd25a = mkGr2 [ "_:a1 rel:son pers:Wi3 . \n" , "_:a1 rel:daughter pers:Ma3 . \n" , "_:a2 rel:son pers:Ro4 . \n" , "_:a2 rel:daughter pers:Rh4 . \n" ] rul25 :: RDFRule rul25 = makeN3ClosureSimpleRule scope2 "rul25" query25str result25str fwd25 :: [RDFGraph] fwd25 = fwdApply rul25 [graph2] bwd25, bwd25c, bwd25d :: [[RDFGraph]] bwd25 = bwdApply rul25 conc25 bwd25c = bwdApply rul25 result25c bwd25d = bwdApply rul25 result25d test2 :: Test test2 = TestList [ testEq "testResult21" 1 (length fwd21) , testIn "testResult21a" result21a fwd21 , testEq "testBwd21" 1 (length $ head bwd21) , testIn "testBwd21a" bwd21a (head bwd21) , testEq "testResult22" 1 (length fwd22) , testIn "testResult22a" result22a fwd22 , testEq "testBwd22" 1 (length $ head bwd22) , testIn "testBwd22a" bwd22a (head bwd22) , testEq "testResult23" 1 (length fwd23) , testIn "testResult23a" result23a fwd23 , testEq "testBwd23" 1 (length $ head bwd23) , testIn "testBwd23a" bwd23a (head bwd23) , testEq "testResult24" 1 (length fwd24) , testIn "testResult24a" result24a fwd24 , testEq "testBwd24" 4 (length bwd24) , testIn "testBwd24a1" bwd24a1 (head bwd24) , testIn "testBwd24a2" bwd24a2 (bwd24!!1) , testIn "testBwd24a3" bwd24a3 (bwd24!!2) , testIn "testBwd24a4" bwd24a4 (bwd24!!3) , testEq "testResult25" 1 (length fwd25) , testIn "testResult25a" result25a fwd25 , testEq "testBwd25" 1 (length $ head bwd25) , testIn "testBwd25a" bwd25a (head bwd25) -- testBwd25a1 = testEq "testBwd25a" bwd25a (head $ head bwd25) , testNo "testBwd25c" bwd25c , testNo "testBwd25d" bwd25d ] -- test3: check variable binding filters scope3 :: Namespace scope3 = toNS (Just "scope3") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope3" query31 :: RDFGraph query31 = makeRDFGraphFromN3Builder query31str query31str :: B.Builder query31str = mconcat [ prefix2 , "?a rel:son ?b . \n" , "?a rel:son ?c . \n" ] modify31 :: RDFVarBindingModify modify31 = makeVarFilterModify $ varFilterNE (Var "b") (Var "c") result31 :: RDFGraph result31 = makeRDFGraphFromN3Builder result31str result31str :: B.Builder result31str = prefix2 `mappend` "?b rel:brother ?c . \n" result31a :: RDFGraph result31a = mkGr2 [ "pers:Gr3 rel:brother pers:La3 . \n" , "pers:Gr3 rel:brother pers:Si3 . \n" , "pers:Gr3 rel:brother pers:Al3 . \n" , "pers:La3 rel:brother pers:Gr3 . \n" , "pers:La3 rel:brother pers:Si3 . \n" , "pers:La3 rel:brother pers:Al3 . \n" , "pers:Si3 rel:brother pers:Gr3 . \n" , "pers:Si3 rel:brother pers:La3 . \n" , "pers:Si3 rel:brother pers:Al3 . \n" , "pers:Al3 rel:brother pers:Gr3 . \n" , "pers:Al3 rel:brother pers:La3 . \n" , "pers:Al3 rel:brother pers:Si3 . \n" , "pers:Ol4 rel:brother pers:Lo4 . \n" , "pers:Lo4 rel:brother pers:Ol4 . \n" , "pers:Ha4 rel:brother pers:El4 . \n" , "pers:El4 rel:brother pers:Ha4 . \n" ] result31b :: RDFGraph result31b = mkGr2 ["pers:Gr3 rel:brother pers:Gr3 . \n"] result31c :: RDFGraph result31c = mkGr2 ["pers:Gr3 rel:brother pers:La3 . \n"] bwd31c :: RDFGraph bwd31c = mkGr2 [ "_:a rel:son pers:Gr3 . \n" , "_:a rel:son pers:La3 . \n" ] rul31 :: RDFRule rul31 = makeN3ClosureRule scope3 "rul31" query31str result31str modify31 fwd31 :: [RDFGraph] fwd31 = fwdApply rul31 [graph2] calcbwd31b, calcbwd31c :: [[RDFGraph]] calcbwd31b = bwdApply rul31 result31b calcbwd31c = bwdApply rul31 result31c test3 :: Test test3 = TestList [ testEq "testResult31" 1 (length fwd31) , testIn "testResult31a" result31a fwd31 , testEq "testBwd31" 0 (length calcbwd31b) , testEq "testBwd31" 1 (length $ head calcbwd31c) , testIn "testBwd31c" bwd31c (head calcbwd31c) ] -- Instance entailment tests scope4 :: Namespace scope4 = toNS (Just "scope4") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope4" graph4 :: RDFGraph graph4 = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" ] vocab4 :: S.Set RDFLabel vocab4 = allNodes (not . labelIsVar) graph4 name4 :: ScopedName name4 = makeNSScopedName scope4 "instance4" rule4 :: RDFRule rule4 = makeRdfInstanceEntailmentRule name4 (S.toList vocab4) fwd42a :: RDFGraph fwd42a = mkGr2 [ "pers:Gr3 rel:son _:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" ] fwd42b :: RDFGraph fwd42b = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter _:Rh4 . \n" ] fwd42c :: RDFGraph fwd42c = mkGr2 [ "pers:Gr3 rel:son _:Ro4 ; \n" , " rel:daughter _:Rh4 . \n" ] fwd42d :: RDFGraph fwd42d = mkGr2 [ "_:Gr3 rel:son _:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" ] fwd42e :: RDFGraph fwd42e = mkGr2 [ "_:Gr3 rel:son _:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" ] fwd42f :: RDFGraph fwd42f = mkGr2 [ "_:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter _:Rh4 . \n" ] fwd42g :: RDFGraph fwd42g = mkGr2 [ "_:Gr3 rel:son _:Ro4 ; \n" , " rel:daughter _:Rh4 . \n" ] -- Non-entailments fwd42w :: RDFGraph fwd42w = mkGr2 ["pers:Gr3 rel:daughter pers:Ro4 . \n"] fwd42x :: RDFGraph fwd42x = mkGr2 ["pers:Gr3 rel:daughter pers:Ro4 . \n"] fwd42y :: RDFGraph fwd42y = mkGr2 [ "_:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter pers:Ro4 . \n" ] fwd42z :: RDFGraph fwd42z = mkGr2 [ "_:Gr3 rel:son _:Ro4 ; \n" , " rel:son _:Rh4 . \n" ] bwd43 :: RDFGraph bwd43 = mkGr2 [ "_:a1 rel:son pers:Ro4 . \n" , "_:a2 rel:daughter pers:Rh4 . \n" ] bwd43a :: RDFGraph bwd43a = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 . \n" , "pers:Gr3 rel:daughter pers:Rh4 . \n" ] bwd43b :: RDFGraph bwd43b = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 . \n" , "pers:Ro4 rel:daughter pers:Rh4 . \n" ] bwd43c :: RDFGraph bwd43c = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 . \n" , "pers:Rh4 rel:daughter pers:Rh4 . \n" ] bwd43d :: RDFGraph bwd43d = mkGr2 [ "pers:Ro4 rel:son pers:Ro4 . \n" , "pers:Gr3 rel:daughter pers:Rh4 . \n" ] bwd43e :: RDFGraph bwd43e = mkGr2 [ "pers:Ro4 rel:son pers:Ro4 . \n" , "pers:Ro4 rel:daughter pers:Rh4 . \n" ] bwd43f :: RDFGraph bwd43f = mkGr2 [ "pers:Ro4 rel:son pers:Ro4 . \n" , "pers:Rh4 rel:daughter pers:Rh4 . \n" ] bwd43g :: RDFGraph bwd43g = mkGr2 [ "pers:Rh4 rel:son pers:Ro4 . \n" , "pers:Gr3 rel:daughter pers:Rh4 . \n" ] bwd43h :: RDFGraph bwd43h = mkGr2 [ "pers:Rh4 rel:son pers:Ro4 . \n" , "pers:Ro4 rel:daughter pers:Rh4 . \n" ] bwd43i :: RDFGraph bwd43i = mkGr2 [ "pers:Rh4 rel:son pers:Ro4 . \n" , "pers:Rh4 rel:daughter pers:Rh4 . \n" ] -- Forward chaining fwdApply42 :: [RDFGraph] fwdApply42 = fwdApply rule4 [graph4] -- Backward chaining bwdApply43 :: [[RDFGraph]] bwdApply43 = bwdApply rule4 bwd43 test4 :: Test test4 = TestList [ -- Check basics testEq "testRuleName41" name4 (ruleName rule4) , testEq "testVocab41" 3 (S.size vocab4) , testEq "testFwdLength42" 7 (length fwdApply42) , testIn "testFwdApply42a" fwd42a fwdApply42 , testIn "testFwdApply42b" fwd42b fwdApply42 , testIn "testFwdApply42c" fwd42c fwdApply42 , testIn "testFwdApply42d" fwd42d fwdApply42 , testIn "testFwdApply42e" fwd42e fwdApply42 , testIn "testFwdApply42f" fwd42f fwdApply42 , testIn "testFwdApply42g" fwd42g fwdApply42 , testEq "testBwdLength43" 9 (length bwdApply43) , testIn "testBwdApply43a" [bwd43a] bwdApply43 , testIn "testBwdApply43b" [bwd43b] bwdApply43 , testIn "testBwdApply43c" [bwd43c] bwdApply43 , testIn "testBwdApply43d" [bwd43d] bwdApply43 , testIn "testBwdApply43e" [bwd43e] bwdApply43 , testIn "testBwdApply43f" [bwd43f] bwdApply43 , testIn "testBwdApply43g" [bwd43g] bwdApply43 , testIn "testBwdApply43h" [bwd43h] bwdApply43 , testIn "testBwdApply43i" [bwd43i] bwdApply43 -- Entailment checks , testEq "testEntail44a" True (checkInference rule4 [graph4] fwd42a) , testEq "testEntail44b" True (checkInference rule4 [graph4] fwd42b) , testEq "testEntail44g" True (checkInference rule4 [graph4] fwd42g) , testEq "testEntail44w" False (checkInference rule4 [graph4] fwd42w) , testEq "testEntail44x" False (checkInference rule4 [graph4] fwd42x) , testEq "testEntail44y" False (checkInference rule4 [graph4] fwd42y) , testEq "testEntail44z" False (checkInference rule4 [graph4] fwd42z) ] -- Subgraph entailment tests scope5 :: Namespace scope5 = toNS (Just "scope5") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope5" graph5 :: RDFGraph graph5 = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" , "pers:Si3 rel:son pers:Ol4 . \n" ] name5 :: ScopedName name5 = makeNSScopedName scope5 "subgraph5" rule5 :: RDFRule rule5 = makeRdfSubgraphEntailmentRule name5 -- Forward chaining excludes null agraph and copy of antecedent fwd52a :: RDFGraph fwd52a = mkGr2 ["pers:Gr3 rel:son pers:Ro4 . \n"] fwd52b :: RDFGraph fwd52b = mkGr2 ["pers:Gr3 rel:daughter pers:Rh4 . \n"] fwd52c :: RDFGraph fwd52c = mkGr2 ["pers:Si3 rel:son pers:Ol4 . \n"] fwd52d :: RDFGraph fwd52d = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 . \n" , "pers:Gr3 rel:daughter pers:Rh4 . \n" ] fwd52e :: RDFGraph fwd52e = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 . \n" , "pers:Si3 rel:son pers:Ol4 . \n" ] fwd52f :: RDFGraph fwd52f = mkGr2 [ "pers:Gr3 rel:daughter pers:Rh4 . \n" , "pers:Si3 rel:son pers:Ol4 . \n" ] -- Forward chaining fwdApply52 :: [RDFGraph] fwdApply52 = fwdApply rule5 [graph5] test5 :: Test test5 = TestList [ testEq "testRuleName51" name5 (ruleName rule5) , testEq "testFwdLength52" 6 (length fwdApply52) , testIn "testFwdApply52a" fwd52a fwdApply52 , testIn "testFwdApply52b" fwd52b fwdApply52 , testIn "testFwdApply52c" fwd52c fwdApply52 , testIn "testFwdApply52d" fwd52d fwdApply52 , testIn "testFwdApply52e" fwd52e fwdApply52 , testIn "testFwdApply52f" fwd52f fwdApply52 ] -- Simple entailment test -- Simple entailment provides entailment check only, no forward or -- backward chaining. For that use instance- and subgraph- rules. scope6 :: Namespace scope6 = toNS (Just "scope6") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope6" graph6 :: RDFGraph graph6 = mkGr2 [ "pers:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" , "pers:Si3 rel:son pers:Ol4 ; \n" , " rel:son pers:Lo4 . \n" ] name6 :: ScopedName name6 = makeNSScopedName scope5 "subgraph6" rule6 :: RDFRule rule6 = makeRdfSimpleEntailmentRule name6 simple6a :: RDFGraph simple6a = mkGr2 [ "_:Gr3 rel:son pers:Ro4 ; \n" , " rel:daughter pers:Rh4 . \n" ] simple6b :: RDFGraph simple6b = mkGr2 [ "_:Si3 rel:son pers:Ol4 ; \n" , " rel:son pers:Lo4 . \n" ] simple6c :: RDFGraph simple6c = mkGr2 [ "_:Si3 rel:son _:Ol4 ; \n" , " rel:son _:Lo4 . \n" ] simple6d :: RDFGraph simple6d = mkGr2 [ "_:Si3 rel:son _:Ol4 ; \n" , " rel:daughter _:Lo4 . \n" ] simple6e :: RDFGraph simple6e = mkGr2 [ "_:Si3 rel:daughter _:Ol4 ; \n" , " rel:mother _:Lo4 . \n" ] test6 :: Test test6 = TestList [ testEq "testRuleName61" name6 (ruleName rule6) , test "testSimple62" (checkInference rule6 [graph6] simple6a) , test "testSimple63" (checkInference rule6 [graph6] simple6b) , test "testSimple64" (checkInference rule6 [graph6] simple6c) , test "testSimple65" (checkInference rule6 [graph6] simple6d) , test "testSimple66" (not $ checkInference rule6 [graph6] simple6e) , test "testFwd64" (null $ fwdApply rule6 [graph6]) , test "testBwd65" (null $ bwdApply rule6 graph6) ] -- Test forward chaining node allocation logic -- -- ?a uncle ?c => ?a father ?b, ?b brother ?c, ?b allocTo ?a -- -- Ro4 uncle La3, Ro4 uncle Si3, Rh4 uncle La3, Rh4 uncle Si3 -- => -- Ro4 father _:f1, _:f1 brother La3, -- Ro4 father _:f1, _:f1 brother Si3, -- Rh4 father _:f2, _:f2 brother La3, -- Rh4 father _:f2, _:f2 brother Si3 scope7 :: Namespace scope7 = toNS (Just "scope7") "http://id.ninebynine.org/wip/2003/rdfprooftest/scope7" graph7 :: RDFGraph graph7 = mkGr2 [ "pers:Ro4 rel:uncle pers:La3 ; \n" , " rel:uncle pers:Si3 . \n" , "pers:Rh4 rel:uncle pers:La3 ; \n" , " rel:uncle pers:Si3 . \n" ] query71str, result71str :: B.Builder query71str = prefix2 `mappend` "?a rel:uncle ?c . \n" result71str = mconcat [ prefix2 , "?a rel:father ?b . \n" , "?b rel:brother ?c . \n" ] query71, result71 :: RDFGraph query71 = makeRDFGraphFromN3Builder query71str result71 = makeRDFGraphFromN3Builder result71str result71a :: RDFGraph result71a = mkGr2 [ "pers:Ro4 rel:father _:f1 . \n" , "_:f1 rel:brother pers:La3 . \n" , "pers:Ro4 rel:father _:f1 . \n" , "_:f1 rel:brother pers:Si3 . \n" , "pers:Rh4 rel:father _:f2 . \n" , "_:f2 rel:brother pers:La3 . \n" , "pers:Rh4 rel:father _:f2 . \n" , "_:f2 rel:brother pers:Si3 . \n" ] rul71 :: RDFRule rul71 = makeN3ClosureAllocatorRule scope7 "rul71" query71str result71str varBindingId mod71 mod71 :: [RDFLabel] -> RDFVarBindingModify mod71 = makeNodeAllocTo (Var "b") (Var "a") var71 :: [RDFVarBinding] var71 = rdfQueryFind query71 graph7 var71a :: [VarBinding RDFLabel RDFLabel] var71a = vbmApply (mod71 (S.toList (allLabels labelIsVar graph7))) var71 var71_1 :: VarBinding RDFLabel RDFLabel var71_1 = head var71a map71a, map71b, map71c :: Maybe RDFLabel map71a = Just (Var "#a") map71b = Just (Var "#b") map71c = Just (Var "#c") sub71a :: [RDFGraph] sub71a = rdfQuerySubs var71a result71 fwd71 :: [RDFGraph] fwd71 = fwdApply rul71 [graph7] test7 :: Test test7 = TestList [ testEq "testVar71" 4 (length var71) , testEq "testVar71a" 4 (length var71a) -- testVar71_1a = testEq "testVar71_1a" map71a ( vbMap var71_1 (Var "a")) -- testVar71_1b = testEq "testVar71_1b" map71b ( vbMap var71_1 (Var "b")) -- testVar71_1c = testEq "testVar71_1c" map71c ( vbMap var71_1 (Var "c")) , testEq "testVar71a" 4 (length sub71a) , testEq "testResult71" 1 (length fwd71) , testIn "testResult71a" result71a fwd71 ] -- Full test suite, main program, and useful expressions for interactive use allTests :: [TF.Test] allTests = [ conv "1" test1 , conv "2" test2 , conv "3" test3 , conv "4" test4 , conv "5" test5 , conv "6" test6 , conv "7" test7 ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFProofContextTest.hs0000644000000000000000000005730314163107250016610 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFProofContextTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module contains RDF proof-checking test cases based on the RDF -- semantics specifications, as capured in module RDFProofContext. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF 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.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.Graph (RDFGraph) -- import Swish.RDF.GraphShowLines () import Swish.RDF.Vocabulary ( namespaceRDF , namespaceRDFS , namespaceRDFD , namespaceXSD , namespaceXsdType , scopeRDF , scopeRDFS , scopeRDFD ) import Data.Maybe (isNothing, fromJust, fromMaybe) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Network.URI (URI, parseURI) import Test.HUnit ( Test(TestCase,TestList) , assertBool, assertEqual ) import TestHelpers ( conv, test , testEq , testElem ) -- misc helpers testGr :: String -> RDFGraph -> [RDFGraph] -> Test testGr = testElem -- testGr lab eg a = TestCase $ assertBool lab (eg `elem` a) -- testProof "rdfProof01" True rdfProof01 testProof :: String -> Bool -> RDFProof -> Test testProof lab valid proof = TestList [ TestCase $ assertEqual lab valid (checkProof proof) , TestCase $ assertBool (lab++": "++ex) (valid == isNothing expl) ] where expl = explainProof proof ex = fromMaybe "(Proof OK)" expl -- testProofStep "rdfStep01" True [rules] [antes] rdfStep01 testProofStep :: String -> Bool -> [RDFRule] -> [RDFGraph] -> Step RDFGraph -> Test testProofStep lab valid rules antes step = TestCase $ assertEqual lab valid (checkStep rules antes step) -- Various support methods makeFormula :: Namespace -> LName -> B.Builder -> RDFFormula makeFormula scope local gr = makeRDFFormula scope local (prefix `mappend` gr) getRule :: String -> RDFRule getRule nam = getContextRule (makeSName nam) nullRule $ rdfdContext++[rulesetXsdInt,rulesetXsdStr] getAxiom :: String -> RDFFormula getAxiom nam = getContextAxiom (makeSName nam) nullRDFFormula rdfdContext makeSName :: String -> ScopedName makeSName nam = makeNSScopedName ns (fromJust (newLName (T.pack loc))) where err = error $ "makeSName: Unrcognized prefix in rule name: " ++ nam (pre, post) = break (==':') nam loc = case post of "" -> err _:loc' -> loc' ns = case pre of "rs_rdf" -> scopeRDF "rs_rdfs" -> scopeRDFS "rs_rdfd" -> scopeRDFD "xsd_integer" -> namespaceXsdType "integer" "xsd_string" -> namespaceXsdType "string" _ -> err -- Common definitions toURI :: String -> URI toURI = fromJust . parseURI toNS :: Maybe T.Text -> String -> Namespace toNS p = makeNamespace p . toURI mkPrefix :: Namespace -> B.Builder mkPrefix = namespaceToBuilder prefix :: B.Builder prefix = mconcat [ mkPrefix namespaceRDF , mkPrefix namespaceRDFS , mkPrefix namespaceRDFD , mkPrefix namespaceXSD -- TODO: should the following use scopeex instead? , mkPrefix $ toNS (Just "ex") "http://example.org/" ] scopeex :: Namespace scopeex = toNS (Just "ex") "http://id.ninebynine.org/wip/2003/RDFProofCheck#" rdfContext, rdfsContext, rdfdContext, xsdintContext, xsdstrContext :: [RDFRuleset] rdfContext = [ rulesetRDF ] rdfsContext = [ rulesetRDF, rulesetRDFS ] rdfdContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD ] xsdintContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD, rulesetXsdInt ] xsdstrContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD, rulesetXsdStr ] rulesetXsdInt, rulesetXsdStr :: RDFRuleset rulesetXsdInt = fromJust $ M.lookup (namespaceXsdType "integer") rdfRulesetMap rulesetXsdStr = fromJust $ M.lookup (namespaceXsdType "string") rdfRulesetMap ------------------------ -- RDF/S rule tests ------------------------ -- -- These tests aim to exercise the specific closure rule constructs -- that are used by the RDF/S rules. They have been prepared as a -- regression test for a refactoring of the variable binding -- filtering and modification logic. -- Simple rule test - forward and backward chaining -- -- rdfr1 = "?x ?a ?y ." => "?a rdf:type rdf:Property ." -- rdfr1 :: RDFRule rdfr1 = getRule "rs_rdf:r1" ant01, con01, bwd01 :: RDFGraph ant01 = formExpr $ makeFormula scopeex "ant01" "ex:s ex:p1 ex:o1 ; ex:p2 ex:o2 ." con01 = formExpr $ makeFormula scopeex "con01" $ "ex:p1 rdf:type rdf:Property ." `mappend` "ex:p2 rdf:type rdf:Property ." bwd01 = formExpr $ makeFormula scopeex "bwd01a" $ "_:s1 ex:p1 _:o1 . " `mappend` "_:s2 ex:p2 _:o2 . " -- Simple rule test - no match forward or backward -- -- rdfsr2 = "?x ?a ?y . ?a rdfs:domain ?z ." => "?x rdf:type ?z ." -- rdfsr2 :: RDFRule rdfsr2 = getRule "rs_rdfs:r2" ant02, con02 :: RDFGraph ant02 = formExpr $ makeFormula scopeex "ant02" "ex:s ex:p1 ex:o1 . ex:p2 rdfs:domain ex:d2 ." con02 = formExpr $ makeFormula scopeex "con02" "ex:s ex:p1 ex:o1 . ex:p2 rdfs:domain ex:d2 ." -- Rule with literal test and "allocateTo": -- match forward, but not backward -- -- This is a two-part rule: (a) apply rdflg, (b) apply rdfr2 -- -- rdflg = "?x ?a ?l . " => "?x ?a ?b . ?b rdf:_allocatedTo ?l ." -- where: -- (isLiteral "?l") -- (allocateTo "?b" "?l") -- -- rdfr2 = "?x ?a ?l . ?b rdf:_allocatedTo ?l . " -- => "?b rdf:type rdf:XMLLiteral ." -- where: -- (isXMLLit "?l") -- rdflg, rdfr2 :: RDFRule rdflg = getRule "rs_rdf:lg" rdfr2 = getRule "rs_rdf:r2" ant03, con03lg, con03r2 :: RDFGraph ant03 = formExpr $ makeFormula scopeex "ant03" $ "ex:s ex:p1 \"lit1\"^^rdf:XMLLiteral ; " `mappend` " ex:p2a \"lit2\"^^rdf:XMLLiteral ; " `mappend` " ex:p2b \"lit2\"^^rdf:XMLLiteral ." con03lg = formExpr $ makeFormula scopeex "con03" $ "ex:s ex:p1 _:l1 ; ex:p2a _:l2; ex:p2b _:l2 ." `mappend` "_:l1 rdf:_allocatedTo \"lit1\"^^rdf:XMLLiteral ." `mappend` "_:l2 rdf:_allocatedTo \"lit2\"^^rdf:XMLLiteral ." con03r2 = formExpr $ makeFormula scopeex "con03" $ "_:l1 rdf:type rdf:XMLLiteral ." `mappend` "_:l2 rdf:type rdf:XMLLiteral ." -- Rule with member property test, match forwards and backwards -- rdfcp1 = "?x ?c ?y . " => "?c rdf:type rdf:Property ." -- where: -- (isMemberProp "?c") -- rdfcp :: RDFRule rdfcp = getRule "rs_rdf:cp1" ant04, con04, bwd04 :: RDFGraph ant04 = formExpr $ makeFormula scopeex "ant04" $ "ex:s rdf:_123 ex:o1 ; " `mappend` " rdf:_2 ex:o2 . " con04 = formExpr $ makeFormula scopeex "con04" $ "rdf:_123 rdf:type rdf:Property ." `mappend` "rdf:_2 rdf:type rdf:Property ." bwd04 = formExpr $ makeFormula scopeex "bwd04a" $ "_:s1 rdf:_123 _:o1 . " `mappend` "_:s2 rdf:_2 _:o2 . " -- Rule with disjunction test, match forwards and backwards -- -- rdfsr3 = "?x ?a ?u . ?a rdfs:range ?z ." => "?u rdf:type ?z ." -- where: -- (requireAny [isUriRef "?u",isBlank "?u"]) -- rdfsr3 :: RDFRule rdfsr3 = getRule "rs_rdfs:r3" ant05, con05, bwd05 :: RDFGraph ant05 = formExpr $ makeFormula scopeex "ant05" $ "ex:s ex:p1 ex:o1 ; " `mappend` " ex:p2 _:o2 . " `mappend` "ex:p1 rdfs:range ex:pr1 . " `mappend` "ex:p2 rdfs:range ex:pr2 . " con05 = formExpr $ makeFormula scopeex "con05" $ "ex:o1 rdf:type ex:pr1 ." `mappend` "_:o2 rdf:type ex:pr2 ." bwd05 = formExpr $ makeFormula scopeex "bwd05a" $ "_:s1 _:p1 ex:o1 . " `mappend` "_:s2 _:p2 _:o2 . " `mappend` "_:p1 rdfs:range ex:pr1 . " `mappend` "_:p2 rdfs:range ex:pr2 . " -- Rule with disjunction test, fail forwards -- -- rdfsr3 = "?x ?a ?u . ?a rdfs:range ?z ." => "?u rdf:type ?z ." -- where: -- (requireAny [isUriRef "?u",isBlank "?u"]) -- ant06, con06, bwd06, chk06 :: RDFGraph ant06 = formExpr $ makeFormula scopeex "ant06" $ "ex:s ex:p1 \"lit1\" . " `mappend` "ex:p1 rdfs:range ex:pr1 . " con06 = formExpr $ makeFormula scopeex "con06" "_:o1 rdf:type ex:pr1 ." bwd06 = formExpr $ makeFormula scopeex "bwd06a" $ "_:s1 _:p1 _:o1 . " `mappend` "_:p1 rdfs:range ex:pr1 . " chk06 = formExpr $ makeFormula scopeex "bwd06a" $ "_:s1 _:p1 \"lit1\" . " `mappend` "_:p1 rdfs:range ex:pr1 . " -- Collected rule tests testRules :: Test testRules = TestList [ testEq "testRule01a" "rs_rdf:r1" (show $ ruleName rdfr1) , testEq "testRule01b" [con01] (fwdApply rdfr1 [ant01]) , testEq "testRule01c" [[bwd01]] (bwdApply rdfr1 con01) , test "testRule01d" (checkInference rdfr1 [ant01] con01) , test "testRule01e" (checkInference rdfr1 [bwd01] con01) , testEq "testRule02a" "rs_rdfs:r2" (show $ ruleName rdfsr2) , testEq "testRule02b" [] (fwdApply rdfsr2 [ant02]) , testEq "testRule02c" [] (bwdApply rdfsr2 con02) , testEq "testRule02d" False (checkInference rdfsr2 [ant02] con02) , testEq "testRule03a" "rs_rdf:lg" (show $ ruleName rdflg) , testEq "testRule03b" "rs_rdf:r2" (show $ ruleName rdfr2) , testEq "testRule03c" [con03lg] (fwdApply rdflg [ant03]) , testEq "testRule03d" [] (bwdApply rdflg con03lg) , test "testRule03e" (checkInference rdflg [ant03] con03lg) , testEq "testRule03f" [con03r2] (fwdApply rdfr2 [con03lg]) , testEq "testRule03g" [] (bwdApply rdfr2 con03r2) , test "testRule03h" (checkInference rdfr2 [con03lg] con03r2) , testEq "testRule04a" "rs_rdf:cp1" (show $ ruleName rdfcp) , testEq "testRule04b" [con04] (fwdApply rdfcp [ant04]) , testEq "testRule04c" [[bwd04]] (bwdApply rdfcp con04) , test "testRule04d" (checkInference rdfcp [ant04] con04) , test "testRule01e" (checkInference rdfcp [bwd04] con04) , testEq "testRule05a" "rs_rdfs:r3" (show $ ruleName rdfsr3) , testEq "testRule05b" [con05] (fwdApply rdfsr3 [ant05]) , testEq "testRule05c" [[bwd05]] (bwdApply rdfsr3 con05) , test "testRule05d" (checkInference rdfsr3 [ant05] con05) , test "testRule01e" (checkInference rdfsr3 [bwd05] con05) , testEq "testRule06a" "rs_rdfs:r3" (show $ ruleName rdfsr3) , testEq "testRule06b" [] (fwdApply rdfsr3 [ant06]) , testEq "testRule06c" [[bwd06]] (bwdApply rdfsr3 con06) , testEq "testRule06d" False (checkInference rdfsr3 [ant06] con06) , testEq "testRule06e" True (checkInference rdfsr3 [bwd06] con06) , testEq "testRule06e" False (checkInference rdfsr3 [chk06] con06) ] ------------------------ -- Complete proof tests ------------------------ -- -- These are a few tests of complete RDF proof chains based on the -- RDF semantic rules. -- RDF entailment proof checks rdfBase01, rdfGoal01 :: RDFFormula rdfBase01 = makeFormula scopeex "rdfBase01" "ex:s ex:p ex:o ." rdfGoal01 = makeFormula scopeex "rdfGoal01" "ex:p rdf:type rdf:Property ." rdfStep01a :: RDFProofStep rdfStep01a = makeRDFProofStep (getRule "rs_rdf:r1") [rdfBase01] rdfGoal01 rdfProof01 :: RDFProof rdfProof01 = makeRDFProof rdfsContext rdfBase01 rdfGoal01 [ rdfStep01a ] rdfBase02, rdfCon02a, rdfGoal02 :: RDFFormula rdfBase02 = makeFormula scopeex "rdfBase02" "ex:s ex:p \"l1\"^^rdf:XMLLiteral ." rdfCon02a = makeFormula scopeex "rdfStep02a" $ "ex:s ex:p _:lll . " `mappend` "_:lll rdf:_allocatedTo \"l1\"^^rdf:XMLLiteral . " rdfGoal02 = makeFormula scopeex "rdfGoal02" "_:lll rdf:type rdf:XMLLiteral . " rdfStep02a, rdfStep02b :: RDFProofStep rdfStep02a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase02] rdfCon02a rdfStep02b = makeRDFProofStep (getRule "rs_rdf:r2") [rdfCon02a] rdfGoal02 rdfProof02 :: RDFProof rdfProof02 = makeRDFProof rdfsContext rdfBase02 rdfGoal02 [ rdfStep02a, rdfStep02b ] rdfBase03, rdfCon03a, rdfGoal03 :: RDFFormula rdfBase03 = makeFormula scopeex "rdfBase03" "ex:s ex:p ex:o ." rdfCon03a = makeFormula scopeex "rdfStep03a" $ "ex:s ex:p _:lll . " `mappend` "_:lll rdf:_allocatedTo \"l1\"^^rdf:XMLLiteral . " rdfGoal03 = makeFormula scopeex "rdfGoal03" "_:lll rdf:type rdf:XMLLiteral . " rdfStep03a, rdfStep03b :: RDFProofStep rdfStep03a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase03] rdfCon03a rdfStep03b = makeRDFProofStep (getRule "rs_rdf:r2") [rdfCon03a] rdfGoal03 rdfProof03 :: RDFProof rdfProof03 = makeRDFProof rdfsContext rdfBase03 rdfGoal03 [ rdfStep03a, rdfStep03b ] rdfBase04, rdfGoal04 :: RDFFormula rdfBase04 = makeFormula scopeex "rdfBase04" "ex:s ex:p ex:o ." rdfGoal04 = makeFormula scopeex "rdfGoal04" "_:s ex:p _:o ." rdfStep04a :: RDFProofStep rdfStep04a = makeRDFProofStep (getRule "rs_rdf:se") [rdfBase04] rdfGoal04 rdfProof04 :: RDFProof rdfProof04 = makeRDFProof rdfsContext rdfBase04 rdfGoal04 [ rdfStep04a ] rdfBase05 :: RDFFormula rdfBase05 = makeFormula scopeex "rdfBase05" "ex:s ex:p rdf:nil ." rdfStep05a :: RDFProofStep rdfStep05a = makeRDFProofStep (getRule "rs_rdf:r1") [rdfBase05] rdfCons05a rdfCons05a :: RDFFormula rdfCons05a = makeFormula scopeex "rdfCons05a" "ex:p rdf:type rdf:Property ." rdfStep05b :: RDFProofStep rdfStep05b = makeRDFProofStep (getRule "rs_rdf:se") [rdfBase05, rdfCons05a, getAxiom "rs_rdf:a8"] rdfGoal05 rdfGoal05 :: RDFFormula rdfGoal05 = makeFormula scopeex "rdfGoal05" $ "ex:s _:p _:n ." `mappend` "_:p rdf:type rdf:Property ." `mappend` "_:n rdf:type rdf:List ." rdfProof05 :: RDFProof rdfProof05 = makeRDFProof rdfsContext rdfBase05 rdfGoal05 [rdfStep05a, rdfStep05b] -- Swap rdfProof05 proof steps: rdfProof06 :: RDFProof rdfProof06 = makeRDFProof rdfsContext rdfBase05 rdfGoal05 [ rdfStep05b, rdfStep05a ] -- Proof using rdfsr1 and rdfsub -- -- ex:s1 ex:p1 "lll" -- ex:s2 ex:p2 "lll" -- => -- ex:s1 ex:p1 _:l -- ex:s2 ex:p2 _:l -- _:l rdf:type rdfs:Literal rdfBase07 :: RDFFormula rdfBase07 = makeFormula scopeex "rdfBase07" $ "ex:s1 ex:p1 \"lll\" ." `mappend` "ex:s2 ex:p2 \"lll\" ." `mappend` "ex:s3 ex:p3 \"mmm\" ." rdfStep07a :: RDFProofStep rdfStep07a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase07] rdfCons07a rdfCons07a :: RDFFormula rdfCons07a = makeFormula scopeex "rdfCons07a" $ "ex:s1 ex:p1 _:l ." `mappend` "ex:s2 ex:p2 _:l ." `mappend` "_:l rdf:_allocatedTo \"lll\" ." `mappend` "ex:s3 ex:p3 _:m ." `mappend` "_:m rdf:_allocatedTo \"mmm\" ." rdfStep07b :: RDFProofStep rdfStep07b = makeRDFProofStep (getRule "rs_rdfs:r1") [rdfCons07a] rdfCons07b rdfCons07b :: RDFFormula rdfCons07b = makeFormula scopeex "rdfCons07a" $ "_:l rdf:type rdfs:Literal ." `mappend` "_:m rdf:type rdfs:Literal ." rdfStep07c :: RDFProofStep rdfStep07c = makeRDFProofStep (getRule "rs_rdf:sub") [rdfCons07a,rdfCons07b] rdfGoal07 rdfGoal07 :: RDFFormula rdfGoal07 = makeFormula scopeex "rdfGoal07" $ "ex:s1 ex:p1 _:l ." `mappend` "ex:s2 ex:p2 _:l ." `mappend` "_:l rdf:type rdfs:Literal ." rdfProof07 :: RDFProof rdfProof07 = makeRDFProof rdfsContext rdfBase07 rdfGoal07 [ rdfStep07a, rdfStep07b, rdfStep07c ] -- Proof of: -- rdf:_123 rdfs:supPropertyOf rdfs:member rdfBase08 :: RDFFormula rdfBase08 = makeFormula scopeex "rdfBase08" "ex:s1 rdf:_123 ex:o ." rdfStep08a :: RDFProofStep rdfStep08a = makeRDFProofStep (getRule "rs_rdfs:cp11") [rdfBase08] rdfCons08a rdfCons08a :: RDFFormula rdfCons08a = makeFormula scopeex "rdfCons08a" "rdf:_123 rdf:type rdfs:ContainerMembershipProperty ." rdfStep08b :: RDFProofStep rdfStep08b = makeRDFProofStep (getRule "rs_rdfs:r12") [rdfCons08a] rdfGoal08 rdfGoal08 :: RDFFormula rdfGoal08 = makeFormula scopeex "rdfCons08b" "rdf:_123 rdfs:subPropertyOf rdfs:member ." rdfProof08 :: RDFProof rdfProof08 = makeRDFProof rdfsContext rdfBase08 rdfGoal08 [ rdfStep08a, rdfStep08b ] -- Proof of: -- ex:s ex:p "010"^^xsd:Integer . -- => -- ex:s ex:p "10"^^xsd:Integer . -- ex:s ex:p _:b -- _:b rdf:type xsd:integer . rdfAxiomIntDt :: RDFFormula rdfAxiomIntDt = getContextAxiom (makeNSScopedName (namespaceXsdType "integer") "dt") nullFormula allRulesets rdfAxiom09 :: Test rdfAxiom09 = testEq "rdfAxiom09" "xsd_integer:dt" $ show (formName rdfAxiomIntDt) rdfBase09 :: RDFFormula rdfBase09 = makeFormula scopeex "rdfBase09" "ex:s ex:p \"010\"^^xsd:integer ." rdfStep09a :: RDFProofStep rdfStep09a = makeRDFProofStep (getRule "rs_rdfd:r2") [rdfAxiomIntDt,rdfBase09] rdfCons09a rdfCons09a :: RDFFormula rdfCons09a = makeFormula scopeex "rdfCons09a" "ex:s ex:p \"10\"^^xsd:integer ." rdfStep09b :: RDFProofStep rdfStep09b = makeRDFProofStep (getRule "rs_rdf:lg") [rdfCons09a] rdfCons09b rdfCons09b :: RDFFormula rdfCons09b = makeFormula scopeex "rdfCons09b" $ "ex:s ex:p _:l ." `mappend` "_:l rdf:_allocatedTo \"10\"^^xsd:integer ." rdfStep09c :: RDFProofStep rdfStep09c = makeRDFProofStep (getRule "rs_rdfd:r1") [rdfAxiomIntDt,rdfCons09a,rdfCons09b] rdfCons09c rdfCons09c :: RDFFormula rdfCons09c = makeFormula scopeex "rdfCons09c" "_:l rdf:type xsd:integer ." rdfStep09d :: RDFProofStep rdfStep09d = makeRDFProofStep (getRule "rs_rdf:sub") [rdfCons09a,rdfCons09b,rdfCons09c] rdfGoal09 rdfGoal09 :: RDFFormula rdfGoal09 = makeFormula scopeex "rdfGoal09" $ "ex:s ex:p \"10\"^^xsd:integer ." `mappend` "_:l rdf:_allocatedTo \"10\"^^xsd:integer ." `mappend` "_:l rdf:type xsd:integer ." rdfProof09 :: RDFProof rdfProof09 = makeRDFProof xsdintContext rdfBase09 rdfGoal09 [ rdfStep09a, rdfStep09b, rdfStep09c, rdfStep09d ] {- test data p09t1 = fwdApply (getRule "rs_rdfd:r2") [(formExpr rdfAxiomIntDt),(formExpr rdfBase09)] p09sh = putStrLn ("\n"++showProof "\n" rdfProof09++"\n") -} -- Proof of: -- ex:s ex:p "abc" . -- ex:s ex:p "def"^^xsd:string . -- => -- ex:s ex:p "abc"^^xsd:string . -- ex:s ex:p "def" . -- xsd:string rdf:type rdfs:Datatype . rdfAxiomStrDt :: RDFFormula rdfAxiomStrDt = getContextAxiom (makeNSScopedName (namespaceXsdType "string") "dt") nullFormula allRulesets rdfAxiom10 :: Test rdfAxiom10 = testEq "rdfAxiom10" "xsd_string:dt" $ show (formName rdfAxiomStrDt) rdfRule10 :: Test rdfRule10 = testEq "rdfRule10" "xsd_string:ls" $ show (ruleName (getRule "xsd_string:ls")) rdfBase10 :: RDFFormula rdfBase10 = makeFormula scopeex "rdfBase10" $ "ex:s ex:p \"abc\" . " `mappend` "ex:s ex:p \"def\"^^xsd:string . " rdfStep10a :: RDFProofStep rdfStep10a = makeRDFProofStep (getRule "xsd_string:ls") [rdfBase10] rdfCons10a rdfCons10a :: RDFFormula rdfCons10a = makeFormula scopeex "rdfCons10a" "ex:s ex:p \"abc\"^^xsd:string . " rdfStep10b :: RDFProofStep rdfStep10b = makeRDFProofStep (getRule "xsd_string:sl") [rdfBase10] rdfCons10b rdfCons10b :: RDFFormula rdfCons10b = makeFormula scopeex "rdfCons10b" "ex:s ex:p \"def\" . " rdfStep10c :: RDFProofStep rdfStep10c = makeRDFProofStep (getRule "rs_rdf:sub") [rdfCons10a,rdfCons10b,rdfAxiomStrDt] rdfGoal10 rdfGoal10 :: RDFFormula rdfGoal10 = makeFormula scopeex "rdfGoal10" $ "ex:s ex:p \"abc\"^^xsd:string . " `mappend` "ex:s ex:p \"def\" . " `mappend` "xsd:string rdf:type rdfs:Datatype . " rdfProof10 :: RDFProof rdfProof10 = makeRDFProof xsdstrContext rdfBase10 rdfGoal10 [ rdfStep10a, rdfStep10b, rdfStep10c ] testRdf :: Test testRdf = TestList [ testProofStep "rdfStep01a" True [getRule "rs_rdf:r1"] [formExpr rdfBase01] rdfStep01a , testProof "rdfProof01" True rdfProof01 -- Really should have support for scoped bnodes , testProof "rdfProof02" True rdfProof02 , testProof "rdfProof03" False rdfProof03 , testProof "rdfProof04" True rdfProof04 , testProof "rdfProof05" True rdfProof05 , testProof "rdfProof06" False rdfProof06 , testProof "rdfProof07" True rdfProof07 , testProof "rdfProof08" True rdfProof08 , rdfAxiom09 , testProof "rdfProof09" True rdfProof09 , rdfAxiom10, rdfRule10 , testProof "rdfProof10" True rdfProof10 {- , TestCase $ putStrLn ("\n"++showProof "\n" rdfProof01) , TestCase $ putStrLn ("\n"++showProof "\n" rdfProof05) -} ] ------------------------------------------------------------ -- Full test suite, main program, -- and useful expressions for interactive use ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "rules" testRules , conv "rdf" testRdf ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFGraphTest.hs0000644000000000000000000015702014163107250015214 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFGraphTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014, 2017, 2021 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module contains test cases for module RDFGraph. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T -- import qualified Data.Traversable as Traversable import qualified Data.Foldable as Foldable import qualified Test.Framework as TF import Swish.Namespace (Namespace, makeNamespace, getNamespaceURI, getNamespaceTuple, ScopedName, makeNSScopedName, nullScopedName) import Swish.QName (QName, qnameFromURI) import Swish.GraphClass (Label(..), arc {- , arcToTriple -} ) import Swish.RDF.Graph ( RDFTriple, toRDFTriple, fromRDFTriple , RDFGraph, NamespaceMap, Formula , RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..) , NSGraph(..) , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral , isDatatyped, isMemberProp , isUri, isBlank, isQueryVar, makeBlank , getScopedName , LookupFormula(..), FormulaMap, emptyFormulaMap , getArcs, addArc , remapLabels, remapLabelList , setFormulae, getFormulae, setFormula, getFormula , fmapNSGraph , newNode, newNodes ) import Swish.RDF.Vocabulary ( namespaceRDF , LanguageTag , toLangTag , rdfXMLLiteral , xsdBoolean , xsdInteger , xsdFloat , xsdDouble , xsdDateTime , xsdDate ) import Control.Arrow ((&&&), first) import Data.List (elemIndex, intercalate) import Data.Maybe (fromJust, fromMaybe) import Data.Ord (comparing) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Network.URI (URI, parseURI) #if MIN_VERSION_time(1,9,0) import Data.Time (UTCTime(..), Day, fromGregorian, defaultTimeLocale) import Data.Time.Format.Internal (buildTime) #elif MIN_VERSION_time(1,5,0) import Data.Time (UTCTime(..), Day, fromGregorian, buildTime, defaultTimeLocale) #else import Data.Time (UTCTime(..), Day, fromGregorian, buildTime) import System.Locale (defaultTimeLocale) #endif import Test.HUnit ( Test(TestCase,TestList,TestLabel) , Assertion , assertBool, assertEqual ) import TestHelpers ( conv, testEq , testEqv , testCompare , testCompareEq) ------------------------------------------------------------ -- Test language tag comparisons ------------------------------------------------------------ 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 (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 = [ ("lt0",lt0), ("lt1",lt1), ("lt2",lt2), ("lt3",lt3), ("lt4",lt4), ("lt5",lt5), ("lt6",lt6), ("lt7",lt7), ("lt8",lt8) ] langeqlist :: [(String, String)] langeqlist = [ ("lt1","lt2"), ("lt3","lt4"), ("lt5","lt6"), ("lt5","lt7"), ("lt5","lt8"), ("lt6","lt7"), ("lt6","lt8"), ("lt7","lt8") ] testLangEq :: String -> Bool -> Lang -> Lang -> Test testLangEq = testCompareEq "testLangEq:" hyphen :: String -> String -> String hyphen a b = a ++ "-" ++ b testLangEqSuite :: Test testLangEqSuite = TestList [ testLangEq (ll1 `hyphen` ll2) (tEq ll1 ll2) t1 t2 | (ll1,t1) <- langlist , (ll2,t2) <- langlist ] where tEq ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` langeqlist || (ll2,ll1) `elem` langeqlist ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ base1Str :: String base1Str = "http://id.ninebynine.org/wip/2003/test/graph1/node#" toURI :: String -> URI toURI s = fromMaybe (error $ "Error: unable to parse URI " ++ s) (parseURI s) toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . toURI -- TODO: basee and baseu had prefixes of "" and "?" before the conversion -- to using Maybe String. Now both are Nothing; is this semantically -- correct? Probably. basee, baseu, base1, base2, base3, base4 :: Namespace basee = makeNamespace Nothing $ toURI "http://example.com/a#" baseu = makeNamespace Nothing $ toURI "http://example.com/" base1 = toNS "base1" base1Str base2 = toNS "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" base3 = toNS "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" base4 = toNS "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" qn1s1 :: QName qn1s1 = fromJust $ qnameFromURI $ toURI $ base1Str ++ "s1" qu1s1 :: URI qu1s1 = toURI $ base1Str ++ "s1" qbes1, qbus1, qb1s1, qb2s2, qb3s3, qb3, qb3bm, qb4m :: ScopedName qbes1 = makeNSScopedName basee "s1" qbus1 = makeNSScopedName baseu "s1" qb1s1 = makeNSScopedName base1 "s1" qb2s2 = makeNSScopedName base2 "s2" qb3s3 = makeNSScopedName base3 "s3" qb3 = makeNSScopedName base3 "" qb3bm = makeNSScopedName base3 "basemore" qb4m = makeNSScopedName base4 "more" es1, us1, s1, s2, s3, s4, s5, s6, s7, s8 :: RDFLabel es1 = Res qbes1 us1 = Res qbus1 s1 = toRDFLabel qb1s1 s2 = toRDFLabel qb2s2 s3 = toRDFLabel qb3s3 s4 = Res qb3 s5 = Blank "s5" s6 = Res qb3bm s7 = Res qb4m s8 = Blank "s8" st1, st2, st3 :: RDFLabel st1 = toRDFLabel $ makeNSScopedName base1 "st1" st2 = toRDFLabel $ makeNSScopedName base2 "st2" st3 = toRDFLabel $ makeNSScopedName base3 "st3" bb, bb0, b1, b2, b3, b4, b5, b6, b7, b8, b9, b10 :: RDFLabel bb = Blank "bb" bb0 = Blank "bb0" b1 = Blank "b1" b2 = Blank "b2" b3 = Blank "b3" b4 = Blank "b4" b5 = Blank "b5" b6 = Blank "b6" b7 = Blank "b7" b8 = Blank "b8" b9 = Blank "b9" b10 = Blank "b10" c1, c2, c3, c4 :: RDFLabel c1 = Blank "c1" c2 = Blank "c2" c3 = Blank "c3" c4 = Blank "c4" ba1, ba2, ba3, ba4 :: RDFLabel ba1 = Blank "_1" ba2 = Blank "_2" ba3 = Blank "_3" ba4 = Blank "_4" bn3, bn4, bn5, bn6 :: RDFLabel bn3 = Blank "3" bn4 = Blank "4" bn5 = Blank "5" bn6 = Blank "6" p1, p2, p3, p4 :: RDFLabel p1 = Res $ makeNSScopedName base1 "p1" p2 = Res $ makeNSScopedName base2 "p2" p3 = Res $ makeNSScopedName base3 "p3" p4 = Res $ makeNSScopedName base3 "p4" o1, o2, o3, o4, o5, o6 :: RDFLabel o1 = Res $ makeNSScopedName base1 "o1" o2 = Res $ makeNSScopedName base2 "o2" o3 = Res $ makeNSScopedName base3 "o3" o4 = toRDFLabel qb3 o5 = Blank "o5" o6 = Blank "s5" qb1t1, qb1t2 :: ScopedName qb1t1 = makeNSScopedName base1 "type1" qb1t2 = makeNSScopedName base1 "type2" l1, l2, l2gb, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12 :: RDFLabel l1 = "l1" -- use IsString instance 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 = TypedLit "NaN" xsdFloat infF = TypedLit "INF" xsdFloat ninfF = TypedLit "-INF" xsdFloat nanD, infD, ninfD :: RDFLabel nanD = TypedLit "NaN" xsdDouble infD = TypedLit "INF" xsdDouble ninfD = TypedLit "-INF" xsdDouble v1, v2, v3, v4, vb3, vb4 :: RDFLabel v1 = Var "v1" v2 = Var "v2" v3 = Var "v3" v4 = Var "v4" vb3 = Blank "v3" vb4 = Blank "v4" -- Test cases for isMemberProp cm1, cm2, nm1, nm2 :: RDFLabel cm1 = Res $ makeNSScopedName namespaceRDF "_1" cm2 = Res $ makeNSScopedName namespaceRDF "_234567" nm1 = Res $ makeNSScopedName namespaceRDF "987" nm2 = Res $ makeNSScopedName namespaceRDF "_987a65" ------------------------------------------------------------ -- RDFLabel construction and equality tests ------------------------------------------------------------ testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test testLabelEq = testCompareEq "testLabelEq:" nodelist :: [(String, RDFLabel)] nodelist = [ ("es1",es1), ("us1",us1) , ("s1",s1), ("s2",s2), ("s3",s3), ("s4",s4), ("s5",s5) , ("s6",s6), ("s7",s7), ("s8",s8) , ("b1",b1), ("b2",b2), ("b3",b3), ("b4",b4) , ("p1",p1), ("p2",p2), ("p3",p3), ("p4",p4) , ("o1",o1), ("o2",o2), ("o3",o3), ("o4",o4), ("o5",o5) , ("l1",l1), ("l2",l2), ("l2gb",l2gb), ("l3",l3) , ("l4",l4), ("l5",l5), ("l6",l6) , ("l7",l7), ("l8",l8), ("l9",l9) , ("l10",l10), ("l11",l11), ("l12",l12) , ("v1",v1), ("v2",v2) ] nodeeqlist :: [(String, String)] nodeeqlist = [ ("s4","o4") , ("s5","o6") , ("s6","s7") , ("l4","l5") , ("l4","l6") , ("l5","l6") , ("l7","l8") , ("l7","l9") , ("l8","l9") , ("l10","l11") , ("l10","l12") , ("l11","l12") ] testNodeEqSuite :: Test testNodeEqSuite = TestList [ testLabelEq (ll1 `hyphen` ll2) (tEq ll1 ll2) n1 n2 | (ll1,n1) <- nodelist , (ll2,n2) <- nodelist ] where tEq ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` nodeeqlist || (ll2,ll1) `elem` nodeeqlist -- 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 = 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 = testEq (":fconv:" ++ lbl) (Just hVal) $ fromRDFLabel (toLbl sVal dtype) testConv :: (ToRDFLabel a, FromRDFLabel a, Eq a, Show a) => String -> T.Text -> Maybe ScopedName -> a -> Test testConv lbl sVal dtype hVal = TestList [ testToConv lbl sVal dtype hVal, testFrConv lbl sVal dtype hVal ] -- get an integer that is larger than can be stored in an Int -- (could just pick a value bigger than maxBound seen on a 64-bit build -- but try to be fancy) -- bigInt :: T.Text bigInt = let bi :: Integer bi = fromIntegral (maxBound :: Int) + 11 in T.pack $ show bi -- some conversions (e.g. toRDFTriple) are covered by -- other tests -- testConversionSuite :: Test testConversionSuite = TestList [ -- 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 (TypedLit "1.23" xsdFloat)) , testEq "fconv:fail bool1" (Nothing :: Maybe Bool) (fromRDFLabel l1) , 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 (TypedLit bigInt xsdInteger)) , testEq "fconv:fail float1" (Nothing :: Maybe Float) (fromRDFLabel l1) , 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 "") "" -- 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 , testConv "l1-2" "l1" Nothing ("l1"::String) -- boolean , testFrConv "True1" "1" (Just xsdBoolean) True , testFrConv "False0" "0" (Just xsdBoolean) False , testConv "True" "true" (Just xsdBoolean) True , testConv "False" "false" (Just xsdBoolean) False {- For example, -1E4, 1267.43233E12, 12.78e-2, 12 , -0, 0 and INF are all legal literals for float. For example, -1E4, 1267.43233E12, 12.78e-2, 12 , -0, 0 and INF are all legal literals for double. Valid values for xsd:integer include -123456789012345678901234567890, 2147483647, 0, or -0000000000000000000005. -} -- numeric types , testConv "int 0" "0" (Just xsdInteger) (0::Int) , testConv "int -10" "-10" (Just xsdInteger) ((-10)::Int) , testConv "int 10" "10" (Just xsdInteger) (10::Int) , testConv "integer 0" "0" (Just xsdInteger) (0::Integer) , testConv "integer -10" "-10" (Just xsdInteger) ((-10)::Integer) , testConv "integer 10" "10" (Just xsdInteger) (10::Integer) , testFrConv "integer -0..05" "-0000000000000000000005" (Just xsdInteger) ((-5)::Integer) , testConv "integer big" "123456789012345678901234567890" (Just xsdInteger) (123456789012345678901234567890::Integer) , testConv "integer -big" "-123456789012345678901234567890" (Just xsdInteger) ((-123456789012345678901234567890)::Integer) , testToConv "float NaN" "NaN" (Just xsdFloat) ((0.0::Float)/0.0) , testToConv "float INF" "INF" (Just xsdFloat) ((1.0::Float)/0.0) , testToConv "float -INF" "-INF" (Just xsdFloat) (((-1.0)::Float)/0.0) , testEq ":fconv:float NaN" (Just True) (fmap isNaN (fromRDFLabel nanF :: Maybe Float)) , testEq ":fconv:float INF" (Just True) (fmap isInfinite (fromRDFLabel infF :: Maybe Float)) , testEq ":fconv:float -INF" (Just True) (fmap isInfinite (fromRDFLabel ninfF :: Maybe Float)) , testToConv "double NaN" "NaN" (Just xsdDouble) ((0.0::Double)/0.0) , testToConv "double INF" "INF" (Just xsdDouble) ((1.0::Double)/0.0) , testToConv "double -INF" "-INF" (Just xsdDouble) (((-1.0)::Double)/0.0) , testEq ":fconv:double NaN" (Just True) (fmap isNaN (fromRDFLabel nanD :: Maybe Double)) , testEq ":fconv:double INF" (Just True) (fmap isInfinite (fromRDFLabel infD :: Maybe Double)) , testEq ":fconv:double -INF" (Just True) (fmap isInfinite (fromRDFLabel ninfD :: Maybe Double)) , testFrConv "float 0.0" "0.0" (Just xsdFloat) (0::Float) , testToConv "float 0.0" "0.0E0" (Just xsdFloat) (0::Float) , testFrConv "float 0." "0." (Just xsdFloat) (0::Float) , testFrConv "float -0" "-0" (Just xsdFloat) (0::Float) , testFrConv "float 0.2" "0.2" (Just xsdFloat) (0.2::Float) , testToConv "float 0.2" "2.0E-1" (Just xsdFloat) (0.2::Float) , testFrConv "float -0.2" "-0.2" (Just xsdFloat) ((-0.2)::Float) , testToConv "float -0.2" "-2.0E-1" (Just xsdFloat) ((-0.2)::Float) , testConv "float 2.01e-4" "2.01E-4" (Just xsdFloat) (0.000201::Float) , testConv "float -2.01e-4" "-2.01E-4" (Just xsdFloat) ((-0.000201)::Float) , testConv "float 2.01e38" "2.01E38" (Just xsdFloat) (2.01e38::Float) , testConv "float -2.01e38" "-2.01E38" (Just xsdFloat) ((-2.01e38)::Float) , testFrConv "double 0" "0.0" (Just xsdDouble) (0::Double) , testToConv "double 0" "0.0E0" (Just xsdDouble) (0::Double) , testFrConv "double 0." "0." (Just xsdDouble) (0::Double) , testFrConv "double -0" "-0" (Just xsdDouble) (0::Double) , testFrConv "double 0.2" "0.2" (Just xsdDouble) (0.2::Double) , testToConv "double 0.2" "2.0E-1" (Just xsdDouble) (0.2::Double) , testFrConv "double -0.2" "-0.2" (Just xsdDouble) ((-0.2)::Double) , testToConv "double -0.2" "-2.0E-1" (Just xsdDouble) ((-0.2)::Double) , testFrConv "double 2.01e-4" "2.01e-4" (Just xsdDouble) (0.000201::Double) , testToConv "double 2.01e-4" "2.01E-4" (Just xsdDouble) (0.000201::Double) , testFrConv "double -2.01e-4" "-2.01e-4" (Just xsdDouble) ((-0.000201)::Double) , testToConv "double -2.01e-4" "-2.01E-4" (Just xsdDouble) ((-0.000201)::Double) , testConv "double 2.01e38" "2.01E38" (Just xsdDouble) (2.01e38::Double) , testConv "double -2.01e38" "-2.01E38" (Just xsdDouble) ((-2.01e38)::Double) , testConv "double 2.01e108" "2.01E108" (Just xsdDouble) (2.01e108::Double) , testConv "double -2.01e108" "-2.01E108" (Just xsdDouble) ((-2.01e108)::Double) -- URI related types , testEq "tconv:sname s1" s1 (toRDFLabel qb1s1) , testEq "fconv:sname s1" (Just qb1s1) (fromRDFLabel s1) , testEq "tconv:qname s1" s1 (toRDFLabel qn1s1) , testEq "fconv:qname s1" (Just qn1s1) (fromRDFLabel s1) , testEq "tconv:URI s1" s1 (toRDFLabel qu1s1) , testEq "fconv:URI s1" (Just qu1s1) (fromRDFLabel s1) -- time values , testConv "time1" "1970-01-01T00:00:00Z" (Just xsdDateTime) utc1 , testToConv "time2" "2011-02-28T20:04:02.304Z" (Just xsdDateTime) utc2 , testFrConv "time2a" "2011-02-28T20:04:02.304Z" (Just xsdDateTime) utc2 , testFrConv "time2b" "2011-02-28T17:04:02.304-03:00" (Just xsdDateTime) utc2 , testFrConv "time2c" "2011-03-01T00:04:02.304+04:00" (Just xsdDateTime) utc2 , testFrConv "time2d" "2011-02-28T20:04:02.304" (Just xsdDateTime) utc2 , testConv "time2Z" "2011-02-28T20:04:02.304Z" (Just xsdDateTime) utc2 , testConv "day1a" "1970-01-01Z" (Just xsdDate) day1 , testFrConv "day1b" "1970-01-01" (Just xsdDate) day1 , testFrConv "day1c" "1970-01-01-03:00" (Just xsdDate) day1 , testFrConv "day1d" "1970-01-01+04:00" (Just xsdDate) day1 -- basic fromRDFTriple test , testEq "fconv:triple" (Just (qb1s1, p1, "l1" :: String)) (fromRDFTriple t04) -- TODO ] utc1, utc2 :: UTCTime #if MIN_VERSION_time(1,6,0) utc1 = fromJust (buildTime defaultTimeLocale []) #else utc1 = buildTime defaultTimeLocale [] #endif utc2 = let dNum = fromGregorian 2011 2 28 tDiff = (23.0 - 3.0) * 3600.0 + 4.0 * 60.0 + 2.304 in UTCTime dNum tDiff day1 :: Day day1 = fromGregorian 1970 1 1 ------------------------------------------------------------ -- RDFLabel classification tests ------------------------------------------------------------ testClass :: String -> (RDFLabel -> Bool) -> RDFLabel -> Bool -> Test testClass lab clsf nod eq = testCompare "testClass:" lab eq (clsf nod) altIsXmlLit :: RDFLabel -> Bool altIsXmlLit = isDatatyped rdfXMLLiteral testNodeClassSuite :: Test testNodeClassSuite = TestList [ testClass "testClass01" isUri s1 True , testClass "testClass02" isUri s5 False , testClass "testClass03" isUri ba1 False , testClass "testClass04" isUri l1 False , testClass "testClass05" isUri l10 False , testClass "testClass06" isUri cm1 True , testClass "testClass07" isUri nm1 True , testClass "testClass08" isUri v1 False , testClass "testClass10" isLiteral s1 False , testClass "testClass11" isLiteral s5 False , testClass "testClass12" isLiteral ba1 False , testClass "testClass13" isLiteral l1 True , testClass "testClass14" isLiteral l4 True , testClass "testClass15" isLiteral l5 True , testClass "testClass16" isLiteral l10 True , testClass "testClass17" isLiteral l11 True , testClass "testClass18" isLiteral cm1 False , testClass "testClass19" isLiteral v1 False , testClass "testClass20" isTypedLiteral s1 False , testClass "testClass21" isTypedLiteral s5 False , testClass "testClass22" isTypedLiteral ba1 False , testClass "testClass23" isTypedLiteral l1 False , testClass "testClass24" isTypedLiteral l2 False , testClass "testClass25" isTypedLiteral l4 True , testClass "testClass26" isTypedLiteral l5 True , testClass "testClass27" isTypedLiteral l10 True , testClass "testClass28" isTypedLiteral l11 True , testClass "testClass29" isTypedLiteral v1 False , testClass "testClass30" isUntypedLiteral s1 False , testClass "testClass31" isUntypedLiteral s5 False , testClass "testClass32" isUntypedLiteral ba1 False , testClass "testClass33" isUntypedLiteral l1 True , testClass "testClass34" isUntypedLiteral l2 True , testClass "testClass35" isUntypedLiteral l4 False , testClass "testClass36" isUntypedLiteral l5 False , testClass "testClass37" isUntypedLiteral l10 False , testClass "testClass38" isUntypedLiteral l11 False , testClass "testClass39" isUntypedLiteral v1 False , testClass "testClass40" isXMLLiteral s1 False , testClass "testClass41" isXMLLiteral s5 False , testClass "testClass42" isXMLLiteral ba1 False , testClass "testClass43" isXMLLiteral l1 False , testClass "testClass44" isXMLLiteral l2 False , testClass "testClass45" isXMLLiteral l4 False , testClass "testClass46" isXMLLiteral l5 False , testClass "testClass47" isXMLLiteral l10 True , testClass "testClass48" isXMLLiteral l11 True , testClass "testClass49" isXMLLiteral v1 False , testClass "testClass50" altIsXmlLit s1 False , testClass "testClass51" altIsXmlLit s5 False , testClass "testClass52" altIsXmlLit ba1 False , testClass "testClass53" altIsXmlLit l1 False , testClass "testClass54" altIsXmlLit l2 False , testClass "testClass55" altIsXmlLit l4 False , testClass "testClass56" altIsXmlLit l5 False , testClass "testClass57" altIsXmlLit l10 True , testClass "testClass58" altIsXmlLit l11 True , testClass "testClass60" isMemberProp s1 False , testClass "testClass61" isMemberProp s5 False , testClass "testClass62" isMemberProp ba1 False , testClass "testClass63" isMemberProp l1 False , testClass "testClass64" isMemberProp l10 False , testClass "testClass65" isMemberProp cm1 True , testClass "testClass66" isMemberProp cm2 True , testClass "testClass67" isMemberProp nm1 False , testClass "testClass68" isMemberProp nm2 False , testClass "testClass70" isBlank s7 False , testClass "testClass71" isBlank s5 True , testClass "testClass72" isBlank ba1 True , testClass "testClass73" isBlank l1 False , testClass "testClass74" isBlank l4 False , testClass "testClass75" isBlank l5 False , testClass "testClass76" isBlank l10 False , testClass "testClass77" isBlank l11 False , testClass "testClass78" isBlank cm1 False , testClass "testClass79" isBlank v1 False , testClass "testClass80" isQueryVar s8 False , testClass "testClass81" isQueryVar s5 False , testClass "testClass82" isQueryVar ba1 False , testClass "testClass83" isQueryVar l1 False , testClass "testClass84" isQueryVar l4 False , testClass "testClass85" isQueryVar l5 False , testClass "testClass86" isQueryVar l10 False , testClass "testClass87" isQueryVar l11 False , testClass "testClass88" isQueryVar cm1 False , testClass "testClass89" isQueryVar v1 True ] ------------------------------------------------------------ -- RDFLabel local part separation and recombination tests ------------------------------------------------------------ testLocalEq :: String -> String -> String -> Test testLocalEq = testCompare "testLocalEq:" testLocalLabEq :: String -> RDFLabel -> RDFLabel -> Test testLocalLabEq = testCompare "testLocalEq:" testNodeLocalSuite :: Test testNodeLocalSuite = TestList [ testLocalEq "01" "b1" (getLocal b1) , testLocalEq "02" "b2" (getLocal b2) , testLocalEq "03" "?v1" (getLocal v1) , testLocalEq "04" "?v2" (getLocal v2) , testLocalLabEq "05" b1 (makeLabel "b1") , testLocalLabEq "06" b2 (makeLabel "b2") , testLocalLabEq "07" v1 (makeLabel "?v1") , testLocalLabEq "08" v2 (makeLabel "?v2") ] ------------------------------------------------------------ -- Node generation tests ------------------------------------------------------------ take3 :: [a] -> (a, a, a) take3 (a : b : c : _) = (a, b, c) take3 _ = error "Expected at least 3 elements" testNodeEq :: String -> RDFLabel -> RDFLabel -> Test testNodeEq = testCompare "testNodeEq:" tnn01, tnn02 :: RDFLabel tnn01 = newNode v1 [b1,b3,v1,v2] tnn02 = newNode b1 [b1,b3,v1,v2] tnn03, tnn04, tnn05 :: RDFLabel (tnn03, tnn04, tnn05) = take3 $ newNodes b1 [b1, b3, v1, v2] tnn06, tnn07, tnn08 :: RDFLabel (tnn06, tnn07, tnn08) = take3 $ newNodes s1 [b1,b3,v1,v2,tnns3] tnn09 :: RDFLabel tnn09 = newNodes l1 [b1,b3,v1,v2,tnns3] !! 2 tnns1, tnns2, tnns3, tnns4, tnnl1 :: RDFLabel tnns1 = Blank "Res_s1" tnns2 = Blank "Res_s2" tnns3 = Blank "Res_s3" tnns4 = Blank "Res_s4" tnnl1 = Blank "Lit_2" testNewNodeSuite :: Test testNewNodeSuite = TestList [ testNodeEq "testNewNode01" v3 tnn01 , testNodeEq "testNewNode02" b2 tnn02 , testNodeEq "testNewNode03" b2 tnn03 , testNodeEq "testNewNode04" b4 tnn04 , testNodeEq "testNewNode05" b5 tnn05 , testNodeEq "testNewNode06" tnns1 tnn06 , testNodeEq "testNewNode07" tnns2 tnn07 , testNodeEq "testNewNode08" tnns4 tnn08 , testNodeEq "testNewNode09" tnnl1 tnn09 ] ------------------------------------------------------------ -- RDFLabel ordering tests ------------------------------------------------------------ testLabelOrd :: String -> Ordering -> RDFLabel -> RDFLabel -> Test testLabelOrd lab order n1 n2 = TestCase ( assertEqual ("testLabelOrd:"++lab++"["++show n1++","++show n2++"]") order (compare n1 n2) ) nodeorder :: [String] nodeorder = [ -- URIs "es1", "us1" , "o1", "p1", "s1" , "o2", "p2", "s2" , "s4", "o4", "s6", "s7" , "o3", "p3", "p4", "s3" -- literals , "l1" -- language literals , "l2", "l2gb", "l3" -- typed literals (we have repeats) , "l10", "l11", "l12" , "l4", "l5", "l6" , "l7", "l8", "l9" -- blank nodes , "b1", "b2", "b3", "b4" , "o5", "s5", "s8" -- variables , "v1", "v2" ] testNodeOrdSuite :: Test testNodeOrdSuite = TestList [ testLabelOrd (ll1 `hyphen` ll2) (tOrd ll1 ll2) n1 n2 | (ll1,n1) <- nodelist , (ll2,n2) <- nodelist ] where tOrd ll1 ll2 | tEq ll1 ll2 = EQ | otherwise = comparing fromJust (elemIndex ll1 nodeorder) (elemIndex ll2 nodeorder) tEq ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` nodeeqlist || (ll2,ll1) `elem` nodeeqlist ------------------------------------------------------------ -- Other RDFLabel tests ------------------------------------------------------------ testLabelOtherSuite :: Test testLabelOtherSuite = TestList [ testEq "testLabelName01" (getScopedName s1) qb1s1 , testEq "testLabelName02" (getScopedName b1) nullScopedName , testEq "testLabelName03" (getScopedName l1) nullScopedName , testEq "testLabelName04" (getScopedName v1) nullScopedName ] ------------------------------------------------------------ -- Statement construction and equality tests ------------------------------------------------------------ testStmtEq :: String -> Bool -> RDFTriple -> RDFTriple -> Test testStmtEq = testCompareEq "testStmtEq:" slist, plist, olist :: [(String, RDFLabel)] slist = [ ("s1",s1), ("s4",s4), ("s5",s5), ("s6",s6), ("s7",s7) ] plist = [ ("p1",p1) ] olist = [ ("o1",o1), ("o4",o4), ("o5",o5), ("l1",l1), ("l4",l4), ("l7",l7), ("l8",l8), ("l10",l10) ] tlist :: [(String, RDFTriple)] tlist = [ (lab s p o,trp s p o) | s <- slist, p <- plist, o <- olist ] where lab (s,_) (p,_) (o,_) = intercalate ("."::String) [s, p, o] trp (_,s) (_,p) (_,o) = arc s p o stmteqlist :: [(String, String)] stmteqlist = [ ("s6.p1.l1", "s7.p1.l1"), ("s6.p1.l4", "s7.p1.l4"), ("s6.p1.l7", "s7.p1.l7"), ("s6.p1.l7", "s7.p1.l8"), ("s6.p1.l8", "s7.p1.l7"), ("s6.p1.l8", "s7.p1.l8"), ("s6.p1.l10","s7.p1.l10"), ("s6.p1.o1", "s7.p1.o1"), ("s6.p1.o4", "s7.p1.o4"), ("s6.p1.o5", "s7.p1.o5"), ("s1.p1.l7", "s1.p1.l8"), ("s4.p1.l7", "s4.p1.l8"), ("s5.p1.l7", "s5.p1.l8"), ("s6.p1.l7", "s6.p1.l8"), ("s7.p1.l7", "s7.p1.l8") ] testStmtEqSuite :: Test testStmtEqSuite = TestList [ testStmtEq (ll1 `hyphen` ll2) (tEq ll1 ll2) t1 t2 | (ll1,t1) <- tlist , (ll2,t2) <- tlist ] where tEq ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` stmteqlist || (ll2,ll1) `elem` stmteqlist ------------------------------------------------------------ -- Graph construction and equality tests ------------------------------------------------------------ testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test testGraphEq lab eq gg1 gg2 = -- Set test False to get extra trace info about graph differences -- Some tests will fail with this setting, so revert to True to -- get test result. if True then testCompareEq "testGraphEq:" lab eq gg1 gg2 else TestList [ TestCase ( assertEqual ("testGraphEq:"++lab) eq (gg1==gg2) ) , TestCase ( assertEqual ("testGraphEq:"++lab) gg1 gg2 ) ] testGraphEqM :: String -> Bool -> Maybe RDFGraph -> Maybe RDFGraph -> Test testGraphEqM = testCompareEq "testGraphEq:" t01, t02, t03, t04, t05, t06 :: RDFTriple t01 = arc s1 p1 o1 t02 = arc s2 p1 o2 t03 = arc s3 p1 o3 t04 = arc s1 p1 l1 t05 = arc s2 p1 l4 t06 = arc s3 p1 l10 t10, t11, t12 :: RDFTriple t10 = arc s1 p1 b1 t11 = arc b1 p2 b2 t12 = arc b2 p3 o1 t20, t21, t22 :: RDFTriple t20 = arc s1 p1 b3 t21 = arc b3 p2 b4 t22 = arc b4 p3 o1 tt01, tt02, tt03, tt04, tt05, tt06 :: RDFTriple tt01 = arc st1 p1 o1 tt02 = arc st2 p1 o2 tt03 = arc st3 p1 o3 tt04 = toRDFTriple st1 p1 ("l1" :: RDFLabel) -- tt04 = arc st1 p1 l1 tt05 = arc st2 p1 l4 tt06 = arc st3 p1 l10 makeNewPrefixNamespace :: (T.Text,Namespace) -> Namespace makeNewPrefixNamespace (pre,ns) = makeNamespace (Just pre) (getNamespaceURI ns) nslist :: NamespaceMap nslist = M.fromList $ map getNamespaceTuple [base1,base2,base3,base4] nslistalt :: NamespaceMap nslistalt = M.fromList $ map (first (fmap (T.append "alt")) . getNamespaceTuple) [base1,base2,base3] toGraph :: [RDFTriple] -> RDFGraph toGraph stmts = NSGraph { namespaces = nslist , formulae = emptyFormulaMap , statements = S.fromList stmts } g1, gt1 :: RDFGraph g1 = toGraph [t01] gt1 = toGraph [tt01] -- Check for nonsensitivety of graph equility to namespace differences: g1alt :: RDFGraph g1alt = NSGraph { namespaces = nslistalt , formulae = emptyFormulaMap , statements = S.singleton t01 } -- Construct version of g1 using just URIs uris1, urip1, urio1 :: ScopedName uris1 = "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" urip1 = "http://id.ninebynine.org/wip/2003/test/graph1/node#p1" urio1 = "http://id.ninebynine.org/wip/2003/test/graph1/node#o1" tu01 :: RDFTriple tu01 = toRDFTriple uris1 urip1 urio1 g2arcs :: [String] g2arcs = [ "(base1:s1,base1:p1,base1:o1)" , "(base1:s1,base1:p1,\"l1\")" , "(base2:s2,base1:p1,base2:o2)" , "(base2:s2,base1:p1,\"l4\"^^base1:type1)" , "(base3:s3,base1:p1,base3:o3)" , "(base3:s3,base1:p1,\"l10\"^^rdf:XMLLiteral)" ] g2str :: String -> String g2str sp = let spaces = " " in intercalate ('\n':sp) $ ["Graph, formulae: ", "arcs: "] ++ map (spaces++) g2arcs g2Labels :: [RDFTriple] g2Labels = [t01,t02,t03,t04,t05,t06] g1uri, g2, gt2, g3, gt3, g4, g5, g6, g7, g8, g9, g10 :: RDFGraph g1uri = toGraph [tu01] g2 = toGraph g2Labels gt2 = toGraph [tt01,tt02,tt03,tt04,tt05,tt06] g3 = toGraph [t06,t05,t04,t03,t02,t01] gt3 = toGraph [tt06,tt05,tt04,tt03,tt02,tt01] g4 = toGraph [t01,t02,t03,t04,t05,t06,t10,t11,t12] g5 = toGraph [t01,t02,t03,t04,t05,t06,t20,t21,t22] g6 = toGraph [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] g7 = toGraph [t01,t02] g8 = toGraph [t02,t01] g9 = toGraph [t03,t02,t01] g10 = toGraph [t02,t02,t01] fg1g2 :: RDFGraph fg1g2 = g1 `mappend` g2 g9a, g10a :: RDFGraph g9a = addArc t03 g8 g10a = addArc t02 g8 glist :: [(String, RDFGraph)] glist = [ ("g1",g1), ("g1alt",g1alt), ("g1uri",g1uri) , ("g2",g2), ("g3",g3), ("g4",g4), ("g5",g5), ("g6",g6) , ("g7",g7), ("g8",g8), ("g9",g9), ("g10",g10) , ("g9a",g9a), ("g10a",g10a) ] grapheqlist :: [(String, String)] grapheqlist = [ ("g1","g1alt") , ("g1","g1uri") , ("g1alt","g1uri") , ("g2","g3") , ("g4","g5") , ("g7","g8") , ("g7","g10") , ("g7","g10a") , ("g8","g10") , ("g8","g10a") , ("g9","g9a") , ("g10","g10a") ] testGraphEqSuite :: Test testGraphEqSuite = TestList [ testGraphEq (ll1 `hyphen` ll2) (tEq ll1 ll2) gg1 gg2 | (ll1,gg1) <- glist , (ll2,gg2) <- glist ] where tEq ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` grapheqlist || (ll2,ll1) `elem` grapheqlist -- Selected tests for debugging testGraphEqSelSuite :: Test testGraphEqSelSuite = TestList [ testGraphEq "g1-g2" False g1 g2 , testGraphEq "g2-g1" False g2 g1 , testGraphEq "g2-g2" True g2 g2 , testGraphEq "g2-g3" True g2 g3 , testGraphEq "g1-g4" False g1 g4 , testGraphEq "g2-g4" False g2 g4 , testGraphEq "g7-g7" True g7 g7 , testGraphEq "g7-g8" True g7 g8 , testGraphEq "g8-g7" True g8 g7 , testGraphEq "g9-g9a" True g9 g9a , testGraphEq "g10-g10a" True g10 g10a ] {- showLabel :: RDFLabel -> String showLabel = (" " ++) . show -} -- QUS: are these tests useful, since all they test os the Monoid instance -- of NSGraph (but maybe we do not explicitly test this elsewhere?) -- -- The tests also used to check the Foldable instance of NSGraph but these -- have been removed with the move to Set, rather than list, storage. testGraphFoldSuite :: Test testGraphFoldSuite = TestList [ testEq "fold0" (mempty :: RDFGraph) (Foldable.fold []) , testEq "foldE" (mempty :: RDFGraph) (Foldable.fold [mempty]) , testEq "foldEE" (mempty :: RDFGraph) (Foldable.fold [mempty,mempty]) , testEq "foldg1" g1 (Foldable.fold [g1]) , testEq "foldg1E" g1 (Foldable.fold [g1,mempty]) , testEq "foldEg1" g1 (Foldable.fold [mempty,g1]) , testEq "foldg1g2" fg1g2 (Foldable.fold [g1,g2]) , testEq "foldg2g1" fg1g2 (Foldable.fold [g2,g1]) {- TODO: reinstate? , testEq "foldMap0" "" (Foldable.foldMap showLabel (mempty::RDFGraph)) , testEq "foldMapg1" (concatMap showLabel [s1,p1,o1]) (Foldable.foldMap showLabel g1) , testEq "foldMapg1f2" (concatMap showLabel $ s2 : concatMap arcToTriple g2Labels ++ [s1,p1,o1]) (Foldable.foldMap showLabel g1f2) -} ] ------------------------------------------------------------ -- Test updating formulae ------------------------------------------------------------ testFormulaLookup :: String -> FormulaMap RDFLabel -> RDFLabel -> Maybe RDFGraph -> Test testFormulaLookup lab fs fl gr = testCompare "testFormulaLookup:" lab gr $ M.lookup fl fs -- testCompare "testFormulaLookup:" lab gr $ fmap formGraph $ M.lookup fl fs testMaybeEq :: (Eq a, Show a) => String -> Maybe a -> Maybe a -> Test testMaybeEq = testCompare "testMaybeEq:" g1f1, g1f2, g1f3, g1f4, g1f5, g1f6, g1f7 :: RDFGraph g1f1 = g1 g1f2 = setFormulae fm2 g1f1 g1f3 = setFormulae fm3 g1f1 g1f4 = setFormulae fm4 g1f1 g1f5 = setFormulae fm5 g1f1 g1f6 = setFormulae fm6 g1f1 g1f7 = setFormulae fm7 g1f1 g1f1str, g1f2str :: String g1f1str = "Graph, formulae: \n" ++ "arcs: \n" ++ " (base1:s1,base1:p1,base1:o1)" g1f2str = "Graph, formulae: \n " ++ lf22str ++ "\n" ++ "arcs: \n" ++ " (base1:s1,base1:p1,base1:o1)" lf11, lf22, lf23, lf24, lf25, lf27, lf33, lf36 :: Formula RDFLabel lf11 = Formula s1 g1 lf22 = Formula s2 g2 lf23 = Formula s2 g3 lf24 = Formula s2 g4 lf25 = Formula s2 g5 lf27 = Formula s2 g7 lf33 = Formula s3 g3 lf36 = Formula s3 g6 lf22str :: String lf22str = "base2:s2 :- { \n" ++ " (base1:s1,base1:p1,base1:o1)\n" ++ " (base1:s1,base1:p1,\"l1\")\n" ++ " (base2:s2,base1:p1,base2:o2)\n" ++ " (base2:s2,base1:p1,\"l4\"^^base1:type1)\n" ++ " (base3:s3,base1:p1,base3:o3)\n" ++ " (base3:s3,base1:p1,\"l10\"^^rdf:XMLLiteral) }" toFM :: [Formula RDFLabel] -> FormulaMap RDFLabel toFM = M.fromList . map (formLabel &&& formGraph) fm2, fm3, fm4, fm5, fm6, fm7 :: FormulaMap RDFLabel fm2 = toFM [lf22] fm3 = toFM [lf11, lf22, lf33] fm4 = toFM [lf11, lf23, lf33] fm5 = toFM [lf11, lf24, lf36] fm6 = toFM [lf11, lf25, lf36] fm7 = toFM [lf11, lf27, lf36] f1, f2, f3, f4, f5, f6, f7 :: FormulaMap RDFLabel f1 = getFormulae g1f1 f2 = getFormulae g1f2 f3 = getFormulae g1f3 f4 = getFormulae g1f4 f5 = getFormulae g1f5 f6 = getFormulae g1f6 f7 = getFormulae g1f7 -- Same pattern as 1-3, but using base graph with more nodes used: -- The graph comparison results are expected to be different, -- because of formulae associated with nodes actually used in the -- graph g2f1, g2f2, g2f3 :: RDFGraph g2f1 = g2 g2f2 = setFormulae fm2 g2f1 g2f3 = setFormulae fm3 g2f1 f8, f9, f10 :: FormulaMap RDFLabel f8 = getFormulae g2f1 f9 = getFormulae g2f2 f10 = getFormulae g2f3 -- Comparison of graphs containing formulae. -- The intent is that graphs are matched if there is a bijection, -- where the matched nodes are associated with matching formulae. -- Definitions of formulae not used in the graphs don't affect the -- match result. -- Test methods to set/access an individual formula in a graph g1f21, g1f22 :: RDFGraph g1f21 = setFormula (Formula s1 g7) g1f2 g1f22 = setFormula (Formula s1 g1) g1f21 f21, f22 :: FormulaMap RDFLabel f21 = getFormulae g1f21 f22 = getFormulae g1f22 f23a, f23b, f23c :: Maybe RDFGraph f23a = getFormula g1f22 s1 f23b = getFormula g1f22 s2 f23c = getFormula g1f22 s3 testGraphFormulaSuite :: Test testGraphFormulaSuite = TestLabel "TestFormulae" $ TestList [ testFormulaLookup "01a" f1 s1 Nothing , testFormulaLookup "01b" f1 s2 Nothing , testFormulaLookup "01c" f1 s3 Nothing , testFormulaLookup "02a" f2 s1 Nothing , testFormulaLookup "02b" f2 s2 (Just g2) , testFormulaLookup "02c" f2 s3 Nothing , testFormulaLookup "03a" f3 s1 (Just g1) , testFormulaLookup "03b" f3 s2 (Just g2) , testFormulaLookup "03c" f3 s3 (Just g3) , testFormulaLookup "04a" f4 s1 (Just g1) , testFormulaLookup "04b" f4 s2 (Just g3) , testFormulaLookup "04c" f4 s3 (Just g3) , testFormulaLookup "05a" f5 s1 (Just g1) , testFormulaLookup "05b" f5 s2 (Just g4) , testFormulaLookup "05c" f5 s3 (Just g6) , testFormulaLookup "06a" f6 s1 (Just g1) , testFormulaLookup "06b" f6 s2 (Just g5) , testFormulaLookup "06c" f6 s3 (Just g6) , testFormulaLookup "07a" f7 s1 (Just g1) , testFormulaLookup "07b" f7 s2 (Just g7) , testFormulaLookup "07c" f7 s3 (Just g6) , testFormulaLookup "08a" f8 s1 Nothing , testFormulaLookup "08b" f8 s2 Nothing , testFormulaLookup "08c" f8 s3 Nothing , testFormulaLookup "09a" f9 s1 Nothing , testFormulaLookup "09b" f9 s2 (Just g2) , testFormulaLookup "09c" f9 s3 Nothing , testFormulaLookup "10a" f10 s1 (Just g1) , testFormulaLookup "10b" f10 s2 (Just g2) , testFormulaLookup "10c" f10 s3 (Just g3) -- a few tests added in to improve test coverage , testEq "lf11" (Formula s1 g1) lf11 , testEq "g2:show" (g2str "") (show g2) , testEq "g1f1:show" g1f1str (show g1f1) , testEq "g1f2:show" g1f2str (show g1f2) , testEq "lf22:show" lf22str (show lf22) , testEq "[]:showList" "[no graphs]" (show ([] :: [RDFGraph])) , testEq "g2:showList1" ("[" ++ g2str " " ++ "]") (show [g2]) , testEq "g2:showList2" ("[" ++ g2str " " ++ ",\n " ++ g2str " " ++ "]") (show [g2,g2]) -- back to the main schedule , testGraphEq "g1f1-g1f1" True g1f1 g1f1 , testGraphEq "g1f1-g1f2" True g1f1 g1f2 , testGraphEq "g1f1-g1f3" False g1f1 g1f3 , testGraphEq "g1f2-g1f1" True g1f2 g1f1 , testGraphEq "g1f2-g1f2" True g1f2 g1f2 , testGraphEq "g1f2-g1f3" False g1f2 g1f3 , testGraphEq "g1f3-g1f1" False g1f3 g1f1 , testGraphEq "g1f3-g1f2" False g1f3 g1f2 , testGraphEq "g1f3-g1f3" True g1f3 g1f3 , testGraphEq "g1f4-g1f3" True g1f4 g1f3 , testGraphEq "g1f4-g1f4" True g1f4 g1f4 , testGraphEq "g1f4-g1f5" True g1f4 g1f5 , testGraphEq "g1f5-g1f5" True g1f5 g1f5 , testGraphEq "g1f5-g1f6" True g1f5 g1f6 , testGraphEq "g1f5-g1f7" True g1f5 g1f7 , testGraphEq "g1f6-g1f5" True g1f6 g1f5 , testGraphEq "g1f6-g1f6" True g1f6 g1f6 , testGraphEq "g1f6-g1f7" True g1f6 g1f7 , testGraphEq "g1f7-g1f5" True g1f7 g1f5 , testGraphEq "g1f7-g1f6" True g1f7 g1f6 , testGraphEq "g1f7-g1f7" True g1f7 g1f7 , testGraphEq "g2f1-g2f1" True g2f1 g2f1 , testGraphEq "g2f1-g2f2" False g2f1 g2f2 , testGraphEq "g2f1-g2f3" False g2f1 g2f3 , testGraphEq "g2f2-g2f1" False g2f2 g2f1 , testGraphEq "g2f2-g2f2" True g2f2 g2f2 , testGraphEq "g2f2-g2f3" False g2f2 g2f3 , testGraphEq "g2f3-g2f1" False g2f3 g2f1 , testGraphEq "g2f3-g2f2" False g2f3 g2f2 , testGraphEq "g2f3-g2f3" True g2f3 g2f3 , testFormulaLookup "21a" f21 s1 (Just g7) , testFormulaLookup "21b" f21 s2 (Just g2) , testFormulaLookup "21c" f21 s3 Nothing , testFormulaLookup "22a" f22 s1 (Just g1) , testFormulaLookup "22b" f22 s2 (Just g2) , testFormulaLookup "22c" f22 s3 Nothing , testMaybeEq "23a" f23a (Just g1) , testMaybeEq "23b" f23b (Just g2) , testMaybeEq "23c" f23c Nothing ] ------------------------------------------------------------ -- Test fmap translations of graphs, including formulae ------------------------------------------------------------ translate :: RDFLabel -> RDFLabel translate lab | lab == s1 = st1 | lab == s2 = st2 | lab == s3 = st3 | otherwise = lab translateM :: RDFLabel -> Maybe RDFLabel translateM lab | lab == s1 = Just st1 | lab == s2 = Just st2 | lab == s3 = Just st3 | isBlank lab = Nothing | otherwise = Just lab gt1f1a, gt1f1b, gt1f2a, gt1f2b, gt1f3a, gt1f3b, gt2f1a, gt2f1b, gt2f2a, gt2f2b, gt2f3a, gt2f3b :: RDFGraph gt1f1a = gt1 gt1f1b = fmapNSGraph translate g1f1 gt1f2a = setFormulae ftm2 gt1 gt1f2b = fmapNSGraph translate g1f2 gt1f3a = setFormulae ftm3 gt1 gt1f3b = fmapNSGraph translate g1f3 gt2f1a = gt2 gt2f1b = fmapNSGraph translate g2f1 gt2f2a = setFormulae ftm2 gt2 gt2f2b = fmapNSGraph translate g2f2 gt2f3a = setFormulae ftm3 gt2 gt2f3b = fmapNSGraph translate g2f3 ft1, ft2, ft3, ft4, ft5, ft6 :: FormulaMap RDFLabel ft1 = getFormulae gt1f1b ft2 = getFormulae gt1f2b ft3 = getFormulae gt1f3b ft4 = getFormulae gt2f1b ft5 = getFormulae gt2f2b ft6 = getFormulae gt2f3b ftm2, ftm3 :: FormulaMap RDFLabel ftm2 = toFM [Formula st2 gt2] ftm3 = toFM [Formula st1 gt1,Formula st2 gt2,Formula st3 gt3] -- Monadic translate tests, using Maybe Monad {- TODO: reinstate? gt1f1aM, gt1f1bM, gt1f2aM, gt1f2bM, gt1f5M :: Maybe RDFGraph gt1f1aM = Just gt1 gt1f1bM = Traversable.mapM translateM g1f1 gt1f2aM = Just gt1f2a gt1f2bM = Traversable.mapM translateM g1f2 gt1f5M = Traversable.mapM translateM g1f5 ft1M, ft2M :: FormulaMap RDFLabel ft1M = getFormulae $ fromMaybe (error "Unexpected: gt1f1bM") gt1f1bM ft2M = getFormulae $ fromMaybe (error "Unexpected: gt1f2bM") gt1f2bM --} testGraphTranslateSuite :: Test testGraphTranslateSuite = TestLabel "TestTranslate" $ TestList [ testGraphEq "gt1f1a-gt1f1b" True gt1f1a gt1f1b , testFormulaLookup "GraphTranslate01b" ft1 st1 Nothing , testFormulaLookup "GraphTranslate01c" ft1 st2 Nothing , testFormulaLookup "GraphTranslate01d" ft1 st3 Nothing , testEq "gt1f1a-gt1f1b" gt1f1a gt1f1b , testGraphEq "gt1f2a-gt1f2b" True gt1f2a gt1f2b , testFormulaLookup "GraphTranslate02b" ft2 st1 Nothing , testFormulaLookup "GraphTranslate02c" ft2 st2 (Just gt2) , testFormulaLookup "GraphTranslate02d" ft2 st3 Nothing , testGraphEq "gt1f3a-gt1f3b" True gt1f3a gt1f3b , testFormulaLookup "GraphTranslate03b" ft3 st1 (Just gt1) , testFormulaLookup "GraphTranslate03c" ft3 st2 (Just gt2) , testFormulaLookup "GraphTranslate03d" ft3 st3 (Just gt3) , testGraphEq "gt2f1a-gt2f1b" True gt2f1a gt2f1b , testFormulaLookup "GraphTranslate04b" ft4 st1 Nothing , testFormulaLookup "GraphTranslate04c" ft4 st2 Nothing , testFormulaLookup "GraphTranslate04d" ft4 st3 Nothing , testGraphEq "gt2f2a-gt2f2b" True gt2f2a gt2f2b , testFormulaLookup "GraphTranslate05b" ft5 st1 Nothing , testFormulaLookup "GraphTranslate05c" ft5 st2 (Just gt2) , testFormulaLookup "GraphTranslate05d" ft5 st3 Nothing , testGraphEq "gt2f3a-gt2f3b" True gt2f3a gt2f3b , testFormulaLookup "GraphTranslate06b" ft6 st1 (Just gt1) , testFormulaLookup "GraphTranslate06c" ft6 st2 (Just gt2) , testFormulaLookup "GraphTranslate06d" ft6 st3 (Just gt3) -- , testGraphEqM "gt1f1aM-gt1f1bM" True gt1f1aM gt1f1bM TODO: reinstate? -- , testFormulaLookup "GraphTranslate07b" ft1M st1 Nothing -- , testFormulaLookup "GraphTranslate07c" ft1M st2 Nothing -- , testFormulaLookup "GraphTranslate07d" ft1M st3 Nothing -- , testEq "gt1f1aM-gt1f1bM" gt1f1aM gt1f1bM -- , testGraphEqM "gt1f2aM-gt1f2bM" True gt1f2aM gt1f2bM -- , testFormulaLookup "GraphTranslate08b" ft2M st1 Nothing -- , testFormulaLookup "GraphTranslate08c" ft2M st2 (Just gt2) -- , testFormulaLookup "GraphTranslate08d" ft2M st3 Nothing -- , testEq "gt1f2aM-gt1f2bM" gt1f2aM gt1f1bM -- , testEq "GraphTranslate09a" Nothing gt1f5M ] ------------------------------------------------------------ -- Test merge with conflicting bnodes, including formulae ------------------------------------------------------------ testMerge :: String -> RDFGraph -> RDFGraph -> RDFGraph -> Test testMerge lab a1 a2 gr = TestCase ( assertGrEquiv ("testMerge:"++lab) gr (a1 `mappend` a2) ) assertGrHelper :: String -> RDFGraph -> RDFGraph -> Bool -> Assertion assertGrHelper lbl gg1 gg2 = assertBool $ lbl++"\nExpected: "++ show gg1 ++"\nObtained: "++ show gg2 assertGrEquiv :: String -> RDFGraph -> RDFGraph -> Assertion assertGrEquiv lbl gg1 gg2 = assertGrHelper lbl gg1 gg2 $ getArcs gg1 == getArcs gg2 assertGrEq :: String -> RDFGraph -> RDFGraph -> Assertion assertGrEq lbl gg1 gg2 = assertGrHelper lbl gg1 gg2 $ gg1 == gg2 tm01, tm02, tm03, tm04, tm05, tm06, tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 :: RDFTriple tm01 = arc s1 p1 b1 tm02 = arc b1 p1 o2 tm03 = arc b1 p1 o3 tm04 = arc b2 p2 b3 tm05 = arc b3 p2 b4 tm06 = arc bb p2 b5 tm07 = arc s2 p3 v1 tm08 = arc s3 p3 v2 tm09 = arc s4 p1 c1 tm10 = arc c2 p1 o4 tm11 = arc s4 p2 ba1 tm12 = arc ba2 p2 o4 tm13 = arc s4 p2 bn3 tm14 = arc bn4 p2 o4 tm21, tm22, tm23, tm24, tm25, tm26, tm27, tm28, tm29, tm30, tm31, tm32, tm33, tm34 :: RDFTriple tm21 = arc s1 p1 b6 tm22 = arc b6 p1 o2 tm23 = arc b6 p1 o3 tm24 = arc b7 p2 b8 tm25 = arc b8 p2 b9 tm26 = arc bb0 p2 b10 tm27 = arc s2 p3 v3 tm28 = arc s3 p3 v4 tm29 = arc s4 p1 c3 tm30 = arc c4 p1 o4 tm31 = arc s4 p2 ba3 tm32 = arc ba4 p2 o4 tm33 = arc s4 p2 bn5 tm34 = arc bn6 p2 o4 tm41, tm42, tm43, tm44 :: RDFTriple tm41 = arc s1 p1 b2 tm42 = arc b2 p1 o2 tm43 = arc b2 p1 o3 tm44 = arc b4 p2 b5 tm41a, tm44a :: RDFTriple tm41a = arc s1 p1 b4 tm44a = arc b5 p2 b6 tm67, tm68, tm69, tm70, tm71, tm72, tm73, tm74 :: RDFTriple tm67 = arc s2 p3 v3 tm68 = arc s3 p3 v4 tm69 = arc s4 p1 c3 tm70 = arc c4 p1 o4 tm71 = arc s4 p2 ba3 tm72 = arc ba4 p2 o4 tm73 = arc s4 p2 bn5 tm74 = arc bn6 p2 o4 gm0, gms, gms2, gm1, gm11, gm2, gm2f, gm22, gm3, gm3f, gm33, gm4, gm44 :: RDFGraph gm0 = mempty gms = toGraph [arc s1 p1 o1, arc o1 p2 s3, arc s2 p3 o4] gms2 = toGraph [arc us1 p1 o1, arc p1 p2 es1] gm1 = toGraph [tm01,tm02,tm03,tm04,tm05,tm06,tm07,tm08 ,tm09,tm10,tm11,tm12,tm13,tm14 ] gm11 = toGraph [tm01,tm02,tm03,tm04,tm05,tm06,tm07,tm08 ,tm09,tm10,tm11,tm12,tm13,tm14 ,tm21,tm22,tm23,tm24,tm25,tm26,tm27,tm28 ,tm29,tm30,tm31,tm32,tm33,tm34 ] gm2 = toGraph [tm01] gm2f = toGraph [tm41] gm22 = toGraph [tm01,tm41] gm3 = toGraph [tm04] gm3f = toGraph [tm44] gm33 = toGraph [tm04,tm44] gm4 = toGraph [tm01,tm04] gm44 = toGraph [tm01,tm04,tm41a,tm44a] gm5, gm55 :: RDFGraph gm5 = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm2] , statements = S.fromList [tm01,tm02,tm03] } gm55 = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm2,Formula b2 gm2f] , statements = S.fromList [tm01,tm02,tm03,tm41,tm42,tm43] } gm5s :: RDFGraph gm5s = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm2] , statements = S.fromList [tm01,tm02,tm03, arc s1 p1 o1, arc o1 p2 s3, arc s2 p3 o4] } gm6, gm66 :: RDFGraph gm6 = NSGraph { namespaces = nslist , formulae = toFM [Formula ba1 gm2,Formula bn3 gm3] , statements = S.fromList [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14] } gm66 = NSGraph { namespaces = nslist , formulae = toFM [Formula ba1 gm2,Formula bn3 gm3 ,Formula ba3 gm2f,Formula bn5 gm3f ] , statements = S.fromList [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14 ,tm67,tm68,tm69,tm70,tm71,tm72,tm73,tm74 ] } gm456 :: RDFGraph gm456 = NSGraph { namespaces = nslist -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] , formulae = M.empty , statements = S.fromList [tm01, tm04, tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 , arc b4 p1 o2 , arc b4 p1 o3 ] } gm564 :: RDFGraph gm564 = NSGraph { namespaces = nslist -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] , formulae = M.empty , statements = S.fromList [tm01, tm02, tm03 , arc b5 p2 b6 , tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 ] } gm645 :: RDFGraph gm645 = NSGraph { namespaces = nslist -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] , formulae = M.empty , statements = S.fromList [tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 , arc b4 p1 o2 , arc b4 p1 o3 , arc s1 p1 b5 , arc b6 p2 b7 ] } tm81, tm82, tm811, tm821, tm812, tm822 :: RDFTriple tm81 = arc b1 p1 v1 tm82 = arc b2 p2 v2 tm811 = arc b1 p1 v3 tm821 = arc b2 p2 v4 tm812 = arc b1 p1 vb3 tm822 = arc b2 p2 vb4 gm82b1, gm82b2 :: [(RDFLabel,RDFLabel)] gm82b1 = remapLabelList [v1,v2] [v1,v2,b1,b2] gm82b2 = [(v1,v3),(v2,v4)] gm81, gm82, gm82a, gm83, gm83a :: RDFGraph gm81 = toGraph [tm81,tm82] gm82 = toGraph [tm811,tm821] gm82a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm81 gm83 = toGraph [tm811,tm821] gm83a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm81 gm84, gm85, gm85a, gm86, gm86a :: RDFGraph gm84 = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm81,Formula v2 gm81] , statements = S.fromList [tm81,tm82] } gm85 = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm82,Formula v4 gm82] , statements = S.fromList [tm811,tm821] } gm85a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm84 gm86 = NSGraph { namespaces = nslist , formulae = toFM [Formula b1 gm82,Formula vb4 gm82] , statements = S.fromList [tm812,tm822] } gm86a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm84 testMergeSuite :: Test testMergeSuite = TestList [ testMerge "00" gm0 gm0 gm0 , testMerge "0s" gms gms gms , testMerge "0s2" gms2 gms2 gms2 , testMerge "01" gm1 gm1 gm11 , testMerge "02" gm2 gm2 gm22 , testMerge "03" gm3 gm3 gm33 , testMerge "04" gm4 gm4 gm44 , testMerge "05" gm5 gm5 gm55 , testMerge "06" gm6 gm6 gm66 , testMerge "0+s" gm0 gms gms , testMerge "s+0" gms gm0 gms , testMerge "0+5" gm0 gm5 gm5 , testMerge "5+0" gm5 gm0 gm5 , testMerge "5+s" gm5 gms gm5s , testMerge "s+5" gms gm5 gm5s , TestCase (assertGrEquiv "mconcat:456" gm456 (mconcat [gm4,gm5,gm6])) , TestCase (assertGrEquiv "mconcat:564" gm564 (mconcat [gm5,gm6,gm4])) , TestCase (assertGrEquiv "mconcat:645" gm645 (mconcat [gm6,gm4,gm5])) , TestCase (assertGrEq "mappend" (mappend gm4 (mappend gm5 gm6)) (mappend (mappend gm4 gm5) gm6)) , testGraphEq "Remap07" True gm82 gm82a , testEqv "testRemapList07" gm82b2 gm82b1 , testGraphEq "Remap08" True gm83 gm83a , testGraphEq "Remap09" True gm85 gm85a , testGraphEq "Remap10" True gm86 gm86a ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "LangEq" testLangEqSuite , conv "Conversion" testConversionSuite , conv "NodeEq" testNodeEqSuite , conv "NodeClass" testNodeClassSuite , conv "NodeLocal" testNodeLocalSuite , conv "NewNode" testNewNodeSuite , conv "NodeOrd" testNodeOrdSuite , conv "LabelOther" testLabelOtherSuite , conv "StmtEq" testStmtEqSuite , conv "GraphEq" testGraphEqSuite , conv "GraphEqSel" testGraphEqSelSuite , conv "GraphFold" testGraphFoldSuite , conv "GraphFormula" testGraphFormulaSuite , conv "GraphTranslate" testGraphTranslateSuite , conv "Merge" testMergeSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013, 2014, 2017, 2021 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/RDFDatatypeXsdIntegerTest.hs0000644000000000000000000014553113543702315017733 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : RDFDatatypeXsdIntegerTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This module contains test cases for variable binding values and -- variable binding modifier values. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF import Swish.Datatype ( typeName, typeRules, typeMkRules , getTypeAxiom, getTypeRule , DatatypeVal(..) , getDTMod , DatatypeMap(..) , 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.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.List (intersperse) import Data.Maybe (fromMaybe, fromJust) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Network.URI (URI, parseURI) import Test.HUnit ( Test(TestCase,TestList) , assertFailure ) import TestHelpers (conv, testEq, testElem, testEqv, testEqv2) ------------------------------------------------------------ -- Misc values ------------------------------------------------------------ toURI :: String -> URI toURI = fromJust . parseURI xsdIntName :: LName -> ScopedName xsdIntName = makeNSScopedName namespaceXsdInteger axiomXsdIntegerDT :: ScopedName axiomXsdIntegerDT = xsdIntName "dt" ruleXsdIntegerAbs, ruleXsdIntegerNeg, ruleXsdIntegerSum, ruleXsdIntegerDiff, ruleXsdIntegerProd, ruleXsdIntegerDivMod, ruleXsdIntegerPower, ruleXsdIntegerEq, ruleXsdIntegerNe, ruleXsdIntegerLt, ruleXsdIntegerLe, ruleXsdIntegerGt, ruleXsdIntegerGe :: ScopedName ruleXsdIntegerAbs = xsdIntName "Abs" ruleXsdIntegerNeg = xsdIntName "Neg" ruleXsdIntegerSum = xsdIntName "Sum" ruleXsdIntegerDiff = xsdIntName "Diff" ruleXsdIntegerProd = xsdIntName "Prod" ruleXsdIntegerDivMod = xsdIntName "DivMod" ruleXsdIntegerPower = xsdIntName "Power" ruleXsdIntegerEq = xsdIntName "Eq" ruleXsdIntegerNe = xsdIntName "Ne" ruleXsdIntegerLt = xsdIntName "Lt" ruleXsdIntegerLe = xsdIntName "Le" ruleXsdIntegerGt = xsdIntName "Gt" ruleXsdIntegerGe = xsdIntName "Ge" ------------------------------------------------------------ -- Basic rdfDatatypeXsdInteger tests ------------------------------------------------------------ getXsdIntegerAxiom :: ScopedName -> Formula RDFGraph getXsdIntegerAxiom scopnam = fromMaybe nullFormula $ getTypeAxiom scopnam rdfDatatypeXsdInteger getXsdIntegerRule :: ScopedName -> Rule RDFGraph getXsdIntegerRule scopnam = fromMaybe nullRule $ getTypeRule scopnam rdfDatatypeXsdInteger getXsdIntegerDTmod :: ScopedName -> DatatypeMod Integer RDFLabel RDFLabel getXsdIntegerDTmod scopnam = fromMaybe nullDatatypeMod $ getDTMod scopnam rdfDatatypeValXsdInteger testDatatypeSuite :: Test testDatatypeSuite = TestList [ testEq "testDatatype01" typeNameXsdInteger $ typeName rdfDatatypeXsdInteger , testEq "testDatatype02" namespaceXsdInteger $ rsNamespace xsdIntRules , testEqv "testDatatype03" axiomsXsdInteger $ rsAxioms xsdIntRules , testEqv "testDatatype04" rulesXsdInteger $ rsRules xsdIntRules , testEq "testDatatype05" axiomXsdIntegerDT $ formName (getXsdIntegerAxiom axiomXsdIntegerDT) , testEq "testDatatype06" ruleXsdIntegerAbs $ ruleName (getXsdIntegerRule ruleXsdIntegerAbs) ] ------------------------------------------------------------ -- Basic rdfDatatypeValXsdInteger tests ------------------------------------------------------------ testDatatypeValSuite :: Test testDatatypeValSuite = TestList [ testEq "testDatatypeVal01" (Just 123) $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "123" , testEq "testDatatypeVal02" (Just 0) $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "0" , testEq "testDatatypeVal03" (Just 456) $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "+000456" , testEq "testDatatypeVal04" (Just (-987)) $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "-0987" , testEq "testDatatypeVal05" Nothing $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "11x2" , testEq "testDatatypeVal06" Nothing $ mapL2V (tvalMap rdfDatatypeValXsdInteger) " 321" , testEq "testDatatypeVal07" Nothing $ mapL2V (tvalMap rdfDatatypeValXsdInteger) "321 " , testEq "testDatatypeVal11" (Just "123") $ mapV2L (tvalMap rdfDatatypeValXsdInteger) 123 , testEq "testDatatypeVal12" (Just "-987") $ mapV2L (tvalMap rdfDatatypeValXsdInteger) (-987) , testElem "testDatatypeVal21" dmodXsdIntegerAbs $ map dmName (tvalMod rdfDatatypeValXsdInteger) , testEq "testDatatypeVal22" dmodXsdIntegerAbs $ dmName (getXsdIntegerDTmod dmodXsdIntegerAbs) ] ------------------------------------------------------------ -- Variable binding modifier tests ------------------------------------------------------------ dmodXsdIntegerAbs, dmodXsdIntegerNeg, dmodXsdIntegerSum, dmodXsdIntegerDiff, dmodXsdIntegerProd, dmodXsdIntegerDivMod, dmodXsdIntegerPower, dmodXsdIntegerEq, dmodXsdIntegerNe, dmodXsdIntegerLt, dmodXsdIntegerLe, dmodXsdIntegerGt, dmodXsdIntegerGe :: ScopedName dmodXsdIntegerAbs = xsdIntName "abs" dmodXsdIntegerNeg = xsdIntName "neg" dmodXsdIntegerSum = xsdIntName "sum" dmodXsdIntegerDiff = xsdIntName "diff" dmodXsdIntegerProd = xsdIntName "prod" dmodXsdIntegerDivMod = xsdIntName "divmod" dmodXsdIntegerPower = xsdIntName "power" dmodXsdIntegerEq = xsdIntName "eq" dmodXsdIntegerNe = xsdIntName "ne" dmodXsdIntegerLt = xsdIntName "lt" dmodXsdIntegerLe = xsdIntName "le" dmodXsdIntegerGt = xsdIntName "gt" dmodXsdIntegerGe = xsdIntName "ge" testVmodN :: [RDFLabel] -> String -> Maybe (RDFDatatypeMod Integer) -> [RDFVarBinding] -> [RDFVarBinding] -> Test testVmodN vars lab (Just dmod) ibinds obinds = testEqv lab obinds $ applyRDFDatatypeMod rdfDatatypeValXsdInteger dmod vars ibinds testVmodN _ lab Nothing _ _ = TestCase $ assertFailure $ "testVmodN:"++lab++", null variable binding modifier" testVmod2, testVmod3, testVmod4 :: String -> Maybe (RDFDatatypeMod Integer) -> [RDFVarBinding] -> [RDFVarBinding] -> Test testVmod2 = testVmodN [Var "a", Var "b"] testVmod3 = testVmodN [Var "a", Var "b", Var "c"] testVmod4 = testVmodN [Var "a", Var "b", Var "c", Var "d"] -- make various kinds of RDF variable bindings rdfVR :: (String, ScopedName) -> (RDFLabel, RDFLabel) rdfVR (v,u) = (Var v,Res u) -- (Variable,Resource) rdfVB :: (String, String) -> (RDFLabel, RDFLabel) rdfVB (v,b) = (Var v,Blank b) -- (Variable,Blank) rdfVL :: (String, String) -> (RDFLabel, RDFLabel) rdfVL (v,l) = (Var v, Lit (T.pack l)) -- (Variable,Untyped literal) rdfVI :: (String, String) -> (RDFLabel, RDFLabel) rdfVI (v,l) = (Var v, TypedLit (T.pack l) typeNameXsdInteger) -- (Variable,Integer literal) makeBVR :: [(String,ScopedName)] -> RDFVarBinding makeBVR nls = makeVarBinding $ map rdfVR nls makeBVB :: [(String,String)] -> RDFVarBinding makeBVB nls = makeVarBinding $ map rdfVB nls makeBVI :: [(String,String)] -> RDFVarBinding makeBVI nls = makeVarBinding $ map rdfVI nls makeBVL :: [(String,String)] -> RDFVarBinding makeBVL nls = makeVarBinding $ map rdfVL nls -- Test null modifier testVarModify00 :: Test testVarModify00 = testVmod2 "testVarModify00" (Just nullDatatypeMod) [makeBVI [("a","123")]] [makeBVI [("a","123")]] -- Tests for xsd_integer:abs testVarModifyAbs01, testVarModifyAbs02, testVarModifyAbs03, testVarModifyAbs04, testVarModifyAbs05, testVarModifyAbs06, testVarModifyAbs07, testVarModifyAbs08, testVarModifyAbs09, testVarModifyAbs10 :: Test testVarModifyAbs01 = testVmod2 "testVarModifyAbs01" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("b","123")]] [makeBVI [("a","123"),("b","123")]] testVarModifyAbs02 = testVmod2 "testVarModifyAbs02" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("b","-123")]] [makeBVI [("a","123"),("b","-123")]] testVarModifyAbs03 = testVmod2 "testVarModifyAbs03" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("a","123"),("b","123")]] [makeBVI [("a","123"),("b","123")]] testVarModifyAbs04 = testVmod2 "testVarModifyAbs04" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("a","123"),("b","-123")]] [makeBVI [("a","123"),("b","-123")]] testVarModifyAbs05 = testVmod2 "testVarModifyAbs05" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("a","-123"),("b","123")]] [] testVarModifyAbs06 = testVmod2 "testVarModifyAbs06" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("a","123"),("b","456")]] [] testVarModifyAbs07 = testVmod2 "testVarModifyAbs07" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVI [("c","123")]] [] testVarModifyAbs08 = testVmod2 "testVarModifyAbs08" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVL [("b","123")]] [] testVarModifyAbs09 = testVmod2 "testVarModifyAbs09" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVR [("b",makeScopedName Nothing (toURI "http://ex.org/") "123")]] [] testVarModifyAbs10 = testVmod2 "testVarModifyAbs10" (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) [makeBVB [("b","123")]] [] -- Tests for xsd_integer:neg testVarModifyNeg01, testVarModifyNeg02, testVarModifyNeg03, testVarModifyNeg04, testVarModifyNeg05 :: Test testVarModifyNeg01 = testVmod2 "testVarModifyNeg01" (getDTMod dmodXsdIntegerNeg rdfDatatypeValXsdInteger) [makeBVI [("a","123"),("b","-123")]] [makeBVI [("a","123"),("b","-123")]] testVarModifyNeg02 = testVmod2 "testVarModifyNeg02" (getDTMod dmodXsdIntegerNeg rdfDatatypeValXsdInteger) [makeBVI [("a","-123"),("b","123")]] [makeBVI [("a","-123"),("b","123")]] testVarModifyNeg03 = testVmod2 "testVarModifyNeg03" (getDTMod dmodXsdIntegerNeg rdfDatatypeValXsdInteger) [makeBVI [("a","123"),("b","123")]] [] testVarModifyNeg04 = testVmod2 "testVarModifyNeg04" (getDTMod dmodXsdIntegerNeg rdfDatatypeValXsdInteger) [makeBVI [("b","123")]] [makeBVI [("a","-123"),("b","123")]] testVarModifyNeg05 = testVmod2 "testVarModifyNeg05" (getDTMod dmodXsdIntegerNeg rdfDatatypeValXsdInteger) [makeBVI [("a","-123")]] [makeBVI [("a","-123"),("b","123")]] -- Tests for xsd_integer:sum testVarModifySum01, testVarModifySum02, testVarModifySum03, testVarModifySum04, testVarModifySum05 :: Test testVarModifySum01 = testVmod3 "testVarModifySum01" (getDTMod dmodXsdIntegerSum rdfDatatypeValXsdInteger) [makeBVI [("a","33"),("b","22"),("c","11")]] [makeBVI [("a","33"),("b","22"),("c","11")]] testVarModifySum02 = testVmod3 "testVarModifySum02" (getDTMod dmodXsdIntegerSum rdfDatatypeValXsdInteger) [makeBVI [("b","22"),("c","11")]] [makeBVI [("a","33"),("b","22"),("c","11")]] testVarModifySum03 = testVmod3 "testVarModifySum03" (getDTMod dmodXsdIntegerSum rdfDatatypeValXsdInteger) [makeBVI [("a","33"),("c","11")]] [makeBVI [("a","33"),("b","22"),("c","11")]] testVarModifySum04 = testVmod3 "testVarModifySum04" (getDTMod dmodXsdIntegerSum rdfDatatypeValXsdInteger) [makeBVI [("a","33"),("b","22")]] [makeBVI [("a","33"),("b","22"),("c","11")]] testVarModifySum05 = testVmod3 "testVarModifySum05" (getDTMod dmodXsdIntegerSum rdfDatatypeValXsdInteger) [makeBVI [("a","44"),("b","22"),("c","11")]] [] -- Tests for xsd_integer:diff testVarModifyDiff01, testVarModifyDiff02, testVarModifyDiff03, testVarModifyDiff04, testVarModifyDiff05 :: Test testVarModifyDiff01 = testVmod3 "testVarModifyDiff01" (getDTMod dmodXsdIntegerDiff rdfDatatypeValXsdInteger) [makeBVI [("a","11"),("b","33"),("c","22")]] [makeBVI [("a","11"),("b","33"),("c","22")]] testVarModifyDiff02 = testVmod3 "testVarModifyDiff02" (getDTMod dmodXsdIntegerDiff rdfDatatypeValXsdInteger) [makeBVI [("b","33"),("c","22")]] [makeBVI [("a","11"),("b","33"),("c","22")]] testVarModifyDiff03 = testVmod3 "testVarModifyDiff03" (getDTMod dmodXsdIntegerDiff rdfDatatypeValXsdInteger) [makeBVI [("a","11"),("c","22")]] [makeBVI [("a","11"),("b","33"),("c","22")]] testVarModifyDiff04 = testVmod3 "testVarModifyDiff04" (getDTMod dmodXsdIntegerDiff rdfDatatypeValXsdInteger) [makeBVI [("a","11"),("b","33")]] [makeBVI [("a","11"),("b","33"),("c","22")]] testVarModifyDiff05 = testVmod3 "testVarModifyDiff05" (getDTMod dmodXsdIntegerDiff rdfDatatypeValXsdInteger) [makeBVI [("a","11"),("b","44"),("c","22")]] [] -- Tests for xsd_integer:prod -- -- Note: product can also be used to test if a value is -- an exact multiple of some other. testVarModifyProd01, testVarModifyProd02, testVarModifyProd03, testVarModifyProd04, testVarModifyProd05, testVarModifyProd06 :: Test testVarModifyProd01 = testVmod3 "testVarModifyProd01" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("a","6"),("b","2"),("c","3")]] [makeBVI [("a","6"),("b","2"),("c","3")]] testVarModifyProd02 = testVmod3 "testVarModifyProd02" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("b","2"),("c","3")]] [makeBVI [("a","6"),("b","2"),("c","3")]] testVarModifyProd03 = testVmod3 "testVarModifyProd03" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("a","6"),("c","3")]] [makeBVI [("a","6"),("b","2"),("c","3")]] testVarModifyProd04 = testVmod3 "testVarModifyProd04" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("a","6"),("c","3")]] [makeBVI [("a","6"),("b","2"),("c","3")]] testVarModifyProd05 = testVmod3 "testVarModifyProd05" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("a","7"),("b","2"),("c","3")]] [] testVarModifyProd06 = testVmod3 "testVarModifyProd06" (getDTMod dmodXsdIntegerProd rdfDatatypeValXsdInteger) [makeBVI [("a","7"),("b","2")]] [] -- Tests for xsd_integer:divmod -- -- Note: truncates downwards, so remainder is same sign as divisor -- cf. Haskell divMod function. testVarModifyDivMod01, testVarModifyDivMod02, testVarModifyDivMod03, testVarModifyDivMod04, testVarModifyDivMod05, testVarModifyDivMod06, testVarModifyDivMod07 :: Test testVarModifyDivMod01 = testVmod4 "testVarModifyDivMod01" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("a","2"),("b","1"),("c","7"),("d","3")]] [makeBVI [("a","2"),("b","1"),("c","7"),("d","3")]] testVarModifyDivMod02 = testVmod4 "testVarModifyDivMod02" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("c","7"),("d","3")]] [makeBVI [("a","2"),("b","1"),("c","7"),("d","3")]] testVarModifyDivMod03 = testVmod4 "testVarModifyDivMod03" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("c","-7"),("d","3")]] [makeBVI [("a","-3"),("b","2"),("c","-7"),("d","3")]] testVarModifyDivMod04 = testVmod4 "testVarModifyDivMod04" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("c","7"),("d","-3")]] [makeBVI [("a","-3"),("b","-2"),("c","7"),("d","-3")]] testVarModifyDivMod05 = testVmod4 "testVarModifyDivMod05" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("c","-7"),("d","-3")]] [makeBVI [("a","2"),("b","-1"),("c","-7"),("d","-3")]] testVarModifyDivMod06 = testVmod4 "testVarModifyDivMod06" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("a","2"),("b","5"),("c","7"),("d","3")]] [] testVarModifyDivMod07 = testVmod4 "testVarModifyDivMod07" (getDTMod dmodXsdIntegerDivMod rdfDatatypeValXsdInteger) [makeBVI [("a","2"),("b","1"),("d","3")]] [] -- Tests for xsd_integer:power testVarModifyPower01, testVarModifyPower02, testVarModifyPower03, testVarModifyPower04, testVarModifyPower05, testVarModifyPower06, testVarModifyPower07, testVarModifyPower08 :: Test testVarModifyPower01 = testVmod3 "testVarModifyPower01" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("a","8"),("b","2"),("c","3")]] [makeBVI [("a","8"),("b","2"),("c","3")]] testVarModifyPower02 = testVmod3 "testVarModifyPower02" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("b","2"),("c","3")]] [makeBVI [("a","8"),("b","2"),("c","3")]] testVarModifyPower03 = testVmod3 "testVarModifyPower03" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("a","8"),("c","3")]] [] testVarModifyPower04 = testVmod3 "testVarModifyPower04" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("a","8"),("b","2")]] [] testVarModifyPower05 = testVmod3 "testVarModifyPower05" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("a","8"),("b","3"),("c","2")]] [] testVarModifyPower06 = testVmod3 "testVarModifyPower06" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("b","55"),("c","0")]] [makeBVI [("a","1"),("b","55"),("c","0")]] testVarModifyPower07 = testVmod3 "testVarModifyPower07" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("b","-2"),("c","3")]] [makeBVI [("a","-8"),("b","-2"),("c","3")]] testVarModifyPower08 = testVmod3 "testVarModifyPower08" (getDTMod dmodXsdIntegerPower rdfDatatypeValXsdInteger) [makeBVI [("b","55"),("c","-2")]] [] -- Tests for xsd_integer:eq testVarModifyEq01, testVarModifyEq02, testVarModifyEq03, testVarModifyEq04, testVarModifyEq05 :: Test testVarModifyEq01 = testVmod2 "testVarModifyEq01" (getDTMod dmodXsdIntegerEq rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [makeBVI [("a","100"),("b","100")]] testVarModifyEq02 = testVmod2 "testVarModifyEq02" (getDTMod dmodXsdIntegerEq rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [] testVarModifyEq03 = testVmod2 "testVarModifyEq03" (getDTMod dmodXsdIntegerEq rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [] testVarModifyEq04 = testVmod2 "testVarModifyEq04" (getDTMod dmodXsdIntegerEq rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyEq05 = testVmod2 "testVarModifyEq05" (getDTMod dmodXsdIntegerEq rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Tests for xsd_integer:ne testVarModifyNe01, testVarModifyNe02, testVarModifyNe03, testVarModifyNe04, testVarModifyNe05 :: Test testVarModifyNe01 = testVmod2 "testVarModifyNe01" (getDTMod dmodXsdIntegerNe rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [] testVarModifyNe02 = testVmod2 "testVarModifyNe02" (getDTMod dmodXsdIntegerNe rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [makeBVI [("a","99"),("b","100")]] testVarModifyNe03 = testVmod2 "testVarModifyNe03" (getDTMod dmodXsdIntegerNe rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [makeBVI [("a","-99"),("b","-100")]] testVarModifyNe04 = testVmod2 "testVarModifyNe04" (getDTMod dmodXsdIntegerNe rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyNe05 = testVmod2 "testVarModifyNe05" (getDTMod dmodXsdIntegerNe rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Tests for xsd_integer:lt testVarModifyLt01, testVarModifyLt02, testVarModifyLt03, testVarModifyLt04, testVarModifyLt05 :: Test testVarModifyLt01 = testVmod2 "testVarModifyLt01" (getDTMod dmodXsdIntegerLt rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [] testVarModifyLt02 = testVmod2 "testVarModifyLt02" (getDTMod dmodXsdIntegerLt rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [makeBVI [("a","99"),("b","100")]] testVarModifyLt03 = testVmod2 "testVarModifyLt03" (getDTMod dmodXsdIntegerLt rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [] testVarModifyLt04 = testVmod2 "testVarModifyLt04" (getDTMod dmodXsdIntegerLt rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyLt05 = testVmod2 "testVarModifyLt05" (getDTMod dmodXsdIntegerLt rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Tests for xsd_integer:le testVarModifyLe01, testVarModifyLe02, testVarModifyLe03, testVarModifyLe04, testVarModifyLe05 :: Test testVarModifyLe01 = testVmod2 "testVarModifyLe01" (getDTMod dmodXsdIntegerLe rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [makeBVI [("a","100"),("b","100")]] testVarModifyLe02 = testVmod2 "testVarModifyLe02" (getDTMod dmodXsdIntegerLe rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [makeBVI [("a","99"),("b","100")]] testVarModifyLe03 = testVmod2 "testVarModifyLe03" (getDTMod dmodXsdIntegerLe rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [] testVarModifyLe04 = testVmod2 "testVarModifyLe04" (getDTMod dmodXsdIntegerLe rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyLe05 = testVmod2 "testVarModifyLe05" (getDTMod dmodXsdIntegerLe rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Tests for xsd_integer:gt testVarModifyGt01, testVarModifyGt02, testVarModifyGt03, testVarModifyGt04, testVarModifyGt05 :: Test testVarModifyGt01 = testVmod2 "testVarModifyGt01" (getDTMod dmodXsdIntegerGt rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [] testVarModifyGt02 = testVmod2 "testVarModifyGt02" (getDTMod dmodXsdIntegerGt rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [] testVarModifyGt03 = testVmod2 "testVarModifyGt03" (getDTMod dmodXsdIntegerGt rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [makeBVI [("a","-99"),("b","-100")]] testVarModifyGt04 = testVmod2 "testVarModifyGt04" (getDTMod dmodXsdIntegerGt rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyGt05 = testVmod2 "testVarModifyGt05" (getDTMod dmodXsdIntegerGt rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Tests for xsd_integer:ge testVarModifyGe01, testVarModifyGe02, testVarModifyGe03, testVarModifyGe04, testVarModifyGe05 :: Test testVarModifyGe01 = testVmod2 "testVarModifyGe01" (getDTMod dmodXsdIntegerGe rdfDatatypeValXsdInteger) [makeBVI [("a","100"),("b","100")]] [makeBVI [("a","100"),("b","100")]] testVarModifyGe02 = testVmod2 "testVarModifyGe02" (getDTMod dmodXsdIntegerGe rdfDatatypeValXsdInteger) [makeBVI [("a","99"),("b","100")]] [] testVarModifyGe03 = testVmod2 "testVarModifyGe03" (getDTMod dmodXsdIntegerGe rdfDatatypeValXsdInteger) [makeBVI [("a","-99"),("b","-100")]] [makeBVI [("a","-99"),("b","-100")]] testVarModifyGe04 = testVmod2 "testVarModifyGe04" (getDTMod dmodXsdIntegerGe rdfDatatypeValXsdInteger) [makeBVI [("b","100")]] [] testVarModifyGe05 = testVmod2 "testVarModifyGe05" (getDTMod dmodXsdIntegerGe rdfDatatypeValXsdInteger) [makeBVI [("a","100")]] [] -- Full suite for variable binding modifier tests testVarModifySuite :: Test testVarModifySuite = TestList [ testVarModify00 , testVarModifyAbs01, testVarModifyAbs02, testVarModifyAbs03 , testVarModifyAbs04, testVarModifyAbs05, testVarModifyAbs06 , testVarModifyAbs07, testVarModifyAbs08, testVarModifyAbs09 , testVarModifyAbs10 , testVarModifyNeg01, testVarModifyNeg02, testVarModifyNeg03 , testVarModifyNeg04, testVarModifyNeg05 , testVarModifySum01, testVarModifySum02, testVarModifySum03 , testVarModifySum04, testVarModifySum05 , testVarModifyDiff01, testVarModifyDiff02, testVarModifyDiff03 , testVarModifyDiff04, testVarModifyDiff05 , testVarModifyProd01, testVarModifyProd02, testVarModifyProd03 , testVarModifyProd04, testVarModifyProd05, testVarModifyProd06 , testVarModifyDivMod01, testVarModifyDivMod02, testVarModifyDivMod03 , testVarModifyDivMod04, testVarModifyDivMod05, testVarModifyDivMod06 , testVarModifyDivMod07 , testVarModifyPower01, testVarModifyPower02, testVarModifyPower03 , testVarModifyPower04, testVarModifyPower05, testVarModifyPower06 , testVarModifyPower07, testVarModifyPower08 , testVarModifyEq01, testVarModifyEq02, testVarModifyEq03 , testVarModifyEq04, testVarModifyEq05 , testVarModifyNe01, testVarModifyNe02, testVarModifyNe03 , testVarModifyNe04, testVarModifyNe05 , testVarModifyLt01, testVarModifyLt02, testVarModifyLt03 , testVarModifyLt04, testVarModifyLt05 , testVarModifyLe01, testVarModifyLe02, testVarModifyLe03 , testVarModifyLe04, testVarModifyLe05 , testVarModifyGt01, testVarModifyGt02, testVarModifyGt03 , testVarModifyGt04, testVarModifyGt05 , testVarModifyGe01, testVarModifyGe02, testVarModifyGe03 , testVarModifyGe04, testVarModifyGe05 ] ------------------------------------------------------------ -- 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 (prefixes `mappend` (base `mappend` gr)) testRuleFwd :: String -> Maybe (Rule RDFGraph) -> B.Builder -> [B.Builder] -> Test testRuleFwd lab (Just rule) antstr constrs = let antgr = mkGraph antstr congrs = map mkGraph constrs in testEqv lab congrs $ fwdApply rule [antgr] testRuleFwd lab Nothing _ _ = TestCase $ assertFailure $ "testRuleFwd:"++lab++", null rule supplied" testRuleBwd :: String -> Maybe (Rule RDFGraph) -> B.Builder -> [[B.Builder]] -> Test testRuleBwd lab (Just rule) antstr prestrss = let antgr = mkGraph antstr pregrss = map (map mkGraph) prestrss in testEqv2 lab pregrss $ bwdApply rule antgr testRuleBwd lab Nothing _ _ = TestCase $ assertFailure $ "testRuleBwd:"++lab++", null rule supplied" {- testRuleChk :: String -> Maybe (Rule RDFGraph) -> String -> String -> Test testRuleChk lab (Just rule) antstr constr = let antgr = mkGraph antstr congr = mkGraph constr in test lab $ checkInference rule [antgr] congr testRuleChk lab Nothing _ _ = TestCase $ assertFailure $ "testRuleChk:"++lab++", null rule supplied" -} xsdIntRules :: Ruleset RDFGraph xsdIntRules = typeRules rdfDatatypeXsdInteger {- axdt :: Maybe (Formula RDFGraph) axdt = getRulesetAxiom axiomXsdIntegerDT xsdIntRules -} ruleabs, ruleneg, rulesum, rulediff, ruleprod, ruledivmod, rulepower, ruleeq, rulene, rulelt, rulele, rulegt, rulege :: Maybe (Rule RDFGraph) ruleabs = getRulesetRule ruleXsdIntegerAbs xsdIntRules ruleneg = getRulesetRule ruleXsdIntegerNeg xsdIntRules rulesum = getRulesetRule ruleXsdIntegerSum xsdIntRules rulediff = getRulesetRule ruleXsdIntegerDiff xsdIntRules ruleprod = getRulesetRule ruleXsdIntegerProd xsdIntRules ruledivmod = getRulesetRule ruleXsdIntegerDivMod xsdIntRules rulepower = getRulesetRule ruleXsdIntegerPower xsdIntRules ruleeq = getRulesetRule ruleXsdIntegerEq xsdIntRules rulene = getRulesetRule ruleXsdIntegerNe xsdIntRules rulelt = getRulesetRule ruleXsdIntegerLt xsdIntRules rulele = getRulesetRule ruleXsdIntegerLe xsdIntRules rulegt = getRulesetRule ruleXsdIntegerGt xsdIntRules rulege = getRulesetRule ruleXsdIntegerGe xsdIntRules -- Test cases for the arithmetic functions -- don't want to use text-format at present qconv :: (Show a) => a -> B.Builder qconv = B.fromString . show -- abs -- assume that vals is not empty multiInp :: B.Builder -> [(Int, Int)] -> B.Builder multiInp lbl vals = let iConv (lval, val) = mconcat [ " rdf:_", qconv lval, " \"", qconv val, "\"^^xsd:integer " ] in mconcat $ [ "_:a a xsd_integer:" , lbl , " ;" ] ++ intersperse ";" (map iConv vals) ++ ["."] singleInp :: B.Builder -> Int -> Int -> B.Builder singleInp lbl lval val = multiInp lbl [(lval, val)] abs01inp, abs02inp, abs03inp, abs04inp :: B.Builder abs01inp = singleInp "Abs" 2 1 abs02inp = singleInp "Abs" 2 (-1) abs03inp = singleInp "Abs" 1 1 abs04inp = singleInp "Abs" 1 (-1) abs03bwd :: [[B.Builder]] abs03bwd = [ [ "_:a a xsd_integer:Abs . " , "_:a rdf:_2 \"1\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Abs . " , "_:a rdf:_2 \"-1\"^^xsd:integer . " ] ] -- neg neg01inp, neg02inp :: B.Builder neg01inp = singleInp "Neg" 2 1 neg02inp = singleInp "Neg" 2 (-2) -- sum sum01inp :: B.Builder sum01inp = multiInp "Sum" [(2, 31), (3, 20)] sum01bwd :: [[B.Builder]] sum01bwd = [ [ "_:a a xsd_integer:Sum . " , "_:a rdf:_1 \"51\"^^xsd:integer . " , "_:a rdf:_2 \"31\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Sum . " , "_:a rdf:_1 \"51\"^^xsd:integer . " , "_:a rdf:_3 \"20\"^^xsd:integer . " ] ] sum02inp :: B.Builder sum02inp = multiInp "Sum" [(1, 52), (3, 21)] sum02bwd :: [[B.Builder]] sum02bwd = [ [ "_:a a xsd_integer:Sum . " , "_:a rdf:_1 \"52\"^^xsd:integer . " , "_:a rdf:_2 \"31\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Sum . " , "_:a rdf:_2 \"31\"^^xsd:integer . " , "_:a rdf:_3 \"21\"^^xsd:integer . " ] ] sum03inp :: B.Builder sum03inp = multiInp "Sum" [(1, 53), (2, 32)] sum03bwd :: [[B.Builder]] sum03bwd = [ [ "_:a a xsd_integer:Sum . " , "_:a rdf:_1 \"53\"^^xsd:integer . " , "_:a rdf:_3 \"21\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Sum . " , "_:a rdf:_2 \"32\"^^xsd:integer . " , "_:a rdf:_3 \"21\"^^xsd:integer . " ] ] -- diff diff01inp, diff02inp, diff03inp :: B.Builder diff01inp = multiInp "Diff" [(2, 222), (3, 333)] diff02inp = multiInp "Diff" [(1, -111), (3, 333)] diff03inp = multiInp "Diff" [(1, -111), (2, 222)] diff01bwd :: [[B.Builder]] diff01bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_3 \"333\"^^xsd:integer . " ] ] diff02bwd :: [[B.Builder]] diff02bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Diff . " , "_:a rdf:_2 \"222\"^^xsd:integer . " , "_:a rdf:_3 \"333\"^^xsd:integer . " ] ] diff03bwd :: [[B.Builder]] diff03bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_3 \"333\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Diff . " , "_:a rdf:_2 \"222\"^^xsd:integer . " , "_:a rdf:_3 \"333\"^^xsd:integer . " ] ] -- prod prod01inp, prod02inp, prod03inp :: B.Builder prod01inp = multiInp "Prod" [(2, 222), (3, 3)] prod02inp = multiInp "Prod" [(1, 666), (3, 3)] prod03inp = multiInp "Prod" [(1, 666), (2, 222)] prod01bwd :: [[B.Builder]] prod01bwd = [ [ "_:a a xsd_integer:Prod . " , "_:a rdf:_1 \"666\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Prod . " , "_:a rdf:_1 \"666\"^^xsd:integer . " , "_:a rdf:_3 \"3\"^^xsd:integer . " ] ] prod02bwd :: [[B.Builder]] prod02bwd = [ [ "_:a a xsd_integer:Prod . " , "_:a rdf:_1 \"666\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Prod . " , "_:a rdf:_2 \"222\"^^xsd:integer . " , "_:a rdf:_3 \"3\"^^xsd:integer . " ] ] prod03bwd :: [[B.Builder]] prod03bwd = [ [ "_:a a xsd_integer:Prod . " , "_:a rdf:_1 \"666\"^^xsd:integer . " , "_:a rdf:_3 \"3\"^^xsd:integer . " ] , [ "_:a a xsd_integer:Prod . " , "_:a rdf:_2 \"222\"^^xsd:integer . " , "_:a rdf:_3 \"3\"^^xsd:integer . " ] ] -- divmod divmod01inp, divmod02inp, divmod03inp :: B.Builder divmod01inp = multiInp "DivMod" [(3, 33), (4, 5)] divmod02inp = multiInp "DivMod" [(1, 6), (2, 3), (4, 5)] divmod03inp = multiInp "DivMod" [(3, -33), (4, 5)] -- power power01inp, power02inp, power03inp :: B.Builder power01inp = multiInp "Power" [(2, 2), (3, 5)] power02inp = multiInp "Power" [(2, 111), (3, 0)] power03inp = multiInp "Power" [(2, 22), (3, -33)] -- eq eq01inp, eq02inp, eq03inp :: B.Builder eq01inp = multiInp "Eq" [(1, 11), (2, 11)] eq02inp = multiInp "Eq" [(1, 21), (2, 22)] eq03inp = multiInp "Eq" [(1, 31), (2, -32)] -- ne ne01inp, ne02inp, ne03inp :: B.Builder ne01inp = multiInp "Ne" [(1, 11), (2, 11)] ne02inp = multiInp "Ne" [(1, 21), (2, 22)] ne03inp = multiInp "Ne" [(1, 31), (2, -32)] -- lt lt01inp, lt02inp, lt03inp :: B.Builder lt01inp = multiInp "Lt" [(1, 11), (2, 11)] lt02inp = multiInp "Lt" [(1, 21), (2, 22)] lt03inp = multiInp "Lt" [(1, 31), (2, -32)] -- le le01inp, le02inp, le03inp :: B.Builder le01inp = multiInp "Le" [(1, 11), (2, 11)] le02inp = multiInp "Le" [(1, 21), (2, 22)] le03inp = multiInp "Le" [(1, 31), (2, -32)] -- gt gt01inp, gt02inp, gt03inp :: B.Builder gt01inp = multiInp "Gt" [(1, 11), (2, 11)] gt02inp = multiInp "Gt" [(1, 21), (2, 22)] gt03inp = multiInp "Gt" [(1, 31), (2, -32)] -- ge ge01inp, ge02inp, ge03inp :: B.Builder ge01inp = multiInp "Ge" [(1, 11), (2, 11)] ge02inp = multiInp "Ge" [(1, 21), (2, 22)] ge03inp = multiInp "Ge" [(1, 31), (2, -32)] -- Test cases from design notes -- Make a vector of rules using the graph string below pvRules :: [RDFRule] -- pvRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr pvRules = typeMkRules rdfDatatypeXsdInteger gr where gr = mkGraph $ mconcat [ ":PassengerVehicle a rdfd:GeneralRestriction ; " , " rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; " , " rdfd:constraint xsd_integer:sum . " , ":PassengerVehicle1 a rdfd:GeneralRestriction ; " , " rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; " , " rdfd:constraint xsd_integer:sum ; " , " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " ] -- Now the test cases that use the rules created above. pvRule0, pvRule1 :: Maybe (Rule RDFGraph) pvRule0 = M.lookup (makeNSScopedName namespaceDefault "PassengerVehicle") $ M.fromList $ map (\rl -> (ruleName rl, rl)) pvRules pvRule1 = M.lookup (makeNSScopedName namespaceDefault "PassengerVehicle1") $ M.fromList $ map (\rl -> (ruleName rl, rl)) pvRules pv01inp :: B.Builder pv01inp = mconcat [ "_:a a :PassengerVehicle ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :standingCapacity \"20\"^^xsd:integer . " ] pv01fwd :: [B.Builder] pv01fwd = [ "_:a :totalCapacity \"50\"^^xsd:integer . " ] pv01bwd :: [[B.Builder]] pv01bwd = [ [ "_:a a :PassengerVehicle . " , "_:a :totalCapacity \"50\"^^xsd:integer . " , "_:a :seatedCapacity \"30\"^^xsd:integer . " ] , [ "_:a a :PassengerVehicle . " , "_:a :totalCapacity \"50\"^^xsd:integer . " , "_:a :standingCapacity \"20\"^^xsd:integer . " ] ] pv02inp :: B.Builder pv02inp = mconcat [ "_:a a :PassengerVehicle ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :totalCapacity \"51\"^^xsd:integer . " , "_:b a :PassengerVehicle ; " , " :standingCapacity \"20\"^^xsd:integer ; " , " :totalCapacity \"52\"^^xsd:integer . " ] pv02fwd :: [B.Builder] pv02fwd = [ "_:a :standingCapacity \"21\"^^xsd:integer . " , "_:b :seatedCapacity \"32\"^^xsd:integer . " ] pv02bwd :: [[B.Builder]] pv02bwd = [ [ "_:a a :PassengerVehicle . " , "_:a :standingCapacity \"21\"^^xsd:integer . " , "_:a :totalCapacity \"51\"^^xsd:integer . " , "_:b a :PassengerVehicle . " , "_:b :seatedCapacity \"32\"^^xsd:integer . " , "_:b :totalCapacity \"52\"^^xsd:integer . " ] , [ "_:a a :PassengerVehicle . " , "_:a :seatedCapacity \"30\"^^xsd:integer . " , "_:a :standingCapacity \"21\"^^xsd:integer . " , "_:b a :PassengerVehicle . " , "_:b :seatedCapacity \"32\"^^xsd:integer . " , "_:b :totalCapacity \"52\"^^xsd:integer . " ] , [ "_:a a :PassengerVehicle . " , "_:a :standingCapacity \"21\"^^xsd:integer . " , "_:a :totalCapacity \"51\"^^xsd:integer . " , "_:b a :PassengerVehicle . " , "_:b :seatedCapacity \"32\"^^xsd:integer . " , "_:b :standingCapacity \"20\"^^xsd:integer . " ] , [ "_:a a :PassengerVehicle . " , "_:a :seatedCapacity \"30\"^^xsd:integer . " , "_:a :standingCapacity \"21\"^^xsd:integer . " , "_:b a :PassengerVehicle . " , "_:b :seatedCapacity \"32\"^^xsd:integer . " , "_:b :standingCapacity \"20\"^^xsd:integer . " ] ] pv03inp :: B.Builder pv03inp = mconcat [ "_:a a :PassengerVehicle ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :standingCapacity \"23\"^^xsd:integer ; " , " :totalCapacity \"53\"^^xsd:integer . " ] pv03fwd :: [B.Builder] pv03fwd = [] pv04inp :: B.Builder pv04inp = mconcat [ "_:a a :PassengerVehicle ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :standingCapacity \"20\"^^xsd:integer ; " , " :totalCapacity \"54\"^^xsd:integer . " ] pv04fwd :: [B.Builder] pv04fwd = [ mconcat [ "_:a :standingCapacity \"24\"^^xsd:integer . " , "_:a :seatedCapacity \"34\"^^xsd:integer . " , "_:a :totalCapacity \"50\"^^xsd:integer . " ] ] pv05inp :: B.Builder pv05inp = mconcat [ "_:a a :PassengerVehicle1 ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :standingCapacity \"25\"^^xsd:integer ; " , " :totalCapacity \"55\"^^xsd:integer . " ] pv05fwd :: [B.Builder] pv05fwd = [] pv06inp :: B.Builder pv06inp = mconcat [ "_:a a :PassengerVehicle1 ; " , " :seatedCapacity \"30\"^^xsd:integer ; " , " :standingCapacity \"20\"^^xsd:integer ; " , " :totalCapacity \"56\"^^xsd:integer . " ] pv06fwd :: [B.Builder] pv06fwd = [ falseGraphStr ] pv06bwd :: [[B.Builder]] pv06bwd = [ [ falseGraphStr ] ] pv07inp :: B.Builder pv07inp = "_:a a :PassengerVehicle ; " `mappend` " :totalCapacity \"57\"^^xsd:integer . " pv07fwd :: [B.Builder] pv07fwd = [] -- how come this isn't [[String]] ? pv07bwd :: [B.Builder] pv07bwd = [] -- Full suite for datatype rule tests testDatatypeRuleSuite :: Test testDatatypeRuleSuite = TestList [ testRuleFwd "testRuleFwdAbs01" ruleabs abs01inp [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdAbs02" ruleabs abs02inp [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdAbs03" ruleabs abs03inp [] , testRuleFwd "testRuleFwdAbs04" ruleabs abs04inp [falseGraphStr] , testRuleFwd "testRuleFwdNeg01" ruleneg neg01inp [ "_:a rdf:_1 \"-1\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdNeg02" ruleneg neg02inp [ "_:a rdf:_1 \"2\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdSum01" rulesum sum01inp [ "_:a rdf:_1 \"51\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdSum02" rulesum sum02inp [ "_:a rdf:_2 \"31\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdSum03" rulesum sum03inp [ "_:a rdf:_3 \"21\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdDiff01" rulediff diff01inp [ "_:a rdf:_1 \"-111\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdDiff02" rulediff diff02inp [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdDiff03" rulediff diff03inp [ "_:a rdf:_3 \"333\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdProd01" ruleprod prod01inp [ "_:a rdf:_1 \"666\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdProd02" ruleprod prod02inp [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdProd03" ruleprod prod03inp [ "_:a rdf:_3 \"3\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdDivMod01" ruledivmod divmod01inp [ "_:a rdf:_1 \"6\"^^xsd:integer . " `mappend` "_:a rdf:_2 \"3\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdDivMod02" ruledivmod divmod02inp [] , testRuleFwd "testRuleFwdDivMod03" ruledivmod divmod03inp [ "_:a rdf:_1 \"-7\"^^xsd:integer . " `mappend` "_:a rdf:_2 \"2\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdPower01" rulepower power01inp [ "_:a rdf:_1 \"32\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdPower02" rulepower power02inp [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] , testRuleFwd "testRuleFwdPower03" rulepower power03inp [falseGraphStr] , testRuleFwd "testRuleFwdEq01" ruleeq eq01inp [] , testRuleFwd "testRuleFwdEq02" ruleeq eq02inp [falseGraphStr] , testRuleFwd "testRuleFwdEq03" ruleeq eq03inp [falseGraphStr] , testRuleFwd "testRuleFwdNe01" rulene ne01inp [falseGraphStr] , testRuleFwd "testRuleFwdNe02" rulene ne02inp [] , testRuleFwd "testRuleFwdNe03" rulene ne03inp [] , testRuleFwd "testRuleFwdLt01" rulelt lt01inp [falseGraphStr] , testRuleFwd "testRuleFwdLt02" rulelt lt02inp [] , testRuleFwd "testRuleFwdLt03" rulelt lt03inp [falseGraphStr] , testRuleFwd "testRuleFwdLe01" rulele le01inp [] , testRuleFwd "testRuleFwdLe02" rulele le02inp [] , testRuleFwd "testRuleFwdLe03" rulele le03inp [falseGraphStr] , testRuleFwd "testRuleFwdGt01" rulegt gt01inp [falseGraphStr] , testRuleFwd "testRuleFwdGt02" rulegt gt02inp [falseGraphStr] , testRuleFwd "testRuleFwdGt03" rulegt gt03inp [] , testRuleFwd "testRuleFwdGe01" rulege ge01inp [] , testRuleFwd "testRuleFwdGe02" rulege ge02inp [falseGraphStr] , testRuleFwd "testRuleFwdGe03" rulege ge03inp [] -- backard chaining tests , testRuleBwd "testRuleBwdAbs01" ruleabs abs01inp [] , testRuleBwd "testRuleBwdAbs02" ruleabs abs02inp [] , testRuleBwd "testRuleBwdAbs03" ruleabs abs03inp abs03bwd , testRuleBwd "testRuleBwdAbs04" ruleabs abs04inp [[falseGraphStr]] , testRuleBwd "testRuleBwdNeg01" ruleneg neg01inp [[ "_:a a xsd_integer:Neg . ", "_:a rdf:_1 \"-1\"^^xsd:integer . "]] , testRuleBwd "testRuleBwdNeg02" ruleneg neg02inp [[ "_:a a xsd_integer:Neg . ", "_:a rdf:_1 \"2\"^^xsd:integer . "]] , testRuleBwd "testRuleBwdSum01" rulesum sum01inp sum01bwd , testRuleBwd "testRuleBwdSum02" rulesum sum02inp sum02bwd , testRuleBwd "testRuleBwdSum03" rulesum sum03inp sum03bwd , testRuleBwd "testRuleBwdDiff01" rulediff diff01inp diff01bwd , testRuleBwd "testRuleBwdDiff02" rulediff diff02inp diff02bwd , testRuleBwd "testRuleBwdDiff03" rulediff diff03inp diff03bwd , testRuleBwd "testRuleBwdProd01" ruleprod prod01inp prod01bwd , testRuleBwd "testRuleBwdProd02" ruleprod prod02inp prod02bwd , testRuleBwd "testRuleBwdProd03" ruleprod prod03inp prod03bwd , testRuleBwd "testRuleBwdDivMod01" ruledivmod divmod01inp [] , testRuleBwd "testRuleBwdDivMod02" ruledivmod divmod02inp [] , testRuleBwd "testRuleBwdDivMod03" ruledivmod divmod03inp [] , testRuleBwd "testRuleBwdPower01" rulepower power01inp [] , testRuleBwd "testRuleBwdPower02" rulepower power02inp [] , testRuleBwd "testRuleBwdPower03" rulepower power03inp [[falseGraphStr]] , testRuleBwd "testRuleBwdEq01" ruleeq eq01inp [] , testRuleBwd "testRuleBwdEq02" ruleeq eq02inp [[falseGraphStr]] , testRuleBwd "testRuleBwdEq03" ruleeq eq03inp [[falseGraphStr]] , testRuleBwd "testRuleBwdNe01" rulene ne01inp [[falseGraphStr]] , testRuleBwd "testRuleBwdNe02" rulene ne02inp [] , testRuleBwd "testRuleBwdNe03" rulene ne03inp [] , testRuleBwd "testRuleBwdLt01" rulelt lt01inp [[falseGraphStr]] , testRuleBwd "testRuleBwdLt02" rulelt lt02inp [] , testRuleBwd "testRuleBwdLt03" rulelt lt03inp [[falseGraphStr]] , testRuleBwd "testRuleBwdLe01" rulele le01inp [] , testRuleBwd "testRuleBwdLe02" rulele le02inp [] , testRuleBwd "testRuleBwdLe03" rulele le03inp [[falseGraphStr]] , testRuleBwd "testRuleBwdGt01" rulegt gt01inp [[falseGraphStr]] , testRuleBwd "testRuleBwdGt02" rulegt gt02inp [[falseGraphStr]] , testRuleBwd "testRuleBwdGt03" rulegt gt03inp [] , testRuleBwd "testRuleBwdGe01" rulege ge01inp [] , testRuleBwd "testRuleBwdGe02" rulege ge02inp [[falseGraphStr]] , testRuleBwd "testRuleBwdGe03" rulege ge03inp [] -- test cases from design notes , testRuleFwd "testRuleFwdPv01" pvRule0 pv01inp pv01fwd , testRuleFwd "testRuleFwdPv02" pvRule0 pv02inp pv02fwd , testRuleFwd "testRuleFwdPv03" pvRule0 pv03inp pv03fwd , testRuleFwd "testRuleFwdPv04" pvRule0 pv04inp pv04fwd , testRuleFwd "testRuleFwdPv05" pvRule1 pv05inp pv05fwd , testRuleFwd "testRuleFwdPv06" pvRule1 pv06inp pv06fwd , testRuleFwd "testRuleFwdPv07" pvRule0 pv07inp pv07fwd , testRuleBwd "testRuleBwdPv01" pvRule0 pv01inp pv01bwd , testRuleBwd "testRuleBwdPv02" pvRule0 pv02inp pv02bwd , testRuleBwd "testRuleBwdPv06" pvRule1 pv06inp pv06bwd , testRuleFwd "testRuleBwdPv07" pvRule0 pv07inp pv07bwd ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "Datatype" testDatatypeSuite , conv "DatatypeVal" testDatatypeValSuite , conv "VarModify" testVarModifySuite , conv "DatatypeRule" testDatatypeRuleSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/N3FormatterTest.hs0000644000000000000000000013156713543702315015777 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : N3FormatterTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This Module defines test cases for module Parse parsing functions. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF import Swish.GraphClass (Arc, arc) import Swish.Namespace (Namespace, makeNamespace, getNamespaceTuple, makeNSScopedName, namespaceToBuilder) import Swish.QName (LName) import Swish.RDF.Formatter.N3 (formatGraphAsLazyText, formatGraphDiag) import Swish.RDF.Parser.N3 (parseN3) import Swish.RDF.Graph ( RDFGraph, RDFTriple , RDFLabel(..), ToRDFLabel , NSGraph(..) , NamespaceMap , emptyRDFGraph, toRDFGraph, toRDFTriple , resRdfType, resRdfFirst, resRdfRest, resRdfNil , resOwlSameAs ) import Swish.RDF.Vocabulary (toLangTag, namespaceRDF, namespaceXSD) import Network.URI (URI, parseURI) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Maybe (fromJust) import Data.String (IsString(..)) import Test.HUnit ( Test(TestCase,TestList) , assertEqual ) import TestHelpers (conv, testCompareEq) -- Specialized equality comparisons testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test testLabelEq = testCompareEq "testLabelEq:" testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test testGraphEq = testCompareEq "testGraphEq:" ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ toURI :: String -> URI toURI = fromJust . parseURI toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . toURI toRes :: Namespace -> LName -> RDFLabel toRes ns = Res . makeNSScopedName ns base1, base2, base3, base4, basef, baseu, basem :: Namespace base1 = toNS "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node#" base2 = toNS "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" base3 = toNS "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" base4 = toNS "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" basef = toNS "fbase" "file:///home/swish/photos/" baseu = toNS "ubase" "urn:one:two:3.14" basem = toNS "me" "http://example.com/ns#" s1, s2, s3, sf, su :: RDFLabel s1 = toRes base1 "s1" s2 = toRes base2 "s2" s3 = toRes base3 "s3" sf = toRes basef "me.png" su = toRes baseu "" meDepicts, meMe, meHasURN :: RDFLabel meDepicts = toRes basem "depicts" meMe = toRes basem "me" meHasURN = toRes basem "hasURN" b1, b2, b3, b4, b5, b6, b7, b8 :: RDFLabel b1 = Blank "b1" b2 = Blank "b2" b3 = Blank "b3" b4 = Blank "b4" b5 = Blank "b5" b6 = Blank "b6" b7 = Blank "b7" b8 = Blank "b8" c1, c2, c3, c4, c5, c6 :: RDFLabel c1 = Blank "c1" c2 = Blank "c2" c3 = Blank "c3" c4 = Blank "c4" c5 = Blank "c5" c6 = Blank "c6" p1, p2, p3, p21, p22, p23, p24, p25, p26 :: RDFLabel p1 = Res $ makeNSScopedName base1 "p1" p2 = Res $ makeNSScopedName base2 "p2" p3 = Res $ makeNSScopedName base3 "p3" p21 = Res $ makeNSScopedName base2 "p21" p22 = Res $ makeNSScopedName base2 "p22" p23 = Res $ makeNSScopedName base2 "p23" p24 = Res $ makeNSScopedName base2 "p24" p25 = Res $ makeNSScopedName base2 "p25" p26 = Res $ makeNSScopedName base2 "p26" o1, o2, o3 :: RDFLabel o1 = Res $ makeNSScopedName base1 "o1" o2 = Res $ makeNSScopedName base2 "o2" o3 = Res $ makeNSScopedName base3 "o3" l1txt, l2txt, l3txt, l11txt, l12txt, l13txt, l14txt :: B.Builder l1txt = "l1" l2txt = "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" l3txt = "l3--\r\"'\\--\x0020\&--\x00A0\&--" l11txt = "lx11" l12txt = "lx12" l13txt = "lx13" l14txt = "lx14" toL :: B.Builder -> RDFLabel toL = Lit . L.toStrict . B.toLazyText l1, l2, l3, l11, l12, l13, l14 :: RDFLabel l1 = toL l1txt l2 = toL l2txt l3 = toL l3txt l11 = toL l11txt l12 = toL l12txt l13 = toL l13txt l14 = toL l14txt lfr, lfoobar :: RDFLabel lfr = LangLit "chat et chien" (fromJust $ toLangTag "fr") lfoobar = TypedLit "foo bar" (makeNSScopedName base1 "o1") f1, f2 :: RDFLabel f1 = Res $ makeNSScopedName base1 "f1" f2 = Res $ makeNSScopedName base2 "f2" v1, v2, v3, v4 :: RDFLabel v1 = Var "var1" v2 = Var "var2" v3 = Var "var3" v4 = Var "var4" ------------------------------------------------------------ -- Construct graphs for testing ------------------------------------------------------------ t01, t02, t03, t04, t05, t06, t07 :: Arc RDFLabel t01 = arc s1 p1 o1 t02 = arc s2 p1 o2 t03 = arc s3 p1 o3 t04 = arc s1 p1 l1 t05 = arc s2 p1 b1 t06 = arc s3 p1 l2 t07 = arc s3 p2 l3 nslist :: NamespaceMap nslist = M.fromList $ map getNamespaceTuple [ base1 , base2 , base3 , base4 ] g1np :: RDFGraph g1np = emptyRDFGraph { namespaces = uncurry M.singleton (getNamespaceTuple base1) , statements = S.singleton t01 } toGraph :: [Arc RDFLabel] -> RDFGraph toGraph arcs = (toRDFGraph (S.fromList arcs)) {namespaces = nslist} g1, g1b1, g1b3, g1a1, g1l1, g1l2 :: RDFGraph g1 = toGraph [t01] g1b1 = toGraph [arc b1 p1 o1] g1b3 = toGraph [arc b1 b2 b3] g1a1 = toGraph [arc (Blank "1") p1 o1] g1l1 = toGraph [arc s1 p1 l1] g1l2 = toGraph [arc s1 p1 l2] {- g1f1 = NSGraph { namespaces = nslist , formulae = M.singleton o1 (Formula o1g1) , statements = [f01] } where f01 = arc s1 p1 o1 -} g1f2, g1f3 :: RDFGraph g1f2 = NSGraph { namespaces = nslist , formulae = M.singleton b2 g1 -- $ Formula b2 g1 , statements = S.singleton $ arc s1 p1 b2 } g1f3 = NSGraph { namespaces = nslist , formulae = M.singleton b3 g1f2 -- $ Formula b3 g1f2 , statements = S.singleton $ arc s1 p1 b3 } g1fu1 :: RDFGraph g1fu1 = mempty { namespaces = M.fromList $ map getNamespaceTuple [basem, makeNamespace Nothing (toURI "file:///home/swish/photos/")] , statements = S.fromList [arc sf meDepicts meMe, arc sf meHasURN su] } ---- g2, g3, g4, g5, g6, g7 :: RDFGraph g2 = toRDFGraph $ S.fromList [t01,t02,t03] g3 = toGraph [t01,t04] g4 = toGraph [t01,t05] g5 = toGraph [t01,t02,t03,t04,t05] g6 = toGraph [t01,t06] g7 = toGraph [t01,t07] t801, t802, t807, t808, t809, t810 :: Arc RDFLabel t801 = arc s1 resRdfType o1 t802 = arc s2 resOwlSameAs o2 t807 = arc o1 p1 s1 t808 = arc s2 p1 o2 t809 = arc s1 p2 o1 t810 = arc o2 p2 s2 g8, g81, g83 :: RDFGraph g8 = toGraph [t801,t802,t807,t808,t809,t810] g81 = toGraph [t801,t802] g83 = toGraph [t807,t808,t809,t810] t911, t912, t913, t914, t921, t922, t923, t924, t925, t926, t927, t928 :: Arc RDFLabel t911 = arc s1 p1 o1 t912 = arc s1 p1 o2 t913 = arc s1 p2 o2 t914 = arc s1 p2 o3 t921 = arc s2 p1 o1 t922 = arc s2 p1 o2 t923 = arc s2 p1 o3 t924 = arc s2 p1 l1 t925 = arc s2 p2 o1 t926 = arc s2 p2 o2 t927 = arc s2 p2 o3 t928 = arc s2 p2 l1 g9 :: RDFGraph g9 = toGraph [t911,t912,t913,t914, t921,t922,t923,t924, t925,t926,t927,t928] t1011, t1012, t1013, t1014, t1021, t1022, t1023, t1024, t1025, t1026, t1027, t1028 :: Arc RDFLabel t1011 = arc s1 p1 o1 t1012 = arc o2 p1 s1 t1013 = arc s1 p2 o2 t1014 = arc o3 p2 s1 t1021 = arc s2 p1 o1 t1022 = arc s2 p1 o2 t1023 = arc s2 p1 o3 t1024 = arc s2 p1 l1 t1025 = arc o1 p2 s2 t1026 = arc o2 p2 s2 t1027 = arc o3 p2 s2 -- t1028 = arc l1 p2 s2 t1028 = arc s1 p2 s2 g10 :: RDFGraph g10 = toGraph [t1011,t1012,t1013,t1014, t1021,t1022,t1023,t1024, t1025,t1026,t1027,t1028] g11 :: RDFGraph g11 = toGraph [ arc s1 p1 v1 , arc v2 p1 o1 , arc v3 p1 v4] tx101, tx102, tx111, tx112, tx113, tx114, tx121, tx122, tx123, tx124, tx125, tx126, tx127, tx128 :: Arc RDFLabel tx101 = arc b1 resOwlSameAs s1 tx102 = arc s2 resOwlSameAs b2 tx111 = arc b1 p1 o1 tx112 = arc b1 p1 o2 tx113 = arc b1 p2 o2 tx114 = arc b1 p2 o3 tx121 = arc b2 p1 o1 tx122 = arc b2 p1 o2 tx123 = arc b2 p1 o3 tx124 = arc b2 p1 l1 tx125 = arc b2 p2 o1 tx126 = arc b2 p2 o2 tx127 = arc b2 p2 o3 tx128 = arc b2 p2 l2 x1 :: RDFGraph x1 = toGraph [tx101,tx102, tx111,tx112,tx113,tx114, tx121,tx122,tx123,tx124, tx125,tx126,tx127,tx128] tx201, tx202, tx211, tx212, tx213, tx214, tx221, tx222, tx223, tx224, tx225, tx226, tx227 :: Arc RDFLabel tx201 = arc b1 resOwlSameAs s1 tx202 = arc s2 resOwlSameAs b2 tx211 = arc b1 p1 o1 tx212 = arc o2 p1 b1 tx213 = arc b1 p2 o2 tx214 = arc o3 p2 b1 tx221 = arc b2 p1 o1 tx222 = arc b2 p1 o2 tx223 = arc b2 p1 o3 tx224 = arc b2 p1 l1 tx225 = arc o1 p2 b2 tx226 = arc o2 p2 b2 tx227 = arc o3 p2 b2 -- tx228 = arc l1 p2 b2 x2 :: RDFGraph x2 = toGraph [tx201,tx202, tx211,tx212,tx213,tx214, tx221,tx222,tx223,tx224, tx225,tx226,tx227] tx311, tx312, tx313, tx314, tx321, tx322, tx323, tx324, tx325, tx326, tx327 :: Arc RDFLabel tx311 = arc s1 p1 o1 tx312 = arc o2 p1 s1 tx313 = arc s1 p2 o2 tx314 = arc o3 p2 s1 tx321 = arc s2 p1 o1 tx322 = arc s2 p1 o2 tx323 = arc s2 p1 o3 tx324 = arc s2 p1 l1 tx325 = arc o1 p2 s2 tx326 = arc o2 p2 s2 tx327 = arc o3 p2 s2 -- tx328 = arc l1 p2 s2 x3 :: RDFGraph x3 = toGraph [tx311,tx312,tx313,tx314, tx321,tx322,tx323,tx324, tx325,tx326,tx327] tx401, tx402, tx403, tx404, tx405, tx406, tx407, tx408, tx409 :: Arc RDFLabel tx401 = arc s1 resOwlSameAs b1 tx402 = arc b1 resRdfFirst o1 tx403 = arc b1 resRdfRest b2 tx404 = arc b2 resRdfFirst o2 tx405 = arc b2 resRdfRest b3 tx406 = arc b3 resRdfFirst o3 tx407 = arc b3 resRdfRest b4 tx408 = arc b4 resRdfFirst l1 tx409 = arc b4 resRdfRest resRdfNil x4 :: RDFGraph x4 = toGraph [tx401,tx402,tx403,tx404, tx405,tx406,tx407,tx408, tx409] x5 :: RDFGraph x5 = toGraph [ arc b1 resOwlSameAs s1 , arc b1 resRdfFirst o1 , arc b1 resRdfRest b2 , arc b2 resRdfFirst o2 , arc b2 resRdfRest b3 , arc b3 resRdfFirst o3 , arc b3 resRdfRest b4 , arc b4 resRdfFirst l1 , arc b4 resRdfRest resRdfNil ] {- I was aiming for :s1 = ( :o1 b2:o2 b3:o3 "l1" ) . but really it's :s1 rdf:first ( b1:o1 b2:o2 b3:o3 "l1" ) . or something like that. different versions of cwm parse the triples differently, and it depends on the output format too (eg n3 vs ntriples). -} x6 :: RDFGraph x6 = toGraph [ arc s1 resRdfFirst o1 , arc s1 resRdfRest b2 , arc b2 resRdfFirst o2 , arc b2 resRdfRest b3 , arc b3 resRdfFirst o3 , arc b3 resRdfRest b4 , arc b4 resRdfFirst l1 , arc b4 resRdfRest resRdfNil ] x7 :: RDFGraph x7 = NSGraph { namespaces = nslist , formulae = M.singleton b1 g2 -- $ Formula b1 g2 , statements = S.singleton $ arc b1 p2 f2 } x8 :: RDFGraph x8 = NSGraph { namespaces = nslist , formulae = M.singleton f1 g2 -- $ Formula f1 g2 , statements = S.singleton $ arc f1 p2 f2 } x9 :: RDFGraph x9 = NSGraph { namespaces = nslist , formulae = M.singleton f1 g1 -- $ Formula f1 g1 , statements = S.singleton $ arc f1 p2 f2 } -- Test allocation of bnodes carries over a nested formula x12, x12fg :: RDFGraph x12 = NSGraph { namespaces = nslist , formulae = M.singleton b2 x12fg -- $ Formula b2 x12fg , statements = S.fromList [ arc s1 p1 b1 , arc b1 p1 o1 , arc b2 p2 f2 , arc s3 p3 b3 , arc b3 p3 o3 ] } x12fg = toRDFGraph $ S.fromList [ arc s2 p2 b4 , arc b4 p2 o2 ] -- List of simple anon nodes x13 :: RDFGraph x13 = toGraph [ arc s1 resRdfFirst b1 , arc s1 resRdfRest c1 , arc c1 resRdfFirst b2 , arc c1 resRdfRest c2 , arc c2 resRdfFirst b3 , arc c2 resRdfRest resRdfNil , arc b1 p1 o1 , arc b2 p1 o2 , arc b3 p1 o3 ] -- List of simple anon nodes using autogenerated bnodes x13a :: RDFGraph x13a = toGraph [ arc s1 resRdfFirst b_1 , arc s1 resRdfRest c_1 , arc c_1 resRdfFirst b_2 , arc c_1 resRdfRest c_2 , arc c_2 resRdfFirst b_3 , arc c_2 resRdfRest resRdfNil , arc b_1 p1 o1 , arc b_2 p1 o2 , arc b_3 p1 o3 ] where b_1 = Blank "1" b_2 = Blank "2" b_3 = Blank "3" c_1 = Blank "4" c_2 = Blank "5" -- List of more complex anon nodes x14 :: RDFGraph x14 = toGraph [ arc s1 resRdfFirst b1 , arc s1 resRdfRest c1 , arc c1 resRdfFirst b2 , arc c1 resRdfRest c2 , arc c2 resRdfFirst b3 , arc c2 resRdfRest resRdfNil , arc b1 p1 o1 , arc b1 p2 o1 , arc b2 p1 o2 , arc b2 p2 o2 , arc b3 p1 o3 , arc b3 p2 o3 ] -- List with nested list x15 :: RDFGraph x15 = toGraph [ arc s1 resRdfFirst b1 , arc s1 resRdfRest c1 , arc c1 resRdfFirst b2 , arc c1 resRdfRest c2 , arc c2 resRdfFirst b3 , arc c2 resRdfRest resRdfNil , arc b1 p1 o1 , arc b2 p2 c3 , arc b3 p1 o3 , arc c3 resRdfFirst b4 , arc c3 resRdfRest c4 , arc c4 resRdfFirst b5 , arc c4 resRdfRest c5 , arc c5 resRdfFirst b6 , arc c5 resRdfRest resRdfNil , arc b4 p1 o1 , arc b5 p1 o2 , arc b6 p1 o3 ] -- More complex list with nested list x16 :: RDFGraph x16 = toGraph [ arc s1 resRdfFirst b1 , arc s1 resRdfRest c1 , arc c1 resRdfFirst b2 , arc c1 resRdfRest c2 , arc c2 resRdfFirst b3 , arc c2 resRdfRest resRdfNil , arc b1 p1 o1 , arc b1 p2 o1 , arc b2 p2 c3 , arc b3 p1 o3 , arc b3 p2 o3 , arc c3 resRdfFirst b4 , arc c3 resRdfRest c4 , arc c4 resRdfFirst b5 , arc c4 resRdfRest c5 , arc c5 resRdfFirst b6 , arc c5 resRdfRest resRdfNil , arc b4 p1 o1 , arc b4 p2 o1 , arc b5 p1 o2 , arc b5 p2 o2 , arc b6 p1 o3 , arc b6 p2 o3 ] -- Troublesome example x17 :: RDFGraph x17 = toGraph [ arc s1 resRdfType o1 , arc s1 resRdfFirst b1 , arc s1 resRdfRest c1 , arc c1 resRdfFirst b2 , arc c1 resRdfRest resRdfNil , arc b1 p21 o2 , arc b1 p22 c2 , arc b2 p24 o3 , arc b2 p25 l13 , arc c2 resRdfFirst b3 , arc c2 resRdfRest c3 , arc c3 resRdfFirst l12 , arc c3 resRdfRest resRdfNil , arc b3 p23 l11 ] -- collection graphs graph_c1, graph_c1rev, graph_c2, graph_c2rev, graph_c3 :: RDFGraph graph_c1 = toGraph [arc s1 p1 resRdfNil] graph_c1rev = toGraph [arc resRdfNil p1 o1] graph_c2 = toGraph [arc s1 p1 b1, arc b1 resRdfFirst l1, arc b1 resRdfRest b2, arc b2 resRdfFirst o2, arc b2 resRdfRest b3, arc b3 resRdfFirst l2, arc b3 resRdfRest b4, arc b4 resRdfFirst o3, arc b4 resRdfRest resRdfNil] graph_c2rev = toGraph [arc b1 resRdfFirst l1, arc b1 resRdfRest b2, arc b2 resRdfFirst o2, arc b2 resRdfRest b3, arc b3 resRdfFirst l2, arc b3 resRdfRest b4, arc b4 resRdfFirst o3, arc b4 resRdfRest resRdfNil, arc b1 p1 o1] graph_c3 = toGraph [arc s1 p1 b1, arc b1 resRdfFirst l1, arc b1 resRdfRest b2, arc b2 resRdfFirst o2, arc b2 resRdfRest b3, arc b3 resRdfFirst l2, arc b3 resRdfRest b4, arc b4 resRdfFirst o3, arc b4 resRdfRest resRdfNil, arc s1 p2 resRdfNil, arc s2 p2 o2] -- bnode graphs graph_b1, graph_b1rev, graph_b2, graph_b2rev, graph_b3, graph_b4, graph_b5 :: RDFGraph graph_b1 = toRDFGraph $ S.singleton $ arc s1 p1 b1 graph_b1rev = toRDFGraph $ S.singleton $ arc b1 p1 o1 graph_b2 = toRDFGraph $ S.fromList [arc s1 p1 b1, arc b1 p2 l1, arc b1 o2 o3] graph_b2rev = toRDFGraph $ S.fromList [arc b1 p2 l1, arc b1 o2 o3, arc b1 p1 o1] graph_b3 = toRDFGraph $ S.fromList [arc s1 p1 b1, arc b1 p2 l2, arc b1 o2 o3, arc s1 p2 b2, arc s2 p2 o2] graph_b4 = toRDFGraph $ S.fromList [arc b1 resRdfType o1, arc b2 resRdfType o2] graph_b5 = toRDFGraph $ S.fromList [arc b1 resRdfType o1, arc b2 p2 o2, arc b3 resRdfType o3] -- datatype/literal graphs graph_l1, graph_l2, graph_l3, graph_l4 :: RDFGraph graph_l1 = toGraph [arc s1 p1 lfr] graph_l2 = toGraph [arc s1 p1 lfoobar] graph_l3 = let tf :: ToRDFLabel a => a -> RDFTriple tf = toRDFTriple s1 p1 arcs = [ tf True , tf (12::Int) -- so, issue over comparing -2.304e-108 and value read in from string -- due to comparing a ScopedName instance built from a RDFLabel -- as the hash used in the comparison is based on the Show value -- but then why isn't this a problem for Float , tf ((-2.304e-108)::Double) , tf (23.4::Float) ] {- gtmp = toRDFGraph arcs in gtmp { namespaces = M.insert (Just "xsd") ("http://www.w3.org/2001/XMLSchema#") (namespaces gtmp) } -} in toRDFGraph $ S.fromList arcs graph_l4 = toGraph [ toRDFTriple s1 p1 ("A string with \"quotes\"" :: RDFLabel) , toRDFTriple s2 p2 (TypedLit "A typed string with \"quotes\"" (fromString "urn:a#b")) ] ------------------------------------------------------------ -- Trivial formatter tests ------------------------------------------------------------ -- -- These are very basic tests that confirm that output for a -- simple graph corresponds exactly to some supplied string. formatTest :: String -> RDFGraph -> B.Builder -> Test formatTest lab gr out = TestList [ TestCase ( assertEqual ("formatTest:"++lab) outTxt res ) ] where outTxt = B.toLazyText out res = formatGraphAsLazyText gr diagTest :: String -> RDFGraph -> L.Text -> Test diagTest lab gr out = TestList [ TestCase ( assertEqual ("diag:text:"++lab) out resTxt ) , TestCase ( assertEqual ("diag:map:"++lab) M.empty nmap ) , TestCase ( assertEqual ("diag:gen:"++lab) 0 ngen ) , TestCase ( assertEqual ("diag:trc:"++lab) [] trc ) ] where (res,nmap,ngen,trc) = formatGraphDiag "\n" True gr resTxt = B.toLazyText res mkPrefix :: Namespace -> B.Builder mkPrefix = namespaceToBuilder prefixList :: [B.Builder] prefixList = [ mkPrefix base1 , mkPrefix base2 , mkPrefix base3 , mkPrefix base4 , mkPrefix namespaceRDF , mkPrefix namespaceXSD ] commonPrefixesN :: [Int] -> B.Builder commonPrefixesN = mconcat . map (prefixList !!) commonPrefixes :: B.Builder commonPrefixes = commonPrefixesN [0..3] commonPrefixes21, commonPrefixes321, commonPrefixes132 :: B.Builder commonPrefixes21 = commonPrefixesN [1,0] commonPrefixes321 = commonPrefixesN [2,1,0] commonPrefixes132 = commonPrefixesN [0,2,1] -- Single statement using form simpleN3Graph_g1_01 :: B.Builder simpleN3Graph_g1_01 = " .\n" -- Single statement using prefix:name form simpleN3Graph_g1_02 :: B.Builder simpleN3Graph_g1_02 = commonPrefixes `mappend` "base1:s1 base1:p1 base1:o1 .\n" -- Single blank node simpleN3Graph_g1_03 :: B.Builder simpleN3Graph_g1_03 = commonPrefixes `mappend` "[\n base1:p1 base1:o1\n] .\n" -- Single auto-allocated blank node simpleN3Graph_g1_04 :: B.Builder simpleN3Graph_g1_04 = commonPrefixes `mappend` "[\n base1:p1 base1:o1\n] .\n" -- Single literal object simpleN3Graph_g1_05 :: B.Builder simpleN3Graph_g1_05 = commonPrefixes `mappend` "base1:s1 base1:p1 \"l1\" .\n" -- Single multiline literal object simpleN3Graph_g1_06 :: B.Builder simpleN3Graph_g1_06 = commonPrefixes `mappend` "base1:s1 base1:p1 \"l2-'\\\"line1\\\"'\\n\\nl2-'\\\"\\\"line2\\\"\\\"'\" .\n" -- this 'round trips' into a triple-quoted string simpleN3Graph_g1_06_rt :: B.Builder simpleN3Graph_g1_06_rt = commonPrefixes `mappend` "base1:s1 base1:p1 \"\"\"l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'\"\"\" .\n" {- -- Single statement with formula node simpleN3Graph_g1_07 = commonPrefixes ++ "base1:s1 base1:p1 base1:o1 .\n"++ "base1:o1 :-\n"++ " {\n"++ " base1:s1 base1:p1 base1:o1\n"++ " } .\n" -} -- Single statement with formula blank node simpleN3Graph_g1_08 :: B.Builder simpleN3Graph_g1_08 = mconcat [ commonPrefixes , "base1:s1 base1:p1 { \n" , " base1:s1 base1:p1 base1:o1\n" , " } .\n" ] -- Three blank nodes (or is that blind mice?) simpleN3Graph_g1_09 :: B.Builder simpleN3Graph_g1_09 = commonPrefixes `mappend` "[\n _:b2 []\n] .\n" -- Simple nested formula case simpleN3Graph_g1_10 :: B.Builder simpleN3Graph_g1_10 = mconcat [ commonPrefixes , "base1:s1 base1:p1 { \n" , " base1:s1 base1:p1 { \n" , " base1:s1 base1:p1 base1:o1\n" , " } \n" , " } .\n" ] -- try out URIs that do not use the http scheme simpleN3Graph_g1_fu1 :: B.Builder simpleN3Graph_g1_fu1 = mconcat [ "@prefix : .\n" , "@prefix me: .\n" -- , ":me.png me:depicts me:me ;\n" , " me:depicts me:me ;\n" , " me:hasURN .\n" ] {- Simple troublesome case Changed Aug 15 2013 to support rendering _:a :knows _:b . _:b :knows _:a . which, as currently implemented, loses the ability to make the simplification below. simpleN3Graph_x13a = mconcat [ commonPrefixes , "base1:s1 " , b1s , " ;\n" , " ( ", b2s, " ", b3s, " ) .\n" ] where b1s = "[\n base1:p1 base1:o1\n]" b2s = "[\n base1:p1 base2:o2\n]" b3s = "[\n base1:p1 base3:o3\n]" -} simpleN3Graph_x13a :: B.Builder simpleN3Graph_x13a = mconcat [ commonPrefixes , "base1:s1 " , b1n , " ;\n ( ", b2n, " ", b3n, " ) .\n" , b1n, " base1:p1 base1:o1 .\n" , b2n, " base1:p1 base2:o2 .\n" , b3n, " base1:p1 base3:o3 .\n" ] where b1n = "_:swish1" b2n = "_:swish2" b3n = "_:swish3" {- Simple collection tests; may replicate some of the previous tests. -} simpleN3Graph_c1 :: B.Builder simpleN3Graph_c1 = commonPrefixes `mappend` "base1:s1 base1:p1 () .\n" simpleN3Graph_c1rev :: B.Builder simpleN3Graph_c1rev = commonPrefixes `mappend` "() base1:p1 base1:o1 .\n" collItems :: B.Builder collItems = mconcat [ "( \"l1\" base2:o2 \"\"\"" , l2txt , "\"\"\" base3:o3 )" ] simpleN3Graph_c2 :: B.Builder simpleN3Graph_c2 = mconcat [ commonPrefixes , "base1:s1 base1:p1 " , collItems , " .\n" ] simpleN3Graph_c2rev :: B.Builder simpleN3Graph_c2rev = mconcat [ commonPrefixes , collItems, " base1:p1 base1:o1 .\n" ] simpleN3Graph_c3 :: B.Builder simpleN3Graph_c3 = mconcat [ commonPrefixes , "base1:s1 base1:p1 ", collItems, " ;\n" , " base2:p2 () .\n" , "base2:s2 base2:p2 base2:o2 .\n" ] {- Simple bnode tests; may replicate some of the previous tests. -} simpleN3Graph_b1 :: B.Builder simpleN3Graph_b1 = commonPrefixesN [0] `mappend` "base1:s1 base1:p1 [] .\n" simpleN3Graph_b1rev :: B.Builder simpleN3Graph_b1rev = commonPrefixesN [0] `mappend` "[\n base1:p1 base1:o1\n] .\n" {- See discussion of simpleN3Graph_x13a for why this has been changed simpleN3Graph_b2 = commonPrefixesN [0,1,2] `mappend` "base1:s1 base1:p1 [\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" -} simpleN3Graph_b2 :: B.Builder simpleN3Graph_b2 = commonPrefixesN [0,1,2] `mappend` "base1:s1 base1:p1 _:b1 .\n_:b1 base2:o2 base3:o3 ;\n base2:p2 \"l1\" .\n" simpleN3Graph_b2rev :: B.Builder simpleN3Graph_b2rev = commonPrefixesN [0,1,2] `mappend` "[\n base1:p1 base1:o1 ;\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" {- See discussion of simpleN3Graph_x13a for why this has been changed simpleN3Graph_b3 = mconcat [ commonPrefixesN [0,1,2] , "base1:s1 base1:p1 [\n base2:o2 base3:o3 ;\n base2:p2 \"\"\"", l2txt, "\"\"\"\n] ;\n" , " base2:p2 [] .\n" , "base2:s2 base2:p2 base2:o2 .\n" ] -} simpleN3Graph_b3 :: B.Builder simpleN3Graph_b3 = mconcat [ commonPrefixesN [0,1,2] , "base1:s1 base1:p1 _:b1 ;\n" , " base2:p2 [] .\n" , "base2:s2 base2:p2 base2:o2 .\n" , "_:b1 base2:o2 base3:o3 ;\n base2:p2 \"\"\"", l2txt, "\"\"\" .\n" ] simpleN3Graph_b4 :: B.Builder simpleN3Graph_b4 = mconcat [ commonPrefixesN [0,1,4] , "[\n a base1:o1\n] .\n" , "[\n a base2:o2\n] .\n" ] simpleN3Graph_b5 :: B.Builder simpleN3Graph_b5 = mconcat [ commonPrefixesN [0,1,2,4] , "[\n a base1:o1\n] .\n" , "[\n base2:p2 base2:o2\n] .\n" , "[\n a base3:o3\n] .\n" ] {- Simple datatype/language tests; may replicate some of the previous tests. -} simpleN3Graph_l1 :: B.Builder simpleN3Graph_l1 = commonPrefixes `mappend` "base1:s1 base1:p1 \"chat et chien\"@fr .\n" simpleN3Graph_l2 :: B.Builder simpleN3Graph_l2 = commonPrefixes `mappend` "base1:s1 base1:p1 \"foo bar\"^^base1:o1 .\n" simpleN3Graph_l3 :: B.Builder simpleN3Graph_l3 = mconcat [ commonPrefixesN [0, 5] , "\n" -- TODO: why do we need this newline? , "base1:s1 base1:p1 -2.304e-108,\n" , " 12,\n" , " \"2.34E1\"^^xsd:float, true .\n" ] simpleN3Graph_l4 :: B.Builder simpleN3Graph_l4 = mconcat [ commonPrefixes , "base1:s1 base1:p1 \"\"\"A string with \"quotes\\\"\"\"\" .\n" , "base2:s2 base2:p2 \"\"\"A typed string with \"quotes\\\"\"\"\"^^ .\n" ] trivialTestSuite :: Test trivialTestSuite = TestList [ -- formatTest "trivialTest01" g1np simpleN3Graph_g1_01 - no longer valid as now add in a prefix/namespace declaration formatTest "trivialTest02" g1 simpleN3Graph_g1_02 , formatTest "trivialTest03" g1b1 simpleN3Graph_g1_03 , formatTest "trivialTest04" g1a1 simpleN3Graph_g1_04 , formatTest "trivialTest05" g1l1 simpleN3Graph_g1_05 , formatTest "trivialTest06" g1l2 simpleN3Graph_g1_06_rt -- trivialTest07 = formatTest "trivialTest07" g1f1 simpleN3Graph_g1_07 -- formula is a named node , formatTest "trivialTest08" g1f2 simpleN3Graph_g1_08 , formatTest "trivialTest09" g1b3 simpleN3Graph_g1_09 , formatTest "trivialTest10" g1f3 simpleN3Graph_g1_10 , formatTest "trivialTest13a" x13a simpleN3Graph_x13a , formatTest "trivialTestfu1" g1fu1 simpleN3Graph_g1_fu1 , formatTest "trivialTestc1" graph_c1 simpleN3Graph_c1 , formatTest "trivialTestc2" graph_c2 simpleN3Graph_c2 , formatTest "trivialTestc3" graph_c3 simpleN3Graph_c3 , formatTest "trivialTestc1rev" graph_c1rev simpleN3Graph_c1rev , formatTest "trivialTestc2rev" graph_c2rev simpleN3Graph_c2rev , formatTest "trivialTestb1" graph_b1 simpleN3Graph_b1 , formatTest "trivialTestb2" graph_b2 simpleN3Graph_b2 , formatTest "trivialTestb3" graph_b3 simpleN3Graph_b3 , formatTest "trivialTestb4" graph_b4 simpleN3Graph_b4 , formatTest "trivialTestb5" graph_b5 simpleN3Graph_b5 , formatTest "trivialTestb1rev" graph_b1rev simpleN3Graph_b1rev , formatTest "trivialTestb2rev" graph_b2rev simpleN3Graph_b2rev , formatTest "lit1" graph_l1 simpleN3Graph_l1 , formatTest "lit2" graph_l2 simpleN3Graph_l2 , formatTest "lit3" graph_l3 simpleN3Graph_l3 , formatTest "lit4" graph_l4 simpleN3Graph_l4 , formatTest "trivialTestx4" x4 exoticN3Graph_x4 , formatTest "trivialTestx5" x5 exoticN3Graph_x5 , formatTest "trivialTestx7" x7 exoticN3Graph_x7 ] ------------------------------------------------------------ -- Parser tests to cross-check round-trip testing ------------------------------------------------------------ parseTest :: String -> B.Builder -> RDFGraph -> String -> Test parseTest lab inp gr er = TestList [ TestCase ( assertEqual ("parseTestError:"++lab) er pe ) , TestCase ( assertEqual ("parseTestGraph:"++lab) gr pg ) ] where (pe,pg) = case parseN3 (B.toLazyText inp) Nothing of Right g -> ("", g) Left s -> (s, emptyRDFGraph) noError, errorText :: String noError = "" errorText = "*" parseTestSuite :: Test parseTestSuite = TestList [ parseTest "01" simpleN3Graph_g1_01 g1np noError , parseTest "02" simpleN3Graph_g1_02 g1 noError , parseTest "03" simpleN3Graph_g1_03 g1b1 noError , parseTest "04" simpleN3Graph_g1_04 g1a1 noError , parseTest "05" simpleN3Graph_g1_05 g1l1 noError , parseTest "06" simpleN3Graph_g1_06 g1l2 noError , parseTest "06rt" simpleN3Graph_g1_06_rt g1l2 noError -- parseTest07 = parseTest "07" simpleN3Graph_g1_07 g1f1 noError -- formula is a named node , parseTest "08" simpleN3Graph_g1_08 g1f2 noError ] ------------------------------------------------------------ -- Repeat above tests using parser and graph-comparison ------------------------------------------------------------ -- -- This establishes a framework that will be used for -- more complex tests that are less susceptible to trivial -- formatting differences. The idea is to generate output -- that can be parsed to obtain an equivalent graph. roundTripTest :: String -> RDFGraph -> Test roundTripTest lab gr = TestList [ TestCase ( assertEqual ("RoundTrip:gr:"++lab) gr pg ) , TestCase ( assertEqual ("RoundTrip:er:"++lab) "" pe ) -- , TestCase ( assertEqual ("Formatted:"++lab) "" out ) ] where out = formatGraphAsLazyText gr (pe,pg) = case parseN3 out Nothing of Right g -> ("", g) Left s -> (s, mempty) -- Full round trip from graph source. This test may pick up some errors -- the bnode generation logic that are not tested by hand-assembled graph -- data structures. fullRoundTripTest :: String -> B.Builder -> Test fullRoundTripTest lab grstr = TestList [ TestCase ( assertEqual ("FullRoundTrip:gr:"++lab) gr pg ) , TestCase ( assertEqual ("FullRoundTrip:er:"++lab) "" pe ) -- , TestCase ( assertEqual ("FullRoundTrip:"++lab) "" out ) ] where grtxt = B.toLazyText grstr (_,gr) = case parseN3 grtxt Nothing of Right g -> ("", g) Left s -> (s, mempty) out = formatGraphAsLazyText gr (pe,pg) = case parseN3 out Nothing of Right g -> ("", g) Left s -> (s, mempty) roundTripTestSuite :: Test roundTripTestSuite = TestList [ roundTripTest "01" g1np , roundTripTest "02" g1 , roundTripTest "03" g1b1 , roundTripTest "04" g1a1 , roundTripTest "05" g1l1 , roundTripTest "06" g1l2 , roundTripTest "l1" graph_l1 , roundTripTest "l2" graph_l2 , roundTripTest "l3" graph_l3 , roundTripTest "l4" graph_l4 -- roundTripTest07 = roundTripTest "07" g1f1 -- formula is a named node , roundTripTest "08" g1f2 , fullRoundTripTest "11" simpleN3Graph_g1_01 , fullRoundTripTest "12" simpleN3Graph_g1_02 , fullRoundTripTest "13" simpleN3Graph_g1_03 , fullRoundTripTest "14" simpleN3Graph_g1_04 , fullRoundTripTest "15" simpleN3Graph_g1_05 , fullRoundTripTest "16rt" simpleN3Graph_g1_06_rt -- roundTripTest17 = fullRoundTripTest "17" simpleN3Graph_g1_07 -- TODO: :- with named node for formula , fullRoundTripTest "18" simpleN3Graph_g1_08 , fullRoundTripTest "fu1" simpleN3Graph_g1_fu1 , fullRoundTripTest "l1" simpleN3Graph_l1 , fullRoundTripTest "l2" simpleN3Graph_l2 , fullRoundTripTest "l3" simpleN3Graph_l3 , fullRoundTripTest "l4" simpleN3Graph_l4 ] ------------------------------------------------------------ -- Simple formatter tests ------------------------------------------------------------ -- -- These are simple tests that format and re-parse a graph, -- and make sure that the result graph compares the same as -- the original. Therefore, depends on a trusted parser and -- graph compare function. simpleTest :: String -> RDFGraph -> Test simpleTest lab = roundTripTest ("SimpleTest:"++lab) simpleTestSuite :: Test simpleTestSuite = TestList [ simpleTest "01" g2 , simpleTest "02" g3 , simpleTest "03" g4 , simpleTest "04" g5 , simpleTest "05" g6 , simpleTest "06" g7 , simpleTest "07" g8 , simpleTest "08" g81 , simpleTest "10" g83 , simpleTest "11" g9 , simpleTest "12" g10 , simpleTest "13" g11 ] ------------------------------------------------------------ -- Exotic parser tests ------------------------------------------------------------ -- -- These tests cover various forms of anonymous nodes -- [...], lists and formulae. -- -- does a round-trip test starting with the exoticTest :: String -> RDFGraph -> Test exoticTest lab gr = TestList [ TestCase ( assertEqual ("ExoticTest:gr:"++lab) gr pg ) , TestCase ( assertEqual ("ExoticTest:er:"++lab) "" pe ) -- , TestCase ( assertEqual ("ExoticTest:"++lab) "" out ) ] where out = formatGraphAsLazyText gr (pe,pg) = case parseN3 out Nothing of Right g -> ("", g) Left s -> (s, mempty) -- Simple anon nodes, with semicolons and commas exoticN3Graph_x1 :: B.Builder exoticN3Graph_x1 = mconcat [ commonPrefixes , " [ base1:p1 base1:o1 ; \n" , " base1:p1 base2:o2 ; \n" , " base2:p2 base2:o2 ; \n" , " base2:p2 base3:o3 ] = base1:s1 . \n" , " base2:s2 = \n" , " [ base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " base2:p2 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"\"\"", l2txt, "\"\"\" ] . \n" ] -- Simple anon nodes, with 'is ... of' and semicolons and commas exoticN3Graph_x2 :: B.Builder exoticN3Graph_x2 = mconcat [ commonPrefixes , " [ @has base1:p1 base1:o1 ; \n" , " @is base1:p1 @of base2:o2 ; \n" , " @has base2:p2 base2:o2 ; \n" , " @is base2:p2 @of base3:o3 ] = base1:s1 . \n" , " base2:s2 = \n" , " [ @has base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " @is base2:p2 @of base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 ] . \n" ] -- Simple anon nodes, attached to identified node {- exoticN3Graph_x3 = commonPrefixes ++ " base1:s1 :- \n" ++ " [ has base1:p1 of base1:o1 ; \n" ++ " is base1:p1 of base2:o2 ; \n" ++ " has base2:p2 of base2:o2 ; \n" ++ " is base2:p2 of base3:o3 ] . \n" ++ " base2:s2 :- \n" ++ " [ has base1:p1 of base1:o1 , \n" ++ " base2:o2 , \n" ++ " base3:o3 , \n" ++ " \"l1\" ; \n" ++ " is base2:p2 of base1:o1 , \n" ++ " base2:o2 , \n" ++ " base3:o3 ] . \n" -- " \"l1\" ] . \n" -} -- List nodes, with and without :- exoticN3Graph_x4 :: B.Builder exoticN3Graph_x4 = commonPrefixes `mappend` "base1:s1 = ( base1:o1 base2:o2 base3:o3 \"l1\" ) .\n" exoticN3Graph_x5 :: B.Builder exoticN3Graph_x5 = commonPrefixes `mappend` "( base1:o1 base2:o2 base3:o3 \"l1\" ) = base1:s1 .\n" {- exoticN3Graph_x6 = commonPrefixes ++ " base1:s1 :- (base1:o1 base2:o2 base3:o3 \"l1\") .\n" -} -- Formula nodes exoticN3Graph_x7 :: B.Builder exoticN3Graph_x7 = mconcat [ commonPrefixes , " { \n" , " base1:s1 base1:p1 base1:o1 .\n" , " base2:s2 base1:p1 base2:o2 .\n" , " base3:s3 base1:p1 base3:o3\n" , " } base2:p2 base2:f2 .\n" ] -- as above with the trailing . in the formula exoticN3Graph_x7a :: B.Builder exoticN3Graph_x7a = mconcat [ commonPrefixes , " { \n" , " base1:s1 base1:p1 base1:o1 .\n" , " base2:s2 base1:p1 base2:o2 .\n" , " base3:s3 base1:p1 base3:o3 .\n" , " } base2:p2 base2:f2 ." ] {- exoticN3Graph_x8 = commonPrefixes ++ " base1:f1 :- \n" ++ " { base1:s1 base1:p1 base1:o1 . \n" ++ " base2:s2 base1:p1 base2:o2 . \n" ++ " base3:s3 base1:p1 base3:o3 . } ; \n" ++ " base2:p2 base2:f2 . " -} {- exoticN3Graph_x9 = commonPrefixes ++ " base1:f1 :- \n" ++ " { base1:s1 base1:p1 base1:o1 . } ; \n" ++ " base2:p2 base2:f2 . " -} -- Test allocation of bnodes over a nested formula exoticN3Graph_x12 :: B.Builder exoticN3Graph_x12 = mconcat [ commonPrefixes , " base1:s1 base1:p1 [ base1:p1 base1:o1 ] . \n" , " { base2:s2 base2:p2 [ base2:p2 base2:o2 ] . } \n" , " base2:p2 base2:f2 . \n" , " base3:s3 base3:p3 [ base3:p3 base3:o3 ] ." ] -- List of bnodes {- exoticN3Graph_x13 = commonPrefixes ++ " base1:s1 :- \n" ++ " ( [base1:p1 base1:o1] \n" ++ " [base1:p1 base2:o2] \n" ++ " [base1:p1 base3:o3] ) .\n" -} {- TODO Hmm, what does the input graph really mean? can we test the following somewhere (do we already?) exoticN3Graph_x13 = commonPrefixes ++ " base1:s1 = \n" ++ " ( [base1:p1 base1:o1] \n" ++ " [base1:p1 base2:o2] \n" ++ " [base1:p1 base3:o3] ) .\n" -} -- List of more complex bnodes {- exoticN3Graph_x14 = commonPrefixes ++ " base1:s1 :- \n" ++ " ( [base1:p1 base1:o1; base2:p2 base1:o1] \n" ++ " [base1:p1 base2:o2; base2:p2 base2:o2] \n" ++ " [base1:p1 base3:o3; base2:p2 base3:o3] ) .\n" -} exoticN3Graph_x14 :: B.Builder exoticN3Graph_x14 = mconcat [ commonPrefixes , " base1:s1 = \n" , " ( [base1:p1 base1:o1; base2:p2 base1:o1] \n" , " [base1:p1 base2:o2; base2:p2 base2:o2] \n" , " [base1:p1 base3:o3; base2:p2 base3:o3] ) .\n" ] -- List with nested list {- exoticN3Graph_x15 = commonPrefixes ++ " base1:s1 :- \n" ++ " ( [base1:p1 base1:o1] \n"++ " [base2:p2 \n" ++ " ( [base1:p1 base1:o1] \n" ++ " [base1:p1 base2:o2] \n" ++ " [base1:p1 base3:o3] ) ] \n"++ " [base1:p1 base3:o3] ) .\n" -} -- More complex list with nested list {- exoticN3Graph_x16 = commonPrefixes ++ " base1:s1 :- \n" ++ " ( [base1:p1 base1:o1; base2:p2 base1:o1] \n"++ " [base2:p2 \n" ++ " ( [base1:p1 base1:o1; base2:p2 base1:o1] \n" ++ " [base1:p1 base2:o2; base2:p2 base2:o2] \n" ++ " [base1:p1 base3:o3; base2:p2 base3:o3] ) ] \n"++ " [base1:p1 base3:o3; base2:p2 base3:o3] ) .\n" -} -- Troublesome example {- exoticN3Graph_x17 = commonPrefixes ++ "base1:s1 a base1:o1 ; :- \n" ++ " ( [ base2:p21 base2:o2 ; \n" ++ " base2:p22 ( [ base2:p23 \"lx11\" ] \"lx12\" ) ] \n" ++ " [ base2:p24 base3:o3 ; base2:p25 \"lx13\" ] \n" ++ " ) . \n" -} -- Null prefixes {- exoticN3Graph_x18 = commonPrefixes ++ "@prefix : <#> . " ++ ":s1 a :o1 ; :- \n" ++ " ( [ :p21 :o2 ; \n" ++ " :p22 ( [ :p23 \"lx11\" ] \"lx12\" ) ] \n" ++ " [ :p24 :o3 ; :p25 \"lx13\" ] \n" ++ " ) . \n" -} -- Check graph sources parse to expected values exoticTestSuite :: Test exoticTestSuite = TestList [ parseTest "exoticParseTest01" exoticN3Graph_x1 x1 noError , parseTest "exoticParseTest02" exoticN3Graph_x2 x2 noError -- exoticParseTest03 = parseTest "exoticParseTest03" exoticN3Graph_x3 x3 noError , parseTest "exoticParseTest04" exoticN3Graph_x4 x4 noError , parseTest "exoticParseTest05" exoticN3Graph_x5 x5 noError -- exoticParseTest06 = parseTest "exoticParseTest06" exoticN3Graph_x6 x6 noError , parseTest "exoticParseTest07" exoticN3Graph_x7 x7 noError , parseTest "exoticParseTest07a" exoticN3Graph_x7a x7 noError -- exoticParseTest08 = parseTest "exoticParseTest08" exoticN3Graph_x8 x8 noError -- exoticParseTest09 = parseTest "exoticParseTest09" exoticN3Graph_x9 x9 noError , parseTest "exoticParseTest12" exoticN3Graph_x12 x12 noError -- exoticParseTest13 = parseTest "exoticParseTest13" exoticN3Graph_x13 x13 noError -- exoticParseTest14 = parseTest "exoticParseTest14" exoticN3Graph_x14 x14 noError -- TODO: re-instate? -- exoticParseTest15 = parseTest "exoticParseTest15" exoticN3Graph_x15 x15 noError -- exoticParseTest16 = parseTest "exoticParseTest16" exoticN3Graph_x16 x16 noError -- exoticParseTest17 = parseTest "exoticParseTest17" exoticN3Graph_x17 x17 noError , exoticTest "01" x1 , exoticTest "02" x2 , exoticTest "03" x3 , exoticTest "04" x4 , exoticTest "05" x5 , exoticTest "06" x6 , exoticTest "07" x7 -- exoticTest08 = exoticTest "08" x8 -- TODO: serialisation uses :- with a named node -- exoticTest09 = exoticTest "09" x9 -- TODO: serialisation uses :- with a named node , testGraphEq "exoticTest10" False x7 x8 , testGraphEq "exoticTest11" False x8 x9 , exoticTest "12" x12 , exoticTest "13" x13 , exoticTest "13a" x13a , exoticTest "14" x14 , exoticTest "15" x15 , exoticTest "16" x16 , exoticTest "17" x17 , fullRoundTripTest "Exotic01" exoticN3Graph_x1 , fullRoundTripTest "Exotic02" exoticN3Graph_x2 -- exoticRoundTripTest03 = fullRoundTripTest "Exotic03" exoticN3Graph_x3 , fullRoundTripTest "Exotic04" exoticN3Graph_x4 , fullRoundTripTest "Exotic05" exoticN3Graph_x5 -- exoticRoundTripTest06 = fullRoundTripTest "Exotic06" exoticN3Graph_x6 , fullRoundTripTest "Exotic07" exoticN3Graph_x7 -- exoticRoundTripTest08 = fullRoundTripTest "Exotic08" exoticN3Graph_x8 -- exoticRoundTripTest09 = fullRoundTripTest "Exotic09" exoticN3Graph_x9 , fullRoundTripTest "Exotic12" exoticN3Graph_x12 , fullRoundTripTest "Exotic14" exoticN3Graph_x14 -- exoticRoundTripTest15 = fullRoundTripTest "Exotic15" exoticN3Graph_x15 -- exoticRoundTripTest16 = fullRoundTripTest "Exotic16" exoticN3Graph_x16 -- exoticRoundTripTest17 = fullRoundTripTest "Exotic17" exoticN3Graph_x17 -- exoticRoundTripTest18 = fullRoundTripTest "Exotic18" exoticN3Graph_x18 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "trivial" trivialTestSuite , conv "parse" parseTestSuite , conv "roundtrip" roundTripTestSuite , conv "simple" simpleTestSuite , conv "exotic" exoticTestSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/N3ParserTest.hs0000644000000000000000000012631513543702315015263 0ustar0000000000000000{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : N3ParserTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : CPP, OverloadedStrings -- -- This Module contains test cases for module "N3Parser". -- -------------------------------------------------------------------------------- module Main where import qualified Data.Map as M import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B import qualified Test.Framework as TF import Swish.GraphClass (Arc, arc) import Swish.Namespace ( Namespace, makeNamespace, getNamespaceURI, getNamespaceTuple , ScopedName , makeScopedName , makeNSScopedName , nullScopedName , namespaceToBuilder ) import Swish.QName (QName, qnameFromURI) import Swish.RDF.Parser.N3 ( parseN3 , parseTextFromText, parseAltFromText , parseNameFromText -- , parsePrefixFromText , parseAbsURIrefFromText, parseLexURIrefFromText , parseURIref2FromText ) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..), NSGraph(..), NamespaceMap , emptyRDFGraph, toRDFGraph , resRdfType, resRdfFirst, resRdfRest, resRdfNil , resOwlSameAs, resLogImplies ) import Swish.RDF.Vocabulary ( namespaceRDF , toLangTag , rdfXMLLiteral , xsdBoolean , xsdInteger , xsdDecimal , xsdDouble ) import Test.HUnit (Test(TestCase,TestList), assertEqual) import Network.URI (URI, nullURI, parseURIReference) #if (!defined(__GLASGOW_HASKELL__)) || (__GLASGOW_HASKELL__ < 710) import Data.Monoid (Monoid(..)) #endif import Data.Maybe (fromJust, fromMaybe) import Data.List (intercalate) import TestHelpers (conv, testCompareEq) -- Specialized equality comparisons testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test testLabelEq = testCompareEq "testLabelEq:" testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test testGraphEq = testCompareEq "testGraphEq:" toURI :: String -> URI toURI s = fromMaybe (error ("Internal error: invalid uri=" ++ s)) (parseURIReference s) ------------------------------------------------------------ -- Generic item parsing test wrapper ------------------------------------------------------------ type ParseFromText a = L.Text -> Either String a parseItemTest :: (Eq a, Show a) => ParseFromText a -> a -> String -> L.Text -> a -> String -> Test parseItemTest ifroms def lab inp val err = TestList [ TestCase ( assertEqual ("parseItemError:"++lab) fixerr pe ) , TestCase ( assertEqual ("parseItemValue:"++lab) val pv ) ] where (pe,pv) = case ifroms inp of Left e -> (e,def) Right v -> (noError,v) fixerr = if err /= noError then pe else noError noError, errorText :: String noError = "" errorText = "*" ------------------------------------------------------------ -- Common test wrappers ------------------------------------------------------------ parseTestBase :: String -> Maybe QName -> String -> B.Builder -> RDFGraph -> String -> Test parseTestBase lbl1 mbase lbl2 inp gr er = TestList [ TestCase ( assertEqual ("parseTestError:"++lbl1++lbl2) er pe ) , TestCase ( assertEqual ("parseTestGraph:"++lbl1++lbl2) gr pg ) ] where (pe,pg) = case parseN3 (B.toLazyText inp) mbase of Right g -> ("", g) Left s -> (s, mempty) parseTest :: String -> B.Builder -> RDFGraph -> String -> Test parseTest = parseTestBase "" Nothing parseTestB :: QName -> String -> B.Builder -> RDFGraph -> String -> Test parseTestB base = parseTestBase "" (Just base) ------------------------------------------------------------ -- Test simple character parsing ------------------------------------------------------------ parseCharTest :: String -> String -> L.Text -> String -> String -> Test parseCharTest c = parseItemTest (parseTextFromText c) "" parseAltTest :: String -> String -> String -> L.Text -> String -> String -> Test parseAltTest cc1 cc2 = parseItemTest (parseAltFromText cc1 cc2) "" charTestSuite :: Test charTestSuite = TestList [ parseCharTest ":" "parseCharTest01" ":" ":" noError , parseCharTest "<>" "parseCharTest02" "<>" "<>" noError , parseAltTest ":" "<>" "parseCharTest03" ":" ":" noError , parseAltTest ":" "<>" "parseCharTest04" "<>" "<>" noError , parseAltTest ":" "<>" "parseCharTest04" "<=" "" errorText ] ------------------------------------------------------------ -- Test simple name parsing ------------------------------------------------------------ parseNameTest :: String -> L.Text -> String -> String -> Test parseNameTest = parseItemTest parseNameFromText "" nameTestSuite :: Test nameTestSuite = TestList [ parseNameTest "parseNameTest01" "name" "name" "" , parseNameTest "parseNameTest02" "rdf" "rdf" "" ] {- Not convinced it's worth testing this piece separately, so removing for now. ------------------------------------------------------------ -- Test simple prefix parsing ------------------------------------------------------------ parsePrefixTest :: String -> L.Text -> Namespace -> String -> Test parsePrefixTest = parseItemTest parsePrefixFromText (Namespace Nothing nullURI) prefixTestSuite :: Test prefixTestSuite = TestList [ parsePrefixTest "parsePrefixTest01" "pref" (Namespace (Just "pref") (toURI "pref:")) "" , parsePrefixTest "parsePrefixTest02" "rdf" namespaceRDF "" ] -} ------------------------------------------------------------ -- Test absolute URIref parsing ------------------------------------------------------------ parseAbsUriRefTest :: String -> L.Text -> URI -> String -> Test parseAbsUriRefTest = parseItemTest parseAbsURIrefFromText nullURI parseLexUriRefTest :: String -> L.Text -> URI -> String -> Test parseLexUriRefTest = parseItemTest parseLexURIrefFromText nullURI absUriRefInp01, absUriRefInp01s, absUriRefInp02, absUriRefInp02s :: L.Text absUriRefInp01 = "" absUriRefInp01s = " " absUriRefInp02 = "" absUriRefInp02s = " " absUriRef01, absUriRef02 :: URI absUriRef01 = toURI "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" absUriRef02 = toURI "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" absUriRefTestSuite :: Test absUriRefTestSuite = TestList [ parseAbsUriRefTest "parseAbsUriRefTest01" absUriRefInp01 absUriRef01 "" , parseAbsUriRefTest "parseAbsUriRefTest02" absUriRefInp02 absUriRef02 "" , parseLexUriRefTest "parseAbsUriRefTest03" absUriRefInp01s absUriRef01 "" , parseLexUriRefTest "parseAbsUriRefTest04" absUriRefInp02s absUriRef02 "" ] ------------------------------------------------------------ -- Test simple URIref parsing ------------------------------------------------------------ parseUriRef2Test :: String -> L.Text -> ScopedName -> String -> Test parseUriRef2Test = parseItemTest parseURIref2FromText nullScopedName sname01 :: ScopedName sname01 = makeNSScopedName namespaceRDF "type" uriRef02 :: L.Text uriRef02 = " " sname02 :: ScopedName sname02 = makeScopedName Nothing (toURI "http://id.ninebynine.org/wip/2003/test/graph1/node#") "s1" uriRef2TestSuite :: Test uriRef2TestSuite = TestList [ parseUriRef2Test "parseUriRef2Test01" "rdf:type" sname01 "" , parseUriRef2Test "parseUriRef2Test02" uriRef02 sname02 "" ] ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ baseFile :: String baseFile = "file:///dev/null" dqn :: QName dqn = (fromJust . qnameFromURI . toURI) baseFile toNS :: T.Text -> String -> Namespace toNS p = makeNamespace (Just p) . toURI dbase, base1, base2, base3, base4, basea :: Namespace dbase = makeNamespace Nothing $ toURI "#" base1 = toNS "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node/" base2 = toNS "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node#" base3 = toNS "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" base4 = toNS "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" basea = toNS "a" "http://example.org/basea#" xsdNS :: Namespace xsdNS = toNS "xsd" "http://www.w3.org/2001/XMLSchema#" u1 :: RDFLabel u1 = Res $ makeNSScopedName base1 "" ds1, ds2, ds3 :: RDFLabel ds1 = Res $ makeNSScopedName dbase "s1" ds2 = Res $ makeNSScopedName dbase "s2" ds3 = Res $ makeNSScopedName dbase "s3" dp1, dp2, dp3 :: RDFLabel dp1 = Res $ makeNSScopedName dbase "p1" dp2 = Res $ makeNSScopedName dbase "p2" dp3 = Res $ makeNSScopedName dbase "p3" do1, do2, do3 :: RDFLabel do1 = Res $ makeNSScopedName dbase "o1" do2 = Res $ makeNSScopedName dbase "o2" do3 = Res $ makeNSScopedName dbase "o3" s1, s2, s3, sa :: RDFLabel s1 = Res $ makeNSScopedName base1 "s1" s2 = Res $ makeNSScopedName base2 "s2" s3 = Res $ makeNSScopedName base3 "s3" sa = Res $ makeNSScopedName basea "a" b1, b2, b3, b4, b5, b6, b7, b8 :: RDFLabel b1 = Blank "b1" b2 = Blank "b2" b3 = Blank "b3" b4 = Blank "b4" b5 = Blank "b5" b6 = Blank "b6" b7 = Blank "b7" b8 = Blank "b8" c1, c2, c3, c4, c5, c6 :: RDFLabel c1 = Blank "c1" c2 = Blank "c2" c3 = Blank "c3" c4 = Blank "c4" c5 = Blank "c5" c6 = Blank "c6" p1, p2, p3, pa :: RDFLabel p1 = Res $ makeNSScopedName base1 "p1" p2 = Res $ makeNSScopedName base2 "p2" p3 = Res $ makeNSScopedName base3 "p3" pa = Res $ makeNSScopedName basea "b" o1, o2, o3, oa :: RDFLabel o1 = Res $ makeNSScopedName base1 "o1" o2 = Res $ makeNSScopedName base2 "o2" o3 = Res $ makeNSScopedName base3 "o3" oa = Res $ makeNSScopedName basea "c" l1, l2, l3 :: RDFLabel l1 = Lit "l1" l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" l3 = Lit "l3--\r\"'\\--\x0020\&--\x00A0\&--" lfr, lxml, lfrxml :: RDFLabel lfr = LangLit "chat" $ fromJust $ toLangTag "fr" lxml = TypedLit "
" rdfXMLLiteral lfrxml = TypedLit "chat" rdfXMLLiteral bTrue, bFalse :: RDFLabel bTrue = TypedLit "true" xsdBoolean bFalse = TypedLit "false" xsdBoolean f1, f2 :: RDFLabel f1 = Res $ makeNSScopedName base1 "f1" f2 = Res $ makeNSScopedName base2 "f2" v1, v2, v3, v4 :: RDFLabel v1 = Var "var1" v2 = Var "var2" v3 = Var "var3" v4 = Var "var4" ------------------------------------------------------------ -- Construct graphs for testing ------------------------------------------------------------ t01 , t01b, t02, t03, t04, t05, t06, t07 :: Arc RDFLabel t01 = arc s1 p1 o1 t01b = arc b1 b2 b3 t02 = arc s2 p1 o2 t03 = arc s3 p1 o3 t04 = arc s1 p1 l1 t05 = arc s2 p1 b1 t06 = arc s3 p1 l2 t07 = arc s3 p2 l3 makeNewPrefixNamespace :: (T.Text,Namespace) -> Namespace makeNewPrefixNamespace (pre,ns) = makeNamespace (Just pre) (getNamespaceURI ns) dg1, dg2, dg3 :: RDFGraph dg1 = toRDFGraph $ S.singleton $ arc ds1 dp1 do1 dg2 = toRDFGraph $ S.fromList [ arc xa1 xb1 xc1 , arc xa2 xb2 xc2 , arc xa3 xb3 xc3 , arc xa4 xb4 xc4 , arc xa5 xb5 xc5 ] where -- the document base is set to file:///dev/null to begin with xa1 = Res "file:///dev/a1" xb1 = Res "file:///dev/b1" xc1 = Res "file:///dev/c1" xa2 = Res "http://example.org/ns/a2" xb2 = Res "http://example.org/ns/b2" xc2 = Res "http://example.org/ns/c2" xa3 = Res "http://example.org/ns/foo/a3" xb3 = Res "http://example.org/ns/foo/b3" xc3 = Res "http://example.org/ns/foo/c3" ns4 = makeNamespace Nothing $ toURI "http://example.org/ns/foo/bar#" ns5 = makeNamespace Nothing $ toURI "http://example.org/ns2#" mUN a b = Res (makeNSScopedName a b) xa4 = mUN ns4 "a4" xb4 = mUN ns4 "b4" xc4 = mUN ns4 "c4" xa5 = mUN ns5 "a5" xb5 = mUN ns5 "b5" xc5 = mUN ns5 "c5" dg3 = -- TODO: add in prefixes ? toRDFGraph $ S.singleton $ arc (Res "file:///home/swish/photos/myphoto") (Res "http://example.com/ns#photoOf") (Res "http://example.com/ns#me") nslist, xnslist :: NamespaceMap nslist = M.fromList $ map getNamespaceTuple [base1, base2, base3, base4] xnslist = (\(a,b) -> M.insert a b nslist) $ getNamespaceTuple xsdNS toGraph :: [Arc RDFLabel] -> RDFGraph toGraph stmts = mempty { namespaces = nslist , statements = S.fromList stmts } g1 :: RDFGraph g1 = toGraph [t01] g1a :: RDFGraph g1a = toGraph [arc sa pa oa] g1_31 :: RDFGraph g1_31 = toGraph [arc u1 u1 u1] g1b :: RDFGraph g1b = toGraph [t01b] g1b_1 :: RDFGraph g1b_1 = toGraph [arc b1 p1 o1] g2 :: RDFGraph g2 = toGraph [t01,t02,t03] g3 :: RDFGraph g3 = toGraph [t01,t04] g4 :: RDFGraph g4 = toGraph [t01,t05] g4_1 :: RDFGraph g4_1 = toGraph [arc b1 p1 o1, arc b2 p2 o2] g4_2 :: RDFGraph g4_2 = toGraph [arc b1 resRdfType o1, arc b2 resRdfType o2] g5 :: RDFGraph g5 = toGraph [t01,t02,t03,t04,t05] g6 :: RDFGraph g6 = toGraph [t01,t06] g7 :: RDFGraph g7 = toGraph [t01,t07] t801, t802, t807, t808, t811, t812 :: Arc RDFLabel t801 = arc s1 resRdfType o1 t802 = arc s2 resOwlSameAs o2 t807 = arc o1 p1 s1 t808 = arc s2 p1 o2 t811 = arc s1 resLogImplies o1 t812 = arc o2 resLogImplies s2 g8 :: RDFGraph g8 = toGraph [t801,t802,t807,t808,t811,t812] g81 :: RDFGraph g81 = toGraph [t801,t802] g83 :: RDFGraph g83 = toGraph [t807,t808,t811,t812] t911, t912, t913, t914, t921, t922, t923, t924, t925, t926, t927, t928 :: Arc RDFLabel t911 = arc s1 p1 o1 t912 = arc s1 p1 o2 t913 = arc s1 p2 o2 t914 = arc s1 p2 o3 t921 = arc s2 p1 o1 t922 = arc s2 p1 o2 t923 = arc s2 p1 o3 t924 = arc s2 p1 l1 t925 = arc s2 p2 o1 t926 = arc s2 p2 o2 t927 = arc s2 p2 o3 t928 = arc s2 p2 l1 g9 :: RDFGraph g9 = toGraph [t911,t912,t913,t914, t921,t922,t923,t924, t925,t926,t927,t928] t1011, t1012, t1013, t1014, t1021, t1022, t1023, t1024, t1025, t1026, t1027, t1028 :: Arc RDFLabel t1011 = arc s1 p1 o1 t1012 = arc o2 p1 s1 t1013 = arc s1 p2 o2 t1014 = arc o3 p2 s1 t1021 = arc s2 p1 o1 t1022 = arc s2 p1 o2 t1023 = arc s2 p1 o3 t1024 = arc s2 p1 l1 t1025 = arc o1 p2 s2 t1026 = arc o2 p2 s2 t1027 = arc o3 p2 s2 t1028 = arc l1 p2 s2 g10 :: RDFGraph g10 = toGraph [t1011,t1012,t1013,t1014, t1021,t1022,t1023,t1024, t1025,t1026,t1027,t1028] t1111, t1112, t1113 :: Arc RDFLabel t1111 = arc s1 p1 v1 t1112 = arc v2 p1 o1 t1113 = arc v3 p1 v4 g11 :: RDFGraph g11 = toGraph [t1111,t1112,t1113] t1211, t1221, t1222, t1223, t1224 :: Arc RDFLabel t1211 = arc b1 p1 o1 t1221 = arc b2 resRdfFirst v1 t1222 = arc b2 resRdfRest b3 t1223 = arc b3 resRdfFirst v2 t1224 = arc b3 resRdfRest resRdfNil g12 :: RDFGraph g12 = toGraph [t1211,t1221,t1222,t1223,t1224] t1711, t1722, t1733 :: Arc RDFLabel t1711 = arc s1 p1 lfr t1722 = arc s2 p2 lxml t1733 = arc s3 p3 lfrxml g17 :: RDFGraph g17 = toGraph [t1711,t1722,t1733] tx101, tx102, tx111, tx112, tx113, tx114, tx121, tx122, tx123, tx124, tx125, tx126, tx127, tx128 :: Arc RDFLabel tx101 = arc b1 resOwlSameAs s1 tx102 = arc s2 resOwlSameAs b2 tx111 = arc b1 p1 o1 tx112 = arc b1 p1 o2 tx113 = arc b1 p2 o2 tx114 = arc b1 p2 o3 tx121 = arc b2 p1 o1 tx122 = arc b2 p1 o2 tx123 = arc b2 p1 o3 tx124 = arc b2 p1 l1 tx125 = arc b2 p2 o1 tx126 = arc b2 p2 o2 tx127 = arc b2 p2 o3 tx128 = arc b2 p2 l1 x1 :: RDFGraph x1 = toGraph [tx101,tx102, tx111,tx112,tx113,tx114, tx121,tx122,tx123,tx124, tx125,tx126,tx127,tx128] tx201, tx202, tx211, tx212, tx213, tx214, tx221, tx222, tx223, tx224, tx225, tx226, tx227, tx228 :: Arc RDFLabel tx201 = arc b1 resOwlSameAs s1 tx202 = arc s2 resOwlSameAs b2 tx211 = arc b1 p1 o1 tx212 = arc o2 p1 b1 tx213 = arc b1 p2 o2 tx214 = arc o3 p2 b1 tx221 = arc b2 p1 o1 tx222 = arc b2 p1 o2 tx223 = arc b2 p1 o3 tx224 = arc b2 p1 l1 tx225 = arc o1 p2 b2 tx226 = arc o2 p2 b2 tx227 = arc o3 p2 b2 tx228 = arc l1 p2 b2 x2 :: RDFGraph x2 = toGraph [tx201,tx202, tx211,tx212,tx213,tx214, tx221,tx222,tx223,tx224, tx225,tx226,tx227,tx228] tx311, tx312, tx313, tx314, tx321, tx322, tx323, tx324, tx325, tx326, tx327, tx328 :: Arc RDFLabel tx311 = arc s1 p1 o1 tx312 = arc o2 p1 s1 tx313 = arc s1 p2 o2 tx314 = arc o3 p2 s1 tx321 = arc s2 p1 o1 tx322 = arc s2 p1 o2 tx323 = arc s2 p1 o3 tx324 = arc s2 p1 l1 tx325 = arc o1 p2 s2 tx326 = arc o2 p2 s2 tx327 = arc o3 p2 s2 tx328 = arc l1 p2 s2 x3 :: RDFGraph x3 = toGraph [tx311,tx312,tx313,tx314, tx321,tx322,tx323,tx324, tx325,tx326,tx327,tx328] tx401, tx402, tx403, tx404, tx405, tx406, tx407, tx408, tx409 :: Arc RDFLabel tx401 = arc s1 resOwlSameAs b1 tx402 = arc b1 resRdfFirst o1 tx403 = arc b1 resRdfRest b2 tx404 = arc b2 resRdfFirst o2 tx405 = arc b2 resRdfRest b3 tx406 = arc b3 resRdfFirst o3 tx407 = arc b3 resRdfRest b4 tx408 = arc b4 resRdfFirst l1 tx409 = arc b4 resRdfRest resRdfNil x4 :: RDFGraph x4 = toGraph [tx401,tx402,tx403,tx404, tx405,tx406,tx407,tx408, tx409] tx501, tx502, tx503, tx504, tx505, tx506, tx507, tx508, tx509 :: Arc RDFLabel tx501 = arc b1 resOwlSameAs s1 tx502 = arc b1 resRdfFirst o1 tx503 = arc b1 resRdfRest b2 tx504 = arc b2 resRdfFirst o2 tx505 = arc b2 resRdfRest b3 tx506 = arc b3 resRdfFirst o3 tx507 = arc b3 resRdfRest b4 tx508 = arc b4 resRdfFirst l1 tx509 = arc b4 resRdfRest resRdfNil x5 :: RDFGraph x5 = toGraph [tx501,tx502,tx503,tx504, tx505,tx506,tx507,tx508, tx509] tx601, tx602, tx603, tx604, tx605, tx606, tx607, tx608 :: Arc RDFLabel tx601 = arc s1 resRdfFirst o1 tx602 = arc s1 resRdfRest b2 tx603 = arc b2 resRdfFirst o2 tx604 = arc b2 resRdfRest b3 tx605 = arc b3 resRdfFirst o3 tx606 = arc b3 resRdfRest b4 tx607 = arc b4 resRdfFirst l1 tx608 = arc b4 resRdfRest resRdfNil x6 :: RDFGraph x6 = toGraph [tx601,tx602,tx603,tx604, tx605,tx606,tx607,tx608] tx701 :: Arc RDFLabel tx701 = arc b1 p2 f2 x7 :: RDFGraph x7 = NSGraph { namespaces = nslist , formulae = M.singleton b1 g2 -- $ Formula b1 g2 , statements = S.singleton tx701 } tx801 :: Arc RDFLabel tx801 = arc f1 p2 f2 x8 :: RDFGraph x8 = NSGraph { namespaces = nslist , formulae = M.singleton f1 g2 -- $ Formula f1 g2 , statements = S.singleton tx801 } x9 :: RDFGraph x9 = NSGraph { namespaces = nslist , formulae = M.singleton f1 g1 -- $ Formula f1 g1 , statements = S.singleton tx801 } -- Test allocation of bnodes carries over a nested formula tx1201, tx1202, tx1203, tx1204, tx1205, tx1211, tx1212 :: Arc RDFLabel tx1201 = arc s1 p1 b1 tx1202 = arc b1 p1 o1 tx1203 = arc b2 p2 f2 tx1204 = arc s3 p3 b3 tx1205 = arc b3 p3 o3 tx1211 = arc s2 p2 b4 tx1212 = arc b4 p2 o2 x12fg :: RDFGraph x12fg = mempty { statements = S.fromList [tx1211,tx1212] } {- x12fg = NSGraph { namespaces = emptyNamespaceMap , formulae = emptyFormulaMap , statements = S.fromList [tx1211,tx1212] } -} x12 :: RDFGraph x12 = NSGraph { namespaces = nslist , formulae = M.singleton b2 x12fg -- $ Formula b2 x12fg , statements = S.fromList [tx1201,tx1202,tx1203,tx1204,tx1205] } -- List of simple anon nodes tx1301, tx1302, tx1303, tx1304, tx1305, tx1306, tx1307, tx1308, tx1309 :: Arc RDFLabel tx1301 = arc s1 resRdfFirst b1 tx1302 = arc s1 resRdfRest c1 tx1303 = arc c1 resRdfFirst b2 tx1304 = arc c1 resRdfRest c2 tx1305 = arc c2 resRdfFirst b3 tx1306 = arc c2 resRdfRest resRdfNil tx1307 = arc b1 p1 o1 tx1308 = arc b2 p1 o2 tx1309 = arc b3 p1 o3 x13 :: RDFGraph x13 = toGraph [tx1301,tx1302,tx1303,tx1304,tx1305,tx1306, tx1307,tx1308,tx1309] -- List of more complex anon nodes tx1401, tx1402, tx1403, tx1404, tx1405, tx1406, tx1407, tx1408, tx1409, tx1410, tx1411, tx1412 :: Arc RDFLabel tx1401 = arc s1 resRdfFirst b1 tx1402 = arc s1 resRdfRest c1 tx1403 = arc c1 resRdfFirst b2 tx1404 = arc c1 resRdfRest c2 tx1405 = arc c2 resRdfFirst b3 tx1406 = arc c2 resRdfRest resRdfNil tx1407 = arc b1 p1 o1 tx1408 = arc b1 p2 o1 tx1409 = arc b2 p1 o2 tx1410 = arc b2 p2 o2 tx1411 = arc b3 p1 o3 tx1412 = arc b3 p2 o3 x14 :: RDFGraph x14 = toGraph [tx1401,tx1402,tx1403,tx1404,tx1405,tx1406, tx1407,tx1408,tx1409,tx1410,tx1411,tx1412] -- List with nested list tx1501, tx1502, tx1503, tx1504, tx1505, tx1506, tx1507, tx1508, tx1509 :: Arc RDFLabel tx1501 = arc s1 resRdfFirst b1 tx1502 = arc s1 resRdfRest c1 tx1503 = arc c1 resRdfFirst b2 tx1504 = arc c1 resRdfRest c2 tx1505 = arc c2 resRdfFirst b3 tx1506 = arc c2 resRdfRest resRdfNil tx1507 = arc b1 p1 o1 tx1508 = arc b2 p2 c3 tx1509 = arc b3 p1 o3 tx1521, tx1522, tx1523, tx1524, tx1525, tx1526, tx1527, tx1528, tx1529 :: Arc RDFLabel tx1521 = arc c3 resRdfFirst b4 tx1522 = arc c3 resRdfRest c4 tx1523 = arc c4 resRdfFirst b5 tx1524 = arc c4 resRdfRest c5 tx1525 = arc c5 resRdfFirst b6 tx1526 = arc c5 resRdfRest resRdfNil tx1527 = arc b4 p1 o1 tx1528 = arc b5 p1 o2 tx1529 = arc b6 p1 o3 x15 :: RDFGraph x15 = toGraph [tx1501,tx1502,tx1503,tx1504,tx1505,tx1506, tx1507,tx1508,tx1509, tx1521,tx1522,tx1523,tx1524,tx1525,tx1526, tx1527,tx1528,tx1529] -- More complex list with nested list tx1601, tx1602, tx1603, tx1604, tx1605, tx1606, tx1607, tx1608, tx1609, tx1610, tx1611 :: Arc RDFLabel tx1601 = arc s1 resRdfFirst b1 tx1602 = arc s1 resRdfRest c1 tx1603 = arc c1 resRdfFirst b2 tx1604 = arc c1 resRdfRest c2 tx1605 = arc c2 resRdfFirst b3 tx1606 = arc c2 resRdfRest resRdfNil tx1607 = arc b1 p1 o1 tx1608 = arc b1 p2 o1 tx1609 = arc b2 p2 c3 tx1610 = arc b3 p1 o3 tx1611 = arc b3 p2 o3 tx1621, tx1622, tx1623, tx1624, tx1625, tx1626, tx1627, tx1628, tx1629, tx1630, tx1631, tx1632 :: Arc RDFLabel tx1621 = arc c3 resRdfFirst b4 tx1622 = arc c3 resRdfRest c4 tx1623 = arc c4 resRdfFirst b5 tx1624 = arc c4 resRdfRest c5 tx1625 = arc c5 resRdfFirst b6 tx1626 = arc c5 resRdfRest resRdfNil tx1627 = arc b4 p1 o1 tx1628 = arc b4 p2 o1 tx1629 = arc b5 p1 o2 tx1630 = arc b5 p2 o2 tx1631 = arc b6 p1 o3 tx1632 = arc b6 p2 o3 x16 :: RDFGraph x16 = toGraph [tx1601,tx1602,tx1603,tx1604,tx1605,tx1606, tx1607,tx1608,tx1609,tx1610,tx1611, tx1621,tx1622,tx1623,tx1624,tx1625,tx1626, tx1627,tx1628,tx1629,tx1630,tx1631,tx1632] kg1 :: RDFGraph kg1 = toRDFGraph $ S.singleton $ arc b a c where -- the document base is set to file:///dev/null to begin with mUN = Res . makeNSScopedName dbase a = mUN "a" b = mUN "b" c = mUN "c" ------------------------------------------------------------ -- Simple parser tests ------------------------------------------------------------ -- check default base simpleN3Graph_dg_01 :: B.Builder simpleN3Graph_dg_01 = ":s1 :p1 :o1 ." -- from the turtle documentation simpleN3Graph_dg_02 :: B.Builder simpleN3Graph_dg_02 = mconcat [ "# this is a complete turtle document\n" , "# In-scope base URI is the document URI at this point\n" , " .\n" , "@base .\n" , "# In-scope base URI is http://example.org/ns/ at this point\n" , " .\n" , "@base .\n" , "# In-scope base URI is http://example.org/ns/foo/ at this point\n" , " .\n" , "@prefix : .\n" , ":a4 :b4 :c4 .\n" , "@prefix : .\n" , ":a5 :b5 :c5 .\n" ] -- try out file prefixes simpleN3Graph_dg_03 :: B.Builder simpleN3Graph_dg_03 = mconcat [ "@prefix : .\n" , "@prefix me: .\n" , ":myphoto me:photoOf me:me." ] commonPrefixes :: B.Builder commonPrefixes = mconcat $ map namespaceToBuilder [base1, base2, base3] rdfPrefix :: B.Builder rdfPrefix = namespaceToBuilder namespaceRDF -- Single statement using form simpleN3Graph_g1_01 :: B.Builder simpleN3Graph_g1_01 = " . " -- Single statement using prefix:name form simpleN3Graph_g1_02 :: B.Builder simpleN3Graph_g1_02 = namespaceToBuilder base1 `mappend` " base1:s1 base1:p1 base1:o1 . " -- Single statement using prefix:name form -- (this was added to check that the parser did not -- think we meant 'a:a a :b .' here) -- simpleN3Graph_g1_02a :: B.Builder simpleN3Graph_g1_02a = namespaceToBuilder basea `mappend` "a:a a:b a:c ." nToB :: Namespace -> B.Builder nToB = B.fromString . show . getNamespaceURI -- Single statement using :name form simpleN3Graph_g1_03 :: B.Builder simpleN3Graph_g1_03 = mconcat [ "@prefix : <", nToB base1, "> .\n" , " :s1 :p1 :o1 . " ] -- Check we can handle ':' and 'prefix:' forms. -- simpleN3Graph_g1_03_1 :: B.Builder simpleN3Graph_g1_03_1 = mconcat [ "@prefix : <", nToB base1, "> .\n" , " : : :." ] simpleN3Graph_g1_03_2 :: B.Builder simpleN3Graph_g1_03_2 = mconcat [ "@prefix b: <", nToB base1, "> .\n" , "b: b: b:. " ] -- Single statement using relative URI form simpleN3Graph_g1_04 :: B.Builder simpleN3Graph_g1_04 = mconcat [ "@base <", nToB base1, "> .\n" , " . " ] -- Single statement using blank nodes simpleN3Graph_g1_05 :: B.Builder simpleN3Graph_g1_05 = mconcat [ "@base <", nToB base1, "> .\n" , " _:b1 _:b2 _:b3 . " ] simpleN3Graph_g1_05_1 :: B.Builder simpleN3Graph_g1_05_1 = commonPrefixes `mappend` " _:b1 base1:p1 base1:o1 . " -- Single statement with junk following simpleN3Graph_g1_06 :: B.Builder simpleN3Graph_g1_06 = mconcat [ namespaceToBuilder base1 , " base1:s1 base1:p1 base1:o1 . " , " **** " ] -- Multiple statements simpleN3Graph_g2 :: B.Builder simpleN3Graph_g2 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base2:s2 base1:p1 base2:o2 . \n" , " base3:s3 base1:p1 base3:o3 . \n" ] -- Graph with literal simpleN3Graph_g3 :: B.Builder simpleN3Graph_g3 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base1:s1 base1:p1 \"l1\" . \n" ] -- Graph with nodeid simpleN3Graph_g4 :: B.Builder simpleN3Graph_g4 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base2:s2 base1:p1 _:b1 . \n" ] simpleN3Graph_g4_1 :: B.Builder simpleN3Graph_g4_1 = commonPrefixes `mappend` " _:b1 base1:p1 base1:o1._:b2 base2:p2 base2:o2." simpleN3Graph_g4_2 :: B.Builder simpleN3Graph_g4_2 = commonPrefixes `mappend` " _:foo1 a base1:o1. _:bar2 a base2:o2." -- same graph as g4_2 simpleN3Graph_g4_3 :: B.Builder simpleN3Graph_g4_3 = commonPrefixes `mappend` " [] a base1:o1.[a base2:o2]." -- Graph with literal and nodeid simpleN3Graph_g5 :: B.Builder simpleN3Graph_g5 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base2:s2 base1:p1 base2:o2 . \n" , " base3:s3 base1:p1 base3:o3 . \n" , " base1:s1 base1:p1 \"l1\" . \n" , " base2:s2 base1:p1 _:b1 . \n" ] -- Triple-quoted literal simpleN3Graph_g6 :: B.Builder simpleN3Graph_g6 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base3:s3 base1:p1 \"\"\"l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'\"\"\" . \n" ] -- String escapes simpleN3Graph_g7 :: B.Builder simpleN3Graph_g7 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 . \n" , " base3:s3 base2:p2 " , " \"l3--\\r\\\"\\'\\\\--\\u0020--\\U000000A0--\" " , " . \n" ] -- Different verb forms simpleN3Graph_g8 :: B.Builder simpleN3Graph_g8 = mconcat [ commonPrefixes , " base1:s1 a base1:o1 . \n" , " base2:s2 = base2:o2 . \n" , " base1:s1 @is base1:p1 @of base1:o1 . \n" , " base2:s2 @has base1:p1 base2:o2 . \n" , " base1:s1 => base1:o1 . \n" , " base2:s2 <= base2:o2 . \n" ] simpleN3Graph_g8b :: B.Builder simpleN3Graph_g8b = mconcat [ commonPrefixes , " base1:s1 a base1:o1 . \n" , " base2:s2 = base2:o2 . \n" , " base1:s1 is base1:p1 of base1:o1 . \n" , " base2:s2 @has base1:p1 base2:o2 . \n" , " base1:s1 => base1:o1 . \n" , " base2:s2 <= base2:o2 . \n" ] simpleN3Graph_g81 :: B.Builder simpleN3Graph_g81 = mconcat [ commonPrefixes , " base1:s1 a base1:o1 . \n" , " base2:s2 = base2:o2 . \n" ] simpleN3Graph_g83 :: B.Builder simpleN3Graph_g83 = mconcat [ commonPrefixes , " base1:s1 @is base1:p1 @of base1:o1 . \n" , " base2:s2 @has base1:p1 base2:o2 . \n" , " base1:s1 => base1:o1 . \n" , " base2:s2 <= base2:o2 . \n" ] simpleN3Graph_g83b :: B.Builder simpleN3Graph_g83b = mconcat [ commonPrefixes , " base1:s1 is base1:p1 of base1:o1 . \n" , " base2:s2 @has base1:p1 base2:o2 . \n" , " base1:s1 => base1:o1 . \n" , " base2:s2 <= base2:o2 . \n" ] -- Semicolons and commas simpleN3Graph_g9 :: B.Builder simpleN3Graph_g9 = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 ; \n" , " base1:p1 base2:o2 ; \n" , " base2:p2 base2:o2 ; \n" , " base2:p2 base3:o3 . \n" , " base2:s2 base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " base2:p2 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" . \n" ] -- ensure you can end a property list with a semicolon simpleN3Graph_g9b :: B.Builder simpleN3Graph_g9b = mconcat [ commonPrefixes , " base1:s1 base1:p1 base1:o1 ; \n" , " base1:p1 base2:o2 ; \n" , " base2:p2 base2:o2 ; \n" , " base2:p2 base3:o3;. \n" , " base2:s2 base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " base2:p2 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ;. \n" ] -- 'is ... of' and semicolons and commas simpleN3Graph_g10 :: B.Builder simpleN3Graph_g10 = mconcat [ commonPrefixes , " base1:s1 @has base1:p1 base1:o1 ; \n" , " @is base1:p1 @of base2:o2 ; \n" , " @has base2:p2 base2:o2 ; \n" , " @is base2:p2 @of base3:o3 . \n" , " base2:s2 @has base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " @is base2:p2 @of base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" . \n" ] -- Simple statements using ?var form simpleN3Graph_g11 :: B.Builder simpleN3Graph_g11 = mconcat [ namespaceToBuilder base1 , " base1:s1 base1:p1 ?var1 . \n" , " ?var2 base1:p1 base1:o1 . \n" , " ?var3 base1:p1 ?var4 . \n" ] -- Bare anonymous nodes simpleN3Graph_g12 :: B.Builder simpleN3Graph_g12 = mconcat [ namespaceToBuilder base1 , " [ base1:p1 base1:o1 ] . \n" , " ( ?var1 ?var2 ) . \n" ] -- Literals with dataype and language simpleN3Graph_g17 :: B.Builder simpleN3Graph_g17 = mconcat [ commonPrefixes , rdfPrefix , " base1:s1 base1:p1 \"chat\"@fr . \n " , " base2:s2 base2:p2 \"
\"^^rdf:XMLLiteral . \n " , " base3:s3 base3:p3 \"chat\"^^rdf:XMLLiteral . \n " ] emsg16 :: String {- parsec error emsg16 = intercalate "\n" [ "", "@prefix base1 : . base1:s1 base1:p1 base1:o1 . **** ", " ^", "(line 1, column 103 indicated by the '^' sign above):", "", "unexpected \"*\"", "expecting declaration, \"@\", pathitem or end of input" ] -} emsg16 = "Expected end of input (EOF)\nRemaining input:\n**** " simpleTestSuite :: Test simpleTestSuite = TestList [ parseTestB dqn "simpleTestd01" simpleN3Graph_dg_01 dg1 noError , parseTestB dqn "simpleTestd02" simpleN3Graph_dg_02 dg2 noError , parseTestB dqn "simpleTestd03" simpleN3Graph_dg_03 dg3 noError , parseTest "simpleTest011" simpleN3Graph_g1_01 g1 noError , parseTest "simpleTest012" simpleN3Graph_g1_02 g1 noError , parseTest "simpleTest012a" simpleN3Graph_g1_02a g1a noError , parseTest "simpleTest013" simpleN3Graph_g1_03 g1 noError , parseTest "simpleTest013_1" simpleN3Graph_g1_03_1 g1_31 noError , parseTest "simpleTest013_2" simpleN3Graph_g1_03_2 g1_31 noError , parseTest "simpleTest014" simpleN3Graph_g1_04 g1 noError , parseTest "simpleTest015" simpleN3Graph_g1_05 g1b noError , parseTest "simpleTest015_1" simpleN3Graph_g1_05_1 g1b_1 noError , parseTest "simpleTest016" simpleN3Graph_g1_06 emptyRDFGraph emsg16 , parseTest "simpleTest03" simpleN3Graph_g2 g2 noError , parseTest "simpleTest04" simpleN3Graph_g3 g3 noError , parseTest "simpleTest05" simpleN3Graph_g4 g4 noError , parseTest "simpleTest05_1" simpleN3Graph_g4_1 g4_1 noError , parseTest "simpleTest05_2" simpleN3Graph_g4_2 g4_2 noError , parseTest "simpleTest05_3" simpleN3Graph_g4_3 g4_2 noError , parseTest "simpleTest06" simpleN3Graph_g5 g5 noError , parseTest "simpleTest07" simpleN3Graph_g6 g6 noError , parseTest "simpleTest08" simpleN3Graph_g7 g7 noError , parseTest "simpleTest09" simpleN3Graph_g8 g8 noError , parseTest "simpleTest09b" simpleN3Graph_g8b g8 noError , parseTest "simpleTest10" simpleN3Graph_g81 g81 noError , parseTest "simpleTest12" simpleN3Graph_g83 g83 noError , parseTest "simpleTest12b" simpleN3Graph_g83b g83 noError , parseTest "simpleTest13" simpleN3Graph_g9 g9 noError , parseTest "simpleTest13b" simpleN3Graph_g9b g9 noError , parseTest "simpleTest14" simpleN3Graph_g10 g10 noError , parseTest "simpleTest15" simpleN3Graph_g11 g11 noError , parseTest "simpleTest16" simpleN3Graph_g12 g12 noError , parseTest "simpleTest17" simpleN3Graph_g17 g17 noError ] ------------------------------------------------------------ -- Literal parser tests ------------------------------------------------------------ -- -- Expand upon the literal testing done above -- litN3Graph_g1 :: B.Builder litN3Graph_g1 = mconcat [ commonPrefixes , " base1:s1 base1:p1 \"true\"^^.\n" , " base2:s2 base2:p2 \"false\"^^.\n" , " base3:s3 base3:p3 \"true\"^^.\n" ] litN3Graph_g2 :: B.Builder litN3Graph_g2 = mconcat [ commonPrefixes , namespaceToBuilder xsdNS , " base1:s1 base1:p1 \"true\"^^xsd:boolean.\n" , " base2:s2 base2:p2 \"false\"^^xsd:boolean.\n" , " base3:s3 base3:p3 \"true\"^^xsd:boolean.\n" ] litN3Graph_g3 :: B.Builder litN3Graph_g3 = mconcat [ commonPrefixes , " base1:s1 base1:p1 @true.\n" , " base2:s2 base2:p2 @false.\n" , " base3:s3 base3:p3 true.\n" ] litN3Graph_g4 :: B.Builder litN3Graph_g4 = commonPrefixes `mappend` " base1:s1 base1:p1 ( true 1 2.0 -2.21 -2.3e-4 ).\n" lit_g1 :: RDFGraph lit_g1 = toGraph [ arc s1 p1 bTrue , arc s2 p2 bFalse , arc s3 p3 bTrue ] -- at the moment we could use lit_g1 rather than lit_g2, since -- the namespace map isn't used in the comparison. -- lit_g2 :: RDFGraph lit_g2 = lit_g1 { namespaces = xnslist } bOne, b20, b221, b23e4 :: RDFLabel 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 { namespaces = xnslist , statements = S.fromList [ arc s1 p1 b1 , arc b1 resRdfFirst bTrue , arc b1 resRdfRest b2 , arc b2 resRdfFirst bOne , arc b2 resRdfRest b3 , arc b3 resRdfFirst b20 , arc b3 resRdfRest b4 , arc b4 resRdfFirst b221 , arc b4 resRdfRest b5 , arc b5 resRdfFirst b23e4 , arc b5 resRdfRest resRdfNil ] } litTestSuite :: Test litTestSuite = TestList [ parseTest "litTest01" litN3Graph_g1 lit_g1 noError , parseTest "litTest02" litN3Graph_g2 lit_g2 noError , parseTest "litTest03" litN3Graph_g3 lit_g2 noError , parseTest "litTest04" litN3Graph_g4 lit_g4 noError ] ------------------------------------------------------------ -- Exotic parser tests ------------------------------------------------------------ -- -- These tests cover various forms of anonymous nodes -- [...], lists and formula. together with uses of ':-' -- -- Simple anon nodes, with semicolons and commas exoticN3Graph_x1 :: B.Builder exoticN3Graph_x1 = mconcat [ commonPrefixes , " [ base1:p1 base1:o1 ; \n" , " base1:p1 base2:o2 ; \n" , " base2:p2 base2:o2 ; \n" , " base2:p2 base3:o3 ] = base1:s1 . \n" , " base2:s2 = \n" , " [ base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " base2:p2 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ] . \n" ] -- check semi-colons at end of property list exoticN3Graph_x1b :: B.Builder exoticN3Graph_x1b = mconcat [ commonPrefixes , " [ base1:p1 base1:o1 ; \n" , " base1:p1 base2:o2 ; \n" , " base2:p2 base2:o2 ; \n" , " base2:p2 base3:o3; ] = base1:s1 . \n" , " base2:s2 = \n" , " [ base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " base2:p2 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; ] ;. \n" ] -- Simple anon nodes, with 'is ... of' and semicolons and commas exoticN3Graph_x2 :: B.Builder exoticN3Graph_x2 = mconcat [ commonPrefixes , " [ @has base1:p1 base1:o1 ; \n" , " @is base1:p1 @of base2:o2 ; \n" , " @has base2:p2 base2:o2 ; \n" , " @is base2:p2 @of base3:o3 ] = base1:s1 . \n" , " base2:s2 = \n" , " [ @has base1:p1 base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ; \n" , " @is base2:p2 @of base1:o1 , \n" , " base2:o2 , \n" , " base3:o3 , \n" , " \"l1\" ] . \n" ] -- List nodes exoticN3Graph_x4 :: B.Builder exoticN3Graph_x4 = commonPrefixes `mappend` " base1:s1 = (base1:o1 base2:o2 base3:o3 \"l1\") .\n" exoticN3Graph_x5 :: B.Builder exoticN3Graph_x5 = commonPrefixes `mappend` " (base1:o1 base2:o2 base3:o3 \"l1\") = base1:s1 .\n" -- Formula nodes, with and without :- exoticN3Graph_x7 :: B.Builder exoticN3Graph_x7 = mconcat [ commonPrefixes , " { base1:s1 base1:p1 base1:o1 . \n" , " base2:s2 base1:p1 base2:o2 . \n" , " base3:s3 base1:p1 base3:o3 . } \n" , " base2:p2 base2:f2 . " ] -- Test allocation of bnodes carries over a nested formula exoticN3Graph_x12 :: B.Builder exoticN3Graph_x12 = mconcat [ commonPrefixes , " base1:s1 base1:p1 [ base1:p1 base1:o1 ] . \n" , " { base2:s2 base2:p2 [ base2:p2 base2:o2 ] . } \n" , " base2:p2 base2:f2 . \n" , " base3:s3 base3:p3 [ base3:p3 base3:o3 ] ." ] exoticTestSuite :: Test exoticTestSuite = TestList [ parseTest "exoticTest01" exoticN3Graph_x1 x1 noError , parseTest "exoticTest01b" exoticN3Graph_x1b x1 noError , parseTest "exoticTest02" exoticN3Graph_x2 x2 noError , parseTest "exoticTest04" exoticN3Graph_x4 x4 noError , parseTest "exoticTest05" exoticN3Graph_x5 x5 noError , parseTest "exoticTest07" exoticN3Graph_x7 x7 noError , parseTest "exoticTest12" exoticN3Graph_x12 x12 noError , testGraphEq "exoticTest20" False x7 x8 , testGraphEq "exoticTest21" False x8 x9 ] keywordN3Graph_01 :: B.Builder keywordN3Graph_01 = "@keywords .\n" `mappend` "b a c . " -- a modification of simpleN3Graph_g8 keywordN3Graph_02 :: B.Builder keywordN3Graph_02 = mconcat [ commonPrefixes , "@prefix : ." , "@keywords is,has.\n" , " s1 @a o1 . \n" , " base2:s2 = base2:o2 . \n" , " s1 is base1:p1 @of o1 . \n" , " base2:s2 has p1 base2:o2 . \n" , " s1 => o1 . \n" , " base2:s2 <= . \n" -- object is base2:o2 ] -- a modification of simpleN3Graph_g83 keywordN3Graph_03 :: B.Builder keywordN3Graph_03 = mconcat [ commonPrefixes , "@keywords of.\n" , " base1:s1 @is base1:p1 of base1:o1 . \n" , " base2:s2 @has base1:p1 base2:o2 . \n" , " base1:s1 => base1:o1 . \n" , " base2:s2 <= base2:o2 . \n" ] keywordTestSuite :: Test keywordTestSuite = TestList [ parseTestB dqn "keywordTest01" keywordN3Graph_01 kg1 noError , parseTest "keywordTest02" keywordN3Graph_02 g8 noError , parseTest "keywordTest03" keywordN3Graph_03 g83 noError ] ------------------------------------------------------------ -- Test parser failure ------------------------------------------------------------ -- -- Very limited at the moment. -- failTest :: String -> B.Builder -> String -> Test failTest lbl gr = parseTest lbl gr emptyRDFGraph failN3Graph_g1 :: B.Builder failN3Graph_g1 = commonPrefixes `mappend` " base1:s1 base2:p2 unknown3:o3 . " fail1 :: String {- parsec error fail1 = intercalate "\n" [ "", "@prefix base3 : . ", " base1:s1 base2:p2 unknown3:o3 . ", " ^", "(line 4, column 29 indicated by the '^' sign above):", "", "unexpected Prefix 'unknown3:' not bound." ] -} fail1 = intercalate "\n" ["When looking for a non-empty sequence with separators:" , "\tPrefix 'unknown3:' not bound." , "Remaining input:" , "o3 . "] failTestSuite :: Test failTestSuite = TestList [ failTest "failTest01" failN3Graph_g1 fail1 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "char" charTestSuite , conv "name" nameTestSuite -- , prefixTestSuite , conv "absUriRef" absUriRefTestSuite , conv "uriRef2" uriRef2TestSuite , conv "simple" simpleTestSuite , conv "lit" litTestSuite , conv "exotic" exoticTestSuite , conv "keyword" keywordTestSuite , conv "fail" failTestSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/TurtleTest.hs0000644000000000000000000005764113543702315015112 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : TurtleTest -- Copyright : (c) 2013, 2018 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This Module contains test cases for the module -- "Swish.RDF.Parser.Turtle" and "Swish.RDF.Formatter.Turtle" based -- on the examples given in -- . -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Test.Framework as TF import qualified Test.Framework.Providers.HUnit as TF import Data.Char (chr) import Data.Maybe (fromMaybe) import Network.URI (URI, parseURIReference) import Swish.RDF.Graph ( RDFGraph , RDFLabel (..) , RDFTriple , ToRDFLabel -- , getArcs , toRDFGraph , toRDFTriple ) import Swish.RDF.Formatter.Turtle (formatGraphAsText) import Swish.RDF.Parser.Turtle (parseTurtle) import Swish.RDF.Vocabulary.DublinCore (dcelemtitle) import Swish.RDF.Vocabulary.FOAF (foafgivenName, foafknows, foafmbox, foafname, foafPerson) import Swish.RDF.Vocabulary.RDF (rdfType, rdfFirst, rdfRest, rdfNil, rdfsLabel) import Swish.RDF.Vocabulary.XSD (xsdDecimal, xsdDouble, xsdString) import Test.HUnit (Assertion, (@=?), assertFailure) triple :: (ToRDFLabel s, ToRDFLabel p, ToRDFLabel o) => s -> p -> o -> RDFTriple triple = toRDFTriple toURI :: String -> URI toURI s = fromMaybe (error ("Internal error: invalid uri=" ++ s)) (parseURIReference s) toGraph :: T.Text -> Either String RDFGraph toGraph = flip parseTurtle Nothing . L.fromStrict parseFail :: String -- ^ error from parse -> T.Text -- ^ original Turtle graph -> Assertion parseFail emsg gr = assertFailure $ concat ["Unable to parse:\n", emsg, "\n*** Turtle=\n", T.unpack gr] -- | Compare a Turtle format graph with its expected -- contents. There is also a 'round trip' check, that -- the contents, written out in Turtle format, then -- read back in, match the original contents (this -- only uses the list of triples, not the input Turtle -- version). -- -- It is quicker to just check the statements when we -- know that the graph can not contain a blank node -- - i.e. compare getArcs gr to S.fromList o - but -- stick with graph equality checks, for now. compareExample :: String -- ^ label -> T.Text -- ^ Turtle representation -> [RDFTriple] -- ^ Corresponding triples -> TF.Test compareExample l t o = let expectedGraph = toRDFGraph oset egr = toGraph t oset = S.fromList o lbl = "example: " ++ l compareTriples = case egr of Left e -> parseFail e t Right gr -> expectedGraph @=? gr compareRoundTrip = let ttl = formatGraphAsText expectedGraph tgr = toGraph ttl in case tgr of Left e -> parseFail e ttl Right gr -> expectedGraph @=? gr in TF.testGroup lbl [ TF.testCase "base case" compareTriples , TF.testCase "round-trip example" compareRoundTrip ] -- | Check that both graphs (in Turtle format) are -- the same, once parsed. -- compareGraphs :: String -> T.Text -> T.Text -> TF.Test compareGraphs l t1 t2 = let ans = case (toGraph t1, toGraph t2) of (Left e1, _) -> parseFail e1 t1 -- "graph 1 of " ++ l (_, Left e2) -> parseFail e2 t2 -- "graph 2 of " ++ l (Right gr1, Right gr2) -> gr1 @=? gr2 in TF.testCase ("example: " ++ l) ans -- | Check that the list of triples creates the output -- graph. It is intended for very-small graphs. -- checkFormat :: String -> [RDFTriple] -> T.Text -> TF.Test checkFormat lbl ts egr = let gr = toRDFGraph $ S.fromList ts ogr = formatGraphAsText gr in TF.testCase ("format: " ++ lbl) $ egr @=? ogr -- ********************************************* -- Examples from Turtle specification -- ********************************************* -- would be nice to read these in from external files -- | From . example1 :: T.Text example1 = T.unlines [ "@base ." , "@prefix rdf: ." , "@prefix rdfs: ." , "@prefix foaf: ." , "@prefix rel: ." , "" , "<#green-goblin>" , " rel:enemyOf <#spiderman> ;" , " a foaf:Person ; # in the context of the Marvel universe" , " foaf:name \"Green Goblin\" ." , "" , "<#spiderman>" , " rel:enemyOf <#green-goblin> ;" , " a foaf:Person ;" , " foaf:name \"Spiderman\", \"Человек-паук\"@ru ." ] result1 :: [RDFTriple] result1 = let greengoblin = toURI "http://example.org/#green-goblin" spiderman = toURI "http://example.org/#spiderman" enemyOf = toURI "http://www.perceive.net/schemas/relationship/enemyOf" ruName = LangLit "Человек-паук" "ru" in [ triple greengoblin enemyOf spiderman , triple greengoblin rdfType foafPerson , triple greengoblin foafname ("Green Goblin"::String) , triple spiderman enemyOf greengoblin , triple spiderman rdfType foafPerson , triple spiderman foafname ("Spiderman"::String) , triple spiderman foafname ruName ] -- | From . -- -- Unfortunately we do not support IRIs at this time. example2_4 :: T.Text example2_4 = T.unlines [ "# A triple with all absolute IRIs" , " ." , "" , "@base ." , " . # relative IRIs, e.g. http://one.example/subject2" , "" , "@prefix p: ." , "p:subject3 p:predicate3 p:object3 . # prefixed name, e.g. http://two.example/subject3" , "" , "@prefix p: . # prefix p: now stands for http://one.example/path/" , "p:subject4 p:predicate4 p:object4 . # prefixed name, e.g. http://one.example/path/subject4" , "" , "@prefix : . # empty prefix" , ":subject5 :predicate5 :object5 . # prefixed name, e.g. http://another.example/subject5" , "" , ":subject6 a :subject7 . # same as :subject6 :subject7 ." , "" , "# a :subject8 . # a multi-script subject IRI ." ] result2_4 :: [RDFTriple] result2_4 = let s1 = toURI "http://one.example/subject1" p1 = toURI "http://one.example/predicate1" o1 = toURI "http://one.example/object1" s2 = toURI "http://one.example/subject2" p2 = toURI "http://one.example/predicate2" o2 = toURI "http://one.example/object2" s3 = toURI "http://two.example/subject3" p3 = toURI "http://two.example/predicate3" o3 = toURI "http://two.example/object3" s4 = toURI "http://one.example/path/subject4" p4 = toURI "http://one.example/path/predicate4" o4 = toURI "http://one.example/path/object4" s5 = toURI "http://another.example/subject5" p5 = toURI "http://another.example/predicate5" o5 = toURI "http://another.example/object5" s6 = toURI "http://another.example/subject6" s7 = toURI "http://another.example/subject7" -- Replace once we support IRIs -- utf8 = toURI "http://伝言.example/?user=أكرم&channel=R%26D" -- s8 = toURI "http://another.example/subject8" in [ triple s1 p1 o1 , triple s2 p2 o2 , triple s3 p3 o3 , triple s4 p4 o4 , triple s5 p5 o5 , triple s6 rdfType s7 -- , triple utf8 rdfType s8 ] -- | From . -- -- *NOTE*: at present we do not match the document since untyped strings are -- *not* mapped to xsd:string. -- example2_5_1 :: T.Text example2_5_1 = T.unlines [ "@prefix rdfs: ." , "@prefix show: ." , "@prefix xsd: ." -- added to example , "" , "show:218 rdfs:label \"That Seventies Show\"^^xsd:string . # literal with XML Schema string datatype" , "show:218 rdfs:label \"That Seventies Show\"^^ . # same as above" , "show:218 rdfs:label \"That Seventies Show\" . # same again" , "show:218 show:localName \"That Seventies Show\"@en . # literal with a language tag" , "show:218 show:localName 'Cette Série des Années Soixante-dix'@fr . # literal delimited by single quote" , "show:218 show:localName \"Cette Série des Années Septante\"@fr-be . # literal with a region subtag" , "show:218 show:blurb '''This is a multi-line # literal with embedded new lines and quotes" , "literal with many quotes (\"\"\"\"\")" , "and up to two sequential apostrophes ('').''' ." ] result2_5_1 :: [RDFTriple] result2_5_1 = let show218 = toURI "http://example.org/vocab/show/218" localName = toURI "http://example.org/vocab/show/localName" blurb = toURI "http://example.org/vocab/show/blurb" -- Should be TypedLit v xsdString; once this happens then nameLit -- is not needed name = "That Seventies Show" nameLit = Lit name blurbLit = Lit "This is a multi-line # literal with embedded new lines and quotes\nliteral with many quotes (\"\"\"\"\")\nand up to two sequential apostrophes ('')." in [ triple show218 rdfsLabel (TypedLit name xsdString) , triple show218 rdfsLabel nameLit , triple show218 localName (LangLit name "en") , triple show218 localName (LangLit "Cette Série des Années Soixante-dix" "fr") , triple show218 localName (LangLit "Cette Série des Années Septante" "fr-be") , triple show218 blurb blurbLit ] -- | From . example2_5_2 :: T.Text example2_5_2 = T.unlines [ "@prefix : ." , " " , " :atomicNumber 2 ; # xsd:integer " , " :atomicMass 4.002602 ; # xsd:decimal " , " :specificGravity 1.663E-4 . # xsd:double" ] result2_5_2 :: [RDFTriple] result2_5_2 = let helium = toURI "http://en.wikipedia.org/wiki/Helium" aNum = toURI "http://example.org/elementsatomicNumber" aMass = toURI "http://example.org/elementsatomicMass" sGrav = toURI "http://example.org/elementsspecificGravity" in [ triple helium aNum (2::Int) , triple helium aMass (TypedLit "4.002602" xsdDecimal) -- , triple helium sGrav (1.663e-4::Double) , triple helium sGrav (TypedLit "1.663E-4" xsdDouble) ] -- | From . example2_5_3 :: T.Text example2_5_3 = T.unlines [ "@prefix : ." , "" , " :isLandlocked false . # xsd:boolean" ] result2_5_3 :: [RDFTriple] result2_5_3 = [ triple (toURI "http://somecountry.example/census2007") (toURI "http://example.org/statsisLandlocked") False ] -- | From . example2_6 :: T.Text example2_6 = T.unlines [ "@prefix foaf: ." , "" , "_:alice foaf:knows _:bob ." , "_:bob foaf:knows _:alice . " ] result2_6 :: [RDFTriple] result2_6 = let alice = Blank "one" bob = Blank "two" in [ triple alice foafknows bob , triple bob foafknows alice ] {- If you write out result2_6 you get @prefix foaf: . [ foaf:knows [ foaf:knows [] ] ] . which is :_a foaf:knows :_b :_b foaf:knows :_c which is obviously wrong -} -- | From . example2_7_a :: T.Text example2_7_a = T.unlines [ "@prefix foaf: ." , "" , "# Someone knows someone else, who has the name \"Bob\"." , "[] foaf:knows [ foaf:name \"Bob\" ] ." ] result2_7_a :: [RDFTriple] result2_7_a = let someone = Blank "p" bob = Blank "23" in [ triple someone foafknows bob , triple bob foafname (Lit "Bob") -- TODO: change to TypedLit ] {- --- Failure in: 0:6:1:"example: 2.7 a" expected: Graph, formulae: arcs: (_:23,foaf:name,"Bob") (_:p,foaf:knows,_:23) but got: Graph, formulae: arcs: (_:1,foaf:name,"Bob") (_:2,foaf:knows,_:3) Writing out as N3 and Turtle give different results, but not convinced round-tripping is sensible here, since reading back in the N3 version generates the invalid results above. % ./dist/build/Swish/Swish -i=delme2.ttl -n3 -o Swish 0.9.0.4 @prefix : <#> . @prefix foaf: . [ foaf:knows [ foaf:name "Bob" ] ] . % ./dist/build/Swish/Swish -i=delme2.ttl -ttl -o Swish 0.9.0.4 @prefix : <#> . @prefix foaf: . [] foaf:knows [ foaf:name "Bob" ] . Need to look at this to see what the difference is. -} -- | From . example2_7_b1 :: T.Text example2_7_b1 = T.unlines [ "@prefix foaf: ." , "" , "[ foaf:name \"Alice\" ] foaf:knows [" , " foaf:name \"Bob\" ;" , " foaf:knows [" , " foaf:name \"Eve\" ] ;" , " foaf:mbox ] ." ] -- | From . example2_7_b2 :: T.Text example2_7_b2 = T.unlines [ "_:a \"Alice\" ." , "_:a _:b ." , "_:b \"Bob\" ." , "_:b _:c ." , "_:c \"Eve\" ." , "_:b ." ] -- | From . example2_8 :: T.Text example2_8 = T.unlines [ "@prefix : ." , "# the object of this triple is the RDF collection blank node" , ":subject :predicate ( :a :b :c ) ." , "" , "# an empty collection value - rdf:nil" , ":subject :predicate2 () ." ] result2_8 :: [RDFTriple] result2_8 = let s = toURI "http://example.org/foosubject" p = toURI "http://example.org/foopredicate" p2 = toURI "http://example.org/foopredicate2" a = toURI "http://example.org/fooa" b = toURI "http://example.org/foob" c = toURI "http://example.org/fooc" l1 = Blank "l1" l2 = Blank "l2" l3 = Blank "l3" in [ triple s p l1 , triple l1 rdfFirst a , triple l1 rdfRest l2 , triple l2 rdfFirst b , triple l2 rdfRest l3 , triple l3 rdfFirst c , triple l3 rdfRest rdfNil , triple s p2 rdfNil ] -- | From . example3_a :: T.Text example3_a = T.unlines [ "@prefix rdf: ." , "@prefix dc: ." , "@prefix ex: ." , "" , "" , " dc:title \"RDF/XML Syntax Specification (Revised)\" ;" , " ex:editor [" , " ex:fullname \"Dave Beckett\";" , " ex:homePage " , " ] ." ] result3_a :: [RDFTriple] result3_a = let g = toURI "http://www.w3.org/TR/rdf-syntax-grammar" exEditor = toURI "http://example.org/stuff/1.0/editor" exFullName = toURI "http://example.org/stuff/1.0/fullname" exHomePage = toURI "http://example.org/stuff/1.0/homePage" bn = Blank "foo" -- "$123_" in [ triple g dcelemtitle (Lit "RDF/XML Syntax Specification (Revised)") , triple g exEditor bn , triple bn exFullName (Lit "Dave Beckett") , triple bn exHomePage (toURI "http://purl.org/net/dajobe/") ] -- | From . example3_b1 :: T.Text example3_b1 = T.unlines [ "@prefix : ." , ":a :b ( \"apple\" \"banana\" ) ." ] example3_b2 :: T.Text example3_b2 = T.unlines [ "@prefix : ." , "@prefix rdf: ." , ":a :b" , " [ rdf:first \"apple\";" , " rdf:rest [ rdf:first \"banana\";" , " rdf:rest rdf:nil ]" , " ] . " ] -- | From . example3_c1 :: T.Text example3_c1 = T.unlines [ "@prefix : ." , "" , ":a :b \"The first line\\nThe second line\\n more\" ." ] example3_c2 :: T.Text example3_c2 = T.unlines [ "@prefix : ." , "" -- line feeds using U+000A , ":a :b \"\"\"The first line" , "The second line" , " more\"\"\" ." ] -- | From . example3_d1 :: T.Text example3_d1 = T.unlines [ "@prefix : ." , "(1 2.0 3E1) :p \"w\" ." ] example3_d2 :: T.Text example3_d2 = T.unlines [ "@prefix rdf: ." , "@prefix : ." , "_:b0 rdf:first 1 ;" , " rdf:rest _:b1 ." , "_:b1 rdf:first 2.0 ;" , " rdf:rest _:b2 ." , "_:b2 rdf:first 3E1 ;" , " rdf:rest rdf:nil ." , "_:b0 :p \"w\" . " ] {- I do not see how this representation is valid, and rapper version 2.0.9 does not parse it (well, it reports the triples and then fails) so I am skipping this test. Am I mis-reading the test? See the discussion at http://lists.w3.org/Archives/Public/public-rdf-comments/2013May/0043.html which suggests that this is indeed invalid. -- | From . -- example3_e1 :: T.Text example3_e1 = T.unlines [ "@prefix : ." , "(1 [:p :q] ( 2 ) ) ." ] example3_e2 :: T.Text example3_e2 = T.unlines [ "@prefix rdf: ." , "@prefix : ." , " _:b0 rdf:first 1 ;" , " rdf:rest _:b1 ." , " _:b1 rdf:first _:b2 ." , " _:b2 :p :q ." , " _:b1 rdf:rest _:b3 ." , " _:b3 rdf:first _:b4 ." , " _:b4 rdf:first 2 ;" , " rdf:rest rdf:nil ." , " _:b3 rdf:rest rdf:nil ." ] -} -- | From . example7_4 :: T.Text example7_4 = T.unlines [ "@prefix ericFoaf: ." , "@prefix : ." , "ericFoaf:ericP :givenName \"Eric\" ;" , " :knows ," , " [ :mbox ] ," , " ." ] result7_4 :: [RDFTriple] result7_4 = let ericP = toURI "http://www.w3.org/People/Eric/ericP-foaf.rdf#ericP" db = toURI "http://norman.walsh.name/knows/who/dan-brickley" timbl = toURI "mailto:timbl@w3.org" amyvdh = toURI "http://getopenid.com/amyvdh" timbn = Blank "node" in [ triple ericP foafgivenName (Lit "Eric") , triple ericP foafknows db , triple ericP foafknows timbn , triple ericP foafknows amyvdh , triple timbn foafmbox timbl ] -- ********************************************* -- Set up test suites -- ********************************************* initialTestSuite :: TF.Test initialTestSuite = TF.testGroup "initial" [ compareExample "1" example1 result1 , compareExample "2.4" example2_4 result2_4 , compareExample "2.5.1" example2_5_1 result2_5_1 , compareExample "2.5.2" example2_5_2 result2_5_2 , compareExample "2.5.3" example2_5_3 result2_5_3 , compareExample "2.6" example2_6 result2_6 , compareExample "2.7 a" example2_7_a result2_7_a , compareGraphs "2.7 b" example2_7_b1 example2_7_b2 , compareExample "2.8" example2_8 result2_8 , compareExample "3 a" example3_a result3_a , compareGraphs "3 b" example3_b1 example3_b2 , compareGraphs "3 c" example3_c1 example3_c2 , compareGraphs "3 d" example3_d1 example3_d2 -- , compareGraphs "3 e" example3_e1 example3_e2 -- at present _e1 does not parse , compareExample "7.4" example7_4 result7_4 ] -- Cases to try and improve the test coverage urnA, urnB :: URI urnA = toURI "urn:a" urnB = toURI "urn:b" trips :: T.Text -> [RDFTriple] trips t = [triple urnA urnB (Lit t)] coverageCases :: TF.Test coverageCases = TF.testGroup "coverage" [ -- This was actually more a problem with output rather than input. compareExample "cov1" " \"' -D RT @madeupname: \\\"Foo \\u0024 Zone\\\" \\U0000007e:\\\"\\\"\\\"D\" ." (trips "' -D RT @madeupname: \"Foo $ Zone\" ~:\"\"\"D") , compareExample "cov2" " \"\"\"\"Bob \\\"\\uF481\"\"\"." (trips (T.snoc "\"Bob \"" (chr 0xf481))) {- rapper will parse this but I do not think it matches the Turtle grammar , compareExample "cov2-option" " \"\"\"\"Bob \"\\U0001F481\"\"\"" (trips "\"Bob \"\\U0001F481") -} , compareExample "cov3-1" " \"\"\"\\\"A quoted string.\\\"\"\"\"." (trips "\"A quoted string.\"") , compareExample "cov3-2" " \"\"\"\\\"\\\"A quoted string.\\\"\"\"\"." (trips "\"\"A quoted string.\"") , compareExample "cov3-3" " \"\"\"\\\"A quoted string.\\\"\\\"\"\"\"." (trips "\"A quoted string.\"\"") , compareExample "cov4" " \"3\\\\8\\\\11\" ." (trips "3\\8\\11") , checkFormat "\\f" (trips "A\ffB") "@prefix : .\n \"A\\u000CfB\" .\n" ] -- Extracted from failures seen when using the W3C test suite -- at . lt1T :: T.Text lt1T = " \"\"\"A long string. \"\"\"@en-UK ." lt1A :: [RDFTriple] lt1A = [ triple (toURI "urn:a") (toURI "urn:b") (LangLit "A long string. " "en-UK") ] le1T :: T.Text le1T = "@prefix : . :c\\~d." le1A :: [RDFTriple] le1A = [ triple (toURI "urn:a") (toURI "urn:b:") (toURI "urn:example/c~d") ] w3cCases :: TF.Test w3cCases = TF.testGroup "w3c" [ compareExample "lang-tag1" lt1T lt1A , compareExample "localEscapes" le1T le1A ] -- allTests :: [TF.Test] allTests = [ initialTestSuite , coverageCases , w3cCases ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/NTTest.hs0000644000000000000000000003345613543702315014152 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : NTTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedString -- -- This Module contains test cases for the NTriples parsing and formatting modules. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Set as S import qualified Data.Text.Lazy as T import qualified Test.Framework as TF import qualified Test.Framework.Providers.HUnit as TF import Swish.GraphClass (arc) import Swish.RDF.Parser.NTriples (parseNT) import Swish.RDF.Formatter.NTriples (formatGraphAsLazyText) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) , emptyRDFGraph , toRDFGraph ) import Swish.RDF.Vocabulary (toLangTag, rdfXMLLiteral) import Test.HUnit ( Test(TestCase,TestList) , (@=?) , assertEqual ) import Data.Maybe (fromJust) import TestHelpers (conv) ------------------------------------------------------------ -- Parser tests ------------------------------------------------------------ -- check that parsing the input creates the expected graph checkGraph :: String -> T.Text -> RDFGraph -> Test checkGraph lab inp gr = TestList [ TestCase ( assertEqual ("parse-failed:"++lab) noError pe ) , TestCase ( assertEqual ("parse-result:"++lab) gr pg ) ] where (pe,pg) = case parseNT inp of Right g -> (noError, g) Left s -> (s, emptyRDFGraph) noError :: String noError = "" -- | Take the input graph and parse it (the first -- graph), then convert this back to text and parse -- the result, to give the second graph. The -- two strings are the errors from the parses, -- if any. doRoundTrip :: T.Text -> (RDFGraph, RDFGraph, String, String) doRoundTrip inp = let (pErr1, pGr1) = case parseNT inp of Right g -> (noError, g) Left s -> (s, emptyRDFGraph) inp2 = formatGraphAsLazyText pGr1 (pErr2, pGr2) = case parseNT inp2 of Right g -> (noError, g) Left s -> (s, emptyRDFGraph) in (pGr1, pGr2, pErr1, pErr2) -- check that the -- parseNT input == parseNT (formatGraph (parse NT input)) -- roundTrip :: String -> T.Text -> Test roundTrip lbl inp = let (pGr1, pGr2, pErr1, pErr2) = doRoundTrip inp in TestList [ TestCase (assertEqual ("roundTrip-parsing1:"++lbl) noError pErr1) , TestCase (assertEqual ("roundTrip-parsing2:"++lbl) noError pErr2) , TestCase (assertEqual ("roundTrip-graph:"++lbl) pGr1 pGr2) ] roundTripTF :: String -> T.Text -> TF.Test roundTripTF lbl inp = let (pGr1, pGr2, pErr1, pErr2) = doRoundTrip inp in TF.testGroup ("roundTrip:" ++ lbl) [ TF.testCase "parsing1" (noError @=? pErr1) , TF.testCase "parsing2" (noError @=? pErr2) , TF.testCase "graph" (pGr1 @=? pGr2) ] ------------------------------------------------------------ -- Rather than bother with locating an external file, -- include it directly. -- -- This is the contents of -- http://www.w3.org/2000/10/rdf-tests/rdfcore/ntriples/test.nt -- retrieved on 2011-03-23 11:25:46 -- ------------------------------------------------------------ w3cTest :: T.Text w3cTest = "#\n# Copyright World Wide Web Consortium, (Massachusetts Institute of\n# Technology, Institut National de Recherche en Informatique et en\n# Automatique, Keio University).\n#\n# All Rights Reserved.\n#\n# Please see the full Copyright clause at\n# \n#\n# Test file with a variety of legal N-Triples\n#\n# Dave Beckett - http://purl.org/net/dajobe/\n# \n# $Id: test.nt,v 1.7 2003/10/06 15:52:19 dbeckett2 Exp $\n# \n#####################################################################\n\n# comment lines\n \t \t # comment line after whitespace\n# empty blank line, then one with spaces and tabs\n\n \t\n .\n_:anon .\n _:anon .\n# spaces and tabs throughout:\n \t \t \t \t.\t \n\n# line ending with CR NL (ASCII 13, ASCII 10)\n .\r\n\n# 2 statement lines separated by single CR (ASCII 10)\n .\r .\n\n\n# All literal escapes\n \"simple literal\" .\n \"backslash:\\\\\" .\n \"dquote:\\\"\" .\n \"newline:\\n\" .\n \"return\\r\" .\n \"tab:\\t\" .\n\n# Space is optional before final .\n .\n \"x\".\n _:anon.\n\n# \\u and \\U escapes\n# latin small letter e with acute symbol \\u00E9 - 3 UTF-8 bytes #xC3 #A9\n \"\\u00E9\" .\n# Euro symbol \\u20ac - 3 UTF-8 bytes #xE2 #x82 #xAC\n \"\\u20AC\" .\n# resource18 test removed\n# resource19 test removed\n# resource20 test removed\n\n# XML Literals as Datatyped Literals\n \"\"^^ .\n \" \"^^ .\n \"x\"^^ .\n \"\\\"\"^^ .\n \"\"^^ .\n \"a \"^^ .\n \"a c\"^^ .\n \"a\\n\\nc\"^^ .\n \"chat\"^^ .\n# resource28 test removed 2003-08-03\n# resource29 test removed 2003-08-03\n\n# Plain literals with languages\n \"chat\"@fr .\n \"chat\"@en .\n\n# Typed Literals\n \"abc\"^^ .\n# resource33 test removed 2003-08-03\n" ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ s1, p1, p2, o1 :: RDFLabel s1 = Res "urn:b#s1" -- rely on IsString to convert to ScopedName p1 = Res "urn:b#p1" p2 = Res "http://example.com/pred2" o1 = Res "urn:b#o1" {- s1 = Res $ makeURIScopedName "urn:b#s1" p1 = Res $ makeURIScopedName "urn:b#p1" p2 = Res $ makeURIScopedName "http://example.com/pred2" o1 = Res $ makeURIScopedName "urn:b#o1" -} l0, l1, l2, l3, l4 :: RDFLabel 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 = 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" b2 = Blank "genid23" ------------------------------------------------------------ -- Construct graphs for testing ------------------------------------------------------------ g0 :: RDFGraph g0 = toRDFGraph S.empty mkGr1 :: RDFLabel -> RDFLabel -> RDFLabel -> RDFGraph mkGr1 s p o = toRDFGraph $ S.singleton $ arc s p o g1, g2, g3, g4, g5, g6, g7, g8, g9, g10, g11, g12 :: RDFGraph g1 = mkGr1 s1 p1 o1 g2 = mkGr1 s1 p1 l0 g3 = mkGr1 s1 p1 l1 g4 = mkGr1 s1 p1 l2 g5 = mkGr1 s1 p1 l3 g6 = mkGr1 s1 p1 lfr g7 = mkGr1 s1 p1 lgben g8 = mkGr1 s1 p1 lxml1 g9 = mkGr1 s1 p1 lxml2 g10 = mkGr1 s1 p1 b1 g11 = mkGr1 b2 p1 b1 g12 = mkGr1 s1 p1 l4 gm1 :: RDFGraph gm1 = toRDFGraph $ S.fromList [arc b2 p2 b1, arc b2 p1 o1] ------------------------------------------------------------ -- Input documents ------------------------------------------------------------ empty1, empty2, empty3, empty4, empty5 :: T.Text {- empty3 and empty4 are not valid NTriple documents since they do not end with a \n, but we support this for now. -} empty1 = "" empty2 = "\n" empty3 = " \n " empty4 = "# a comment" empty5 = "\n # a comment\n " graph1, graph2, graph3, graph4, graph5, graph6, graph7, graph8, graph9, graph10, graph11, graph12 :: T.Text graph1 = " ." graph2 = " \"\"." graph3 = " \"l1\" . " graph4 = " \"l2-'\\\"line1\\\"'\\n\\nl2-'\\\"\\\"line2\\\"\\\"'\"." graph5 = " \"l3--\\r\\\"'\\\\--\\u0020&--\\U0000017A&--\" ." graph6 = " \"chat\"@fr." graph7 = " \"football\"@en-gb . " graph8 = " \"
\"^^." graph9 = " \"chat\"^^." graph10 = " _:x1 . " graph11 = "_:genid23 _:x1 . " graph12 = " \"l4 \\\\\" ." graphm1, graphm1r :: T.Text graphm1 = "_:genid23 .\n\n # test \n_:genid23 _:x1 .\n\n" graphm1r = "_:genid23 _:x1.\n_:genid23 .\n" ------------------------------------------------------------ -- Parser tests ------------------------------------------------------------ rTests :: Test rTests = TestList [ roundTrip "empty1" empty1 , roundTrip "empty2" empty2 , roundTrip "empty3" empty3 , roundTrip "empty4" empty4 , roundTrip "empty5" empty5 , roundTrip "graph1" graph1 , roundTrip "graph2" graph2 , roundTrip "graph3" graph3 , roundTrip "graph4" graph4 , roundTrip "graph5" graph5 , roundTrip "graph6" graph6 , roundTrip "graph7" graph7 , roundTrip "graph8" graph8 , roundTrip "graph9" graph9 , roundTrip "graph10" graph10 , roundTrip "graph11" graph11 , roundTrip "graph12" graph12 , roundTrip "graphm1" graphm1 , roundTrip "graphm1r" graphm1r , roundTrip "W3C test" w3cTest ] eTests :: Test eTests = TestList [ checkGraph "empty1" empty1 g0 , checkGraph "empty2" empty2 g0 , checkGraph "empty3" empty3 g0 , checkGraph "empty4" empty4 g0 , checkGraph "empty5" empty5 g0 ] gTests :: Test gTests = TestList [ checkGraph "graph1" graph1 g1 , checkGraph "graph2" graph2 g2 , checkGraph "graph3" graph3 g3 , checkGraph "graph4" graph4 g4 , checkGraph "graph5" graph5 g5 , checkGraph "graph6" graph6 g6 , checkGraph "graph7" graph7 g7 , checkGraph "graph8" graph8 g8 , checkGraph "graph9" graph9 g9 , checkGraph "graph10" graph10 g10 , checkGraph "graph11" graph11 g11 , checkGraph "graph12" graph12 g12 , checkGraph "graphm1" graphm1 gm1 , checkGraph "graphm1r" graphm1r gm1 ] allTests :: [TF.Test] allTests = [ conv "r" rTests , conv "e" eTests , conv "g" gTests , roundTripTF "langtag" " \"Foo .\"@en-UK." ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/GraphTest.hs0000644000000000000000000016122413543702315014665 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013, 2014 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -- This module defines test cases for module Graph. -- -------------------------------------------------------------------------------- module Main where import qualified Data.Foldable as F import qualified Data.Map as M import qualified Data.Set as S import qualified Test.Framework as TF import qualified Test.Framework.Providers.HUnit as TF import Swish.GraphClass (Arc(..), ArcSet, LDGraph(..), Label(..)) import Swish.GraphClass (arc, arcFromTriple, arcToTriple) import Swish.GraphMem import Swish.GraphMatch ( LabelMap, GenLabelMap(..), EquivalenceClass, ScopedLabel(..), makeScopedLabel, makeScopedArc, LabelIndex, nullLabelVal, emptyMap, mapLabelIndex, {-mapLabelList,-} setLabelHash, newLabelMap, graphLabels, assignLabelMap, newGenerationMap -- graphMatch1 only used with pairSort , equivalenceClasses ) -- import Swish.Utils.ListHelpers (subset) import Data.Function (on) import Data.Hashable (hashWithSalt) import Data.List (sort, sortBy, elemIndex) import Data.Maybe (fromJust) import Data.Ord (comparing) import Data.Word (Word32) import Test.HUnit ( Test(TestCase,TestList,TestLabel) , (@=?) , assertEqual, assertBool ) import TestHelpers (conv, testEq, testNe) default ( Int ) ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ type Statement = Arc LabelMem base1, base2, base3, base4 :: String base1 = "http://id.ninebynine.org/wip/2003/test/graph1/node#" base2 = "http://id.ninebynine.org/wip/2003/test/graph2/node/" base3 = "http://id.ninebynine.org/wip/2003/test/graph3/node" base4 = "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" ------------------------------------------------------------ -- Set, get graph arcs as sets of triples ------------------------------------------------------------ setArcsT :: (Ord lb, LDGraph lg lb) => S.Set (lb, lb, lb) -> lg lb -> lg lb setArcsT a g = setArcs g $ S.map arcFromTriple a getArcsT :: (Ord lb, LDGraph lg lb) => lg lb -> S.Set (lb, lb, lb) getArcsT g = S.map arcToTriple $ getArcs g ------------------------------------------------------------ -- Label map and entry creation helpers ------------------------------------------------------------ tstLabelMap :: (Label lb) => Word32 -> [(lb,LabelIndex)] -> LabelMap lb tstLabelMap gen = LabelMap gen . M.fromList ------------------------------------------------------------ -- Graph helper function tests ------------------------------------------------------------ {- -- 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 ) isOne :: Int -> Bool isOne = (1 ==) testSelect01, testSelect02, testSelect03, testSelect04 :: Test testSelect01 = testSelect "01" (select isOne [0,1,2,0,1,2] "abcabc") "bb" testSelect02 = testSelect "02" (select isOne [1,1,1,1,1,1] "abcabc") "abcabc" testSelect03 = testSelect "03" (select isOne [0,0,0,0,0,0] "abcabc") [] testSelect04 = testSelect "04" (select isOne [] [] ) [] testSelectSuite :: Test testSelectSuite = TestList [ testSelect01, testSelect02, testSelect03, testSelect04 ] -} -- subset: hopefully can remove soon {- testSubset :: String -> Bool -> [Int] -> [Int] -> Test testSubset lab res l1s l2s = testEq ("Mapset"++lab ) res (l1s `subset` l2s) testSubsetSuite :: Test testSubsetSuite = TestList [ testSubset "01" True [1,2,3] [0,1,2,3,4,5] , testSubset "02" True [5,3,1] [0,1,2,3,4,5] , testSubset "03" True [5,4,3,2,1,0] [0,1,2,3,4,5] , testSubset "04" True [] [] , testSubset "05" False [0,1,2,3,4,5] [1,2,3] , testSubset "06" False [0,1,2,3,4,5] [5,3,1] , testSubset "07" True [] [1,2,3] , testSubset "08" False [1,2,3] [] ] -} ------------------------------------------------------------ -- Simple graph label tests ------------------------------------------------------------ testLabSuite :: Test testLabSuite = TestList [ testEq "Lab01" False (labelIsVar lab1f) , testEq "Lab02" True (labelIsVar lab1v) , testEq "Lab03" False (labelIsVar lab2f) , testEq "Lab04" True (labelIsVar lab2v) {- This just tests the hash routine, which doesn't really tell us that much, so replace by checks that the hashes aren't the same , testEq "Lab05" 39495998 (labelHash 1 lab1f) , testEq "Lab06" 45349309 (labelHash 1 lab1v) , testEq "Lab07" 39495997 (labelHash 1 lab2f) , testEq "Lab08" 45349310 (labelHash 1 lab2v) -} , testNe "Hash Lab05/6" (labelHash 1 lab1f) (labelHash 1 lab1v) , testNe "Hash Lab05/7" (labelHash 1 lab1f) (labelHash 1 lab2f) , testNe "Hash Lab06/8" (labelHash 1 lab1v) (labelHash 1 lab2v) , testNe "Hash Lab07/8" (labelHash 1 lab2f) (labelHash 1 lab2v) , testNe "Hash Lab05/8" (labelHash 1 lab1f) (labelHash 1 lab2v) , testNe "Hash Lab06/7" (labelHash 1 lab1v) (labelHash 1 lab2f) , testEq "Lab09" "!lab1" (show lab1f) , testEq "Lab10" "?lab1" (show lab1v) , testEq "Lab11" "!lab2" (show lab2f) , testEq "Lab12" "?lab2" (show lab2v) , testEq "Lab13" "lab1" (getLocal lab1v) , testEq "Lab14" "lab2" (getLocal lab2v) , testEq "Lab15" lab1v (makeLabel "lab1") , testEq "Lab16" lab2v (makeLabel "lab2") ] ------------------------------------------------------------ -- Simple graph tests ------------------------------------------------------------ lab1f, lab1v, lab2f, lab2v :: LabelMem lab1f = LF "lab1" lab1v = LV "lab1" lab2f = LF "lab2" lab2v = LV "lab2" ga1 :: S.Set (LabelMem, LabelMem, LabelMem) ga1 = S.fromList [ (lab1f,lab1f,lab1f), (lab1v,lab1v,lab1v), (lab2f,lab2f,lab2f), (lab2v,lab2v,lab2v), (lab1f,lab1f,lab1v), (lab1f,lab1f,lab2f), (lab1f,lab1f,lab2v), (lab1v,lab1v,lab1f), (lab1v,lab1v,lab2f), (lab1v,lab1v,lab2v), (lab1f,lab1v,lab2f), (lab1f,lab1v,lab2v), (lab1v,lab2f,lab2v) ] gs4 :: Statement -> Bool gs4 (Arc _ _ (LV "lab2")) = True gs4 _ = False ga4 :: S.Set (LabelMem, LabelMem, LabelMem) ga4 = S.fromList [ (lab2v,lab2v,lab2v), (lab1f,lab1f,lab2v), (lab1v,lab1v,lab2v), (lab1f,lab1v,lab2v), (lab1v,lab2f,lab2v) ] ga2 :: S.Set (LabelMem, LabelMem, LabelMem) ga2 = S.fromList [ (lab1f,lab1f,lab1f), (lab1v,lab1v,lab1v), (lab2f,lab2f,lab2f), (lab2v,lab2v,lab2v) ] ga3 :: S.Set (LabelMem, LabelMem, LabelMem) ga3 = S.fromList [ (lab1f,lab1f,lab1v), (lab1f,lab1f,lab2f), (lab1f,lab1f,lab2v), (lab1v,lab1v,lab1f), (lab1v,lab1v,lab2f), (lab1v,lab1v,lab2v), (lab1f,lab1v,lab2f), (lab1f,lab1v,lab2v), (lab1v,lab2f,lab2v) ] gl4 :: S.Set LabelMem gl4 = S.fromList [lab1f,lab1v,lab2f,lab2v] gr1a, gr2a, gr3a, gr4a, gr4b, gr4c, gr4d, gr4e, gr4g :: GraphMem LabelMem gr1a = setArcsT ga1 (GraphMem S.empty) gr2a = setArcsT ga2 emptyGraph gr3a = setArcsT ga3 emptyGraph gr4a = addGraphs gr2a gr3a gr4b = addGraphs gr3a gr2a gr4c = delete gr2a gr4a gr4d = delete gr3a gr4a gr4e = extract gs4 gr4a gr4g = addGraphs gr2a gr4a gl4f :: S.Set LabelMem gl4f = labels gr4a {- gr4ee :: [Bool] gr4ee = map gs4 $ S.toList (getArcs gr4a) -} testGraphSuite :: Test testGraphSuite = TestList [ testEq "Graph01" ga1 (getArcsT gr1a) , testEq "Graph01" ga2 (getArcsT gr2a) , testEq "Graph03" ga3 (getArcsT gr3a) , testEq "Graph04" ga1 (getArcsT gr4a) , testEq "Graph05" ga1 (getArcsT gr4b) , testEq "Graph06" ga3 (getArcsT gr4c) , testEq "Graph07" ga2 (getArcsT gr4d) , testEq "Graph08" ga4 (getArcsT gr4e) , testEq "Graph09" gl4 gl4f , testEq "Graph10" ga1 (getArcsT gr4g) ] ------------------------------------------------------------ -- ------------------------------------------------------------ ------------------------------------------------------------ -- Define some common values ------------------------------------------------------------ s1, s2, s3, s4, s5, s6, s7, s8 :: LabelMem s1 = LF "s1" s2 = LF "s2" s3 = LF "s3" s4 = LF "" s5 = LV "s5" s6 = LF "basemore" s7 = LF ("base"++"more") s8 = LV "s8" b1, b2, b3, b4 :: LabelMem b1 = LV "b1" b2 = LV "b2" b3 = LV "b3" b4 = LV "b4" p1, p2, p3, p4 :: LabelMem p1 = LF "p1" p2 = LF "p2" p3 = LF "p3" p4 = LF "p4" o1, o2, o3, o4, o5, o6 :: LabelMem o1 = LF "o1" o2 = LF "o2" o3 = LF "o3" o4 = LF "" o5 = LV "o5" o6 = LV "s5" l1, l2, l3, l4, l5, l6, l7, l8, l9, l10, l11, l12 :: LabelMem l1 = LF "l1" l2 = LF "l2-en" l3 = LF "l2-fr" l4 = LF "l4-type1" l5 = LF "l4-type1" l6 = LF "l4-type1" l7 = LF "l4-type2" l8 = LF "l4-type2" l9 = LF "l4-type2" l10 = LF "l10-xml" l11 = LF "l10-xml-en" l12 = LF "l10-xml-fr" v1, v2, v3, v4 :: LabelMem v1 = LV "v1" v2 = LV "v2" v3 = LV "v3" v4 = LV "v4" ------------------------------------------------------------ -- Label construction and equality tests ------------------------------------------------------------ testLabelEq :: String -> Bool -> LabelMem -> LabelMem -> Test testLabelEq lab eq n1 n2 = TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) nodelist :: [(String, LabelMem)] nodelist = [ ("s1",s1), ("s2",s2), ("s3",s3), ("s4",s4), ("s5",s5), ("s6",s6), ("s7",s7), ("s8",s8), ("o5",o5), ("p1",p1), ("p2",p2), ("p3",p3), ("p4",p4), ("o1",o1), ("o2",o2), ("o3",o3), ("o4",o4), ("l1",l1), ("l2",l2), ("l3",l3), ("l4",l4), ("l5",l5), ("l6",l6), ("l7",l7), ("l8",l8), ("l9",l9), ("l10",l10), ("l11",l11), ("l12",l12), ("v1",v1), ("v2",v2) ] nodeeqlist :: [(String, String)] nodeeqlist = [ ("s4","o4"), ("s5","o6"), ("s6","s7"), ("l4","l5"), ("l4","l6"), ("l5","l6"), ("l7","l8"), ("l7","l9"), ("l8","l9") ] testLabelEqSuite :: Test testLabelEqSuite = TestList [ testLabelEq (testLab a b) (nodeTest a b) n1 n2 | (a,n1) <- nodelist , (b,n2) <- nodelist ] where testLab a b = a ++ "-" ++ b nodeTest a b = (a == b) || (a,b) `elem` nodeeqlist || (b,a) `elem` nodeeqlist ------------------------------------------------------------ -- Label ordering tests ------------------------------------------------------------ testLabelOrd :: String -> Ordering -> LabelMem -> LabelMem -> Test testLabelOrd lab order n1 n2 = TestCase ( assertEqual ("testLabelOrd:"++lab) order (compare n1 n2) ) nodeorder :: [String] nodeorder = [ "o4", "s4", "s6", "s7", "l1", "l10", "l11", "l12", "l2", "l3", "l4", "l5", "l6", "l7", "l8", "l9", "o1", "o2", "o3", "p1", "p2", "p3", "p4", "s1", "s2", "s3", "b1", "b2", "b3", "b4", "o5", "s5", "s8", "v1", "v2" ] testLabelOrdSuite :: Test testLabelOrdSuite = TestList [ testLabelOrd (testLab a b) (testOrd a b) n1 n2 | (a,n1) <- nodelist , (b,n2) <- nodelist ] where testLab a b = a ++ "-" ++ b testOrd a b | nodeTest a b = EQ | otherwise = comparing fromJust (elemIndex a nodeorder) (elemIndex b nodeorder) nodeTest a b = (a == b) || (a,b) `elem` nodeeqlist || (b,a) `elem` nodeeqlist ------------------------------------------------------------ -- Statement construction and equality tests ------------------------------------------------------------ testStmtEq :: String -> Bool -> Statement -> Statement -> Test testStmtEq lab eq t1 t2 = TestCase ( assertEqual ("testStmtEq:"++lab) eq (t1==t2) ) -- String argument is no longer needed, due to refactoring of -- tlist, but left in -- slist :: [(String, LabelMem)] slist = [ ("s1",s1), ("s4",s4), ("s5",s5), ("s6",s6), ("s7",s7) ] plist :: [(String, LabelMem)] plist = [ ("p1",p1) ] olist :: [(String, LabelMem)] olist = [ ("o1",o1), ("o4",o4), ("o5",o5), ("l1",l1), ("l4",l4), ("l7",l7), ("l8",l8), ("l10",l10) ] tlist :: [(String, Statement)] tlist = [ t s p o | (_,s) <- slist, (_,p) <- plist, (_,o) <- olist ] where t s p o = let a = Arc s p o in (show a, a) stmteqlist :: [(String, String)] stmteqlist = [ ("(s6,p1,l1)", "(s7,p1,l1)"), ("(s6,p1,l4)", "(s7,p1,l4)"), ("(s6,p1,l7)", "(s7,p1,l7)"), ("(s6,p1,l7)", "(s7,p1,l8)"), ("(s6,p1,l8)", "(s7,p1,l7)"), ("(s6,p1,l8)", "(s7,p1,l8)"), ("(s6,p1,l10)","(s7,p1,l10)"), ("(s6,p1,o1)", "(s7,p1,o1)"), ("(s6,p1,o4)", "(s7,p1,o4)"), ("(s6,p1,o5)", "(s7,p1,o5)"), ("(s1,p1,l7)", "(s1,p1,l8)"), ("(s4,p1,l7)", "(s4,p1,l8)"), ("(s5,p1,l7)", "(s5,p1,l8)"), ("(s6,p1,l7)", "(s6,p1,l8)"), ("(s7,p1,l7)", "(s7,p1,l8)") ] testStmtEqSuite :: Test testStmtEqSuite = TestList [ testStmtEq (testLab a b) (nodeTest a b) t1 t2 | (a,t1) <- tlist , (b,t2) <- tlist ] where testLab a b = a ++ "-" ++ b nodeTest a b = (a == b) || (a,b) `elem` stmteqlist || (b,a) `elem` stmteqlist ------------------------------------------------------------ -- Graph element handling support routines ------------------------------------------------------------ lmap :: LabelMap LabelMem lmap = tstLabelMap 5 [(s1,(1,1)),(s2,(2,2)),(s3,(3,3)),(s4,(4,4)), (o1,(1,1)),(o2,(2,2)),(o3,(3,3))] -- setLabelHash :: (Label lb) => LabelMap lb -> (lb,Int) -> LabelMap lb lmap1, lmap2a, lmap2b, lmap3 :: LabelMap LabelMem lmap1 = setLabelHash lmap (s2,22) lmap2a = setLabelHash lmap1 (o1,66) lmap2b = setLabelHash lmap2a (o5,67) -- newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb lmap3 = newLabelMap lmap [(s1,61),(s3,63),(o2,66)] llst :: [String] llst = ["s1","s2","s3","s4","o1","o2","o3"] -- showLabelMap :: (Label lb) => LabelMap lb -> String testShowLabelMap :: Test testShowLabelMap = testEq "showLabelMap" showMap (show lmap) where showMap = "LabelMap gen=5, map=\n"++ " (!,(4,4))\n"++ " (!o1,(1,1))\n"++ " (!o2,(2,2))\n"++ " (!o3,(3,3))\n"++ " (!s1,(1,1))\n"++ " (!s2,(2,2))\n"++ " (!s3,(3,3))" testMapLabelHash00 :: Test testMapLabelHash00 = testEq "mapLabelHash00" showMap (show lmap1) where showMap = "LabelMap gen=5, map=\n"++ " (!,(4,4))\n"++ " (!o1,(1,1))\n"++ " (!o2,(2,2))\n"++ " (!o3,(3,3))\n"++ " (!s1,(1,1))\n"++ " (!s2,(5,22))\n"++ " (!s3,(3,3))" -- mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex testLabelMapSuite :: Test testLabelMapSuite = TestList [ testShowLabelMap , testMapLabelHash00 , testEq "testMapLabelIndex01" (1,1) (mapLabelIndex lmap s1 ) , testEq "testMapLabelIndex02" (2,2) (mapLabelIndex lmap s2 ) , testEq "testMapLabelIndex03" (3,3) (mapLabelIndex lmap s3 ) , testEq "testMapLabelIndex04" (4,4) (mapLabelIndex lmap s4 ) , testEq "testMapLabelIndex05" (1,1) (mapLabelIndex lmap o1 ) , testEq "testMapLabelIndex06" (4,4) (mapLabelIndex lmap o4 ) , testEq "testMapLabelIndex07" nullLabelVal (mapLabelIndex lmap o5 ) , testEq "testMapLabelIndex08" nullLabelVal (mapLabelIndex lmap o6 ) , testEq "MapLabelHash01" (1,1) (mapLabelIndex lmap1 s1 ) , testEq "MapLabelHash02" (5,22) (mapLabelIndex lmap1 s2 ) , testEq "MapLabelHash03" (3,3) (mapLabelIndex lmap1 s3 ) , testEq "MapLabelHash04" (4,4) (mapLabelIndex lmap1 s4 ) , testEq "MapLabelHash05" (1,1) (mapLabelIndex lmap1 o1 ) , testEq "MapLabelHash06" (4,4) (mapLabelIndex lmap1 o4 ) , testEq "MapLabelHash07" nullLabelVal (mapLabelIndex lmap1 o5 ) , testEq "MapLabelHash08" nullLabelVal (mapLabelIndex lmap1 o6 ) , testEq "MapLabelHash11" (1,1) (mapLabelIndex lmap2b s1 ) , testEq "MapLabelHash12" (5,22) (mapLabelIndex lmap2b s2 ) , testEq "MapLabelHash13" (3,3) (mapLabelIndex lmap2b s3 ) , testEq "MapLabelHash14" (4,4) (mapLabelIndex lmap2b s4 ) , testEq "MapLabelHash15" (5,66) (mapLabelIndex lmap2b o1 ) , testEq "MapLabelHash16" (2,2) (mapLabelIndex lmap2b o2 ) , testEq "MapLabelHash17" (4,4) (mapLabelIndex lmap2b o4 ) , testEq "MapLabelHash18" nullLabelVal (mapLabelIndex lmap1 o5 ) , testEq "LabelMap01" (6,61) (mapLabelIndex lmap3 s1 ) , testEq "LabelMap02" (2,2) (mapLabelIndex lmap3 s2 ) , testEq "LabelMap03" (6,63) (mapLabelIndex lmap3 s3 ) , testEq "LabelMap04" (4,4) (mapLabelIndex lmap3 s4 ) , testEq "LabelMap05" (1,1) (mapLabelIndex lmap3 o1 ) , testEq "LabelMap06" (6,66) (mapLabelIndex lmap3 o2 ) ] ------------------------------------------------------------ -- Graph matching support ------------------------------------------------------------ t01, t02, t03, t04, t05, t06 :: Statement t01 = arc s1 p1 o1 t02 = arc s2 p1 o2 t03 = arc s3 p1 o3 t04 = arc s1 p1 l1 t05 = arc s2 p1 l4 t06 = arc s3 p1 l10 tOrder16 :: [Statement] tOrder16 = [t04, t01, t05, t02, t06, t03] t10, t11, t12 :: Statement t10 = arc s1 p1 b1 t11 = arc b1 p2 b2 t12 = arc b2 p3 o1 t20, t21, t22 :: Statement t20 = arc s1 p1 b3 t21 = arc b3 p2 b4 t22 = arc b4 p3 o1 as1, as2, as4, as5, as6 :: S.Set Statement as1 = S.singleton t01 as2 = S.fromList [t01,t02,t03,t04,t05,t06] as4 = S.fromList [t01,t02,t03,t04,t05,t06,t10,t11,t12] as5 = S.fromList [t01,t02,t03,t04,t05,t06,t20,t21,t22] as6 = S.fromList [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] -- graphLabels :: (Label lb) => ArcSet lb -> S.Set lb -- not clear both the 'raw' and 'string' versions are still needed. ls4, glas4 :: S.Set LabelMem ls4 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2] glas4 = graphLabels as4 testGraphLabels04, testGraphLabels14 :: Test testGraphLabels04 = testEq "GraphLabels04" ls4 glas4 testGraphLabels14 = testEq "GraphLabels14" str (show glas4) where -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3]" str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b1,?b2]" -- str = show ls4 ls5, glas5 :: S.Set LabelMem ls5 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b3,b4] glas5 = graphLabels as5 testGraphLabels05, testGraphLabels15 :: Test testGraphLabels05 = testEq "GraphLabels05" ls5 glas5 testGraphLabels15 = testEq "GraphLabels15" str (show glas5) where -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b3,!p2,?b4,!p3]" str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b3,?b4]" -- str = show ls5 ls6, glas6 :: S.Set LabelMem ls6 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2,b3,b4] glas6 = graphLabels as6 testGraphLabels06, testGraphLabels16 :: Test testGraphLabels06 = testEq "GraphLabels05" ls6 glas6 testGraphLabels16 = testEq "GraphLabels16" str (show glas6) where -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3"++ -- ",!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3,?b3,?b4]" str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b1,?b2,?b3,?b4]" -- str = show ls6 -- assignLabels :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb bhash :: Word32 -- bhash = 23 -- before trying to support Hashable 1.2.0 bhash = fromIntegral (23 `hashWithSalt` (0::Word32)) -- since the hashing is now done by hashable, is it worth checking -- the hash values directly? It would perhaps be better to just -- quickcheck that values get sorted. -- copy of internal code in GraphMatch toHash :: (Label lb) => Word32 -> lb -> Word32 toHash s lbl = fromIntegral $ if labelIsVar lbl then 23 `hashWithSalt` s else labelHash (fromIntegral s) lbl l1hash, l4hash, l10hash :: Word32 l1hash = toHash 0 l1 l4hash = toHash 0 l4 l10hash = toHash 0 l10 l1hash2, l4hash2, l10hash2 :: Word32 l1hash2 = l1hash l4hash2 = l4hash l10hash2 = l10hash o1hash, o2hash, o3hash :: Word32 o1hash = toHash 0 o1 o2hash = toHash 0 o2 o3hash = toHash 0 o3 p1hash, p2hash, p3hash :: Word32 p1hash = toHash 0 p1 p2hash = toHash 0 p2 p3hash = toHash 0 p3 s1hash, s2hash, s3hash :: Word32 s1hash = toHash 0 s1 s2hash = toHash 0 s2 s3hash = toHash 0 s3 lmap5 :: LabelMap LabelMem lmap5 = tstLabelMap 2 [ (b4,(1,bhash)), (b3,(1,bhash)), (l10,(1,l10hash)), (l4,(1,l4hash)), (l1,(1,l1hash)), (o3,(1,o3hash)), (o2,(1,o2hash)), (o1,(1,o1hash)), (p3,(1,p3hash)), (p2,(1,p2hash)), (p1,(1,p1hash)), (s3,(1,s3hash)), (s2,(1,s2hash)), (s1,(1,s1hash)) ] testAssignLabelMap05 :: Test testAssignLabelMap05 = testEq "AssignLabels05" lmap5 (newGenerationMap $ assignLabelMap ls5 emptyMap) lmap6 :: LabelMap LabelMem lmap6 = tstLabelMap 2 [ (b2,(2,bhash)), (b1,(2,bhash)), (b4,(1,bhash)), (b3,(1,bhash)), (l10,(1,l10hash)), (l4,(1,l4hash)), (l1,(1,l1hash)), (o3,(1,o3hash)), (o2,(1,o2hash)), (o1,(1,o1hash)), (p3,(1,p3hash)), (p2,(1,p2hash)), (p1,(1,p1hash)), (s3,(1,s3hash)), (s2,(1,s2hash)), (s1,(1,s1hash)) ] testAssignLabelMap06 :: Test testAssignLabelMap06 = testEq "AssignLabels06" lmap6 (assignLabelMap ls6 lmap5) lmapc :: LabelMap LabelMem lmapc = tstLabelMap 1 [(s1,(1,11)),(s2,(1,12)),(s3,(1,13)), (p1,(1,21)),(p2,(1,22)),(p3,(1,13)), (o1,(1,31)),(o2,(1,32)),(o3,(1,13)), (l1,(1,41)),(l4,(1,42)),(l10,(1,43)), (b1,(1,51)),(b2,(1,51)),(b3,(1,51)),(b4,(1,51))] -- [[[TODO: test hash value collision on non-variable label]]] testGraphMatchSupportSuite :: Test testGraphMatchSupportSuite = TestList [ testGraphLabels04 , testGraphLabels14 , testGraphLabels05 , testGraphLabels15 , testGraphLabels06 , testGraphLabels16 , testAssignLabelMap05 , testAssignLabelMap06 -- implicitly tested elsewhere but included here for completeness , testEq "O16-identity" tOrder16 $ sort tOrder16 , testEq "O16-compare" tOrder16 $ sort [t01,t02,t03,t04,t05,t06] ] ------------------------------------------------------------ -- Test steps in graph equality test ------------------------------------------------------------ matchable :: a -> b -> Bool matchable _ _ = True s1_1, s2_1, s3_1 :: ScopedLabel LabelMem s1_1 = makeScopedLabel 1 s1 s2_1 = makeScopedLabel 1 s2 s3_1 = makeScopedLabel 1 s3 p1_1, p2_1, p3_1 :: ScopedLabel LabelMem p1_1 = makeScopedLabel 1 p1 p2_1 = makeScopedLabel 1 p2 p3_1 = makeScopedLabel 1 p3 o1_1, o2_1, o3_1 :: ScopedLabel LabelMem o1_1 = makeScopedLabel 1 o1 o2_1 = makeScopedLabel 1 o2 o3_1 = makeScopedLabel 1 o3 l1_1, l4_1, l10_1 :: ScopedLabel LabelMem l1_1 = makeScopedLabel 1 l1 l4_1 = makeScopedLabel 1 l4 l10_1 = makeScopedLabel 1 l10 b1_1, b2_1, b3_1, b4_1 :: ScopedLabel LabelMem b1_1 = makeScopedLabel 1 b1 b2_1 = makeScopedLabel 1 b2 b3_1 = makeScopedLabel 1 b3 b4_1 = makeScopedLabel 1 b4 s1_2, s2_2, s3_2 :: ScopedLabel LabelMem s1_2 = makeScopedLabel 2 s1 s2_2 = makeScopedLabel 2 s2 s3_2 = makeScopedLabel 2 s3 p1_2, p2_2, p3_2 :: ScopedLabel LabelMem p1_2 = makeScopedLabel 2 p1 p2_2 = makeScopedLabel 2 p2 p3_2 = makeScopedLabel 2 p3 o1_2, o2_2, o3_2 :: ScopedLabel LabelMem o1_2 = makeScopedLabel 2 o1 o2_2 = makeScopedLabel 2 o2 o3_2 = makeScopedLabel 2 o3 l1_2, l4_2, l10_2 :: ScopedLabel LabelMem l1_2 = makeScopedLabel 2 l1 l4_2 = makeScopedLabel 2 l4 l10_2 = makeScopedLabel 2 l10 b1_2, b2_2, b3_2, b4_2 :: ScopedLabel LabelMem b1_2 = makeScopedLabel 2 b1 b2_2 = makeScopedLabel 2 b2 b3_2 = makeScopedLabel 2 b3 b4_2 = makeScopedLabel 2 b4 t01_1 :: Arc (ScopedLabel LabelMem) t01_1 = makeScopedArc 1 t01 t01_2, t02_2, t03_2, t04_2, t05_2, t06_2 :: Arc (ScopedLabel LabelMem) t01_2 = makeScopedArc 2 t01 t02_2 = makeScopedArc 2 t02 t03_2 = makeScopedArc 2 t03 t04_2 = makeScopedArc 2 t04 t05_2 = makeScopedArc 2 t05 t06_2 = makeScopedArc 2 t06 t10_1, t11_1, t12_1, t20_1, t21_1, t22_1 :: Arc (ScopedLabel LabelMem) t10_1 = makeScopedArc 1 t10 t11_1 = makeScopedArc 1 t11 t12_1 = makeScopedArc 1 t12 t20_1 = makeScopedArc 1 t20 t21_1 = makeScopedArc 1 t21 t22_1 = makeScopedArc 1 t22 t10_2, t11_2, t12_2, t20_2, t21_2, t22_2 :: Arc (ScopedLabel LabelMem) t10_2 = makeScopedArc 2 t10 t11_2 = makeScopedArc 2 t11 t12_2 = makeScopedArc 2 t12 t20_2 = makeScopedArc 2 t20 t21_2 = makeScopedArc 2 t21 t22_2 = makeScopedArc 2 t22 -- Compare graph as6 with self, in steps as61, as62 :: ArcSet (ScopedLabel LabelMem) as61 = S.map (makeScopedArc 1) as6 as62 = S.map (makeScopedArc 2) as6 eq1lmap :: LabelMap (ScopedLabel LabelMem) eq1lmap = newGenerationMap $ assignLabelMap (graphLabels as62) $ assignLabelMap (graphLabels as61) emptyMap eq1ltst :: LabelMap (ScopedLabel LabelMem) eq1ltst = tstLabelMap 2 [ (b4_2,(1,bhash)), (b3_2,(1,bhash)), (p3_2,(1,p3hash)), (b2_2,(1,bhash)), (p2_2,(1,p2hash)), (b1_2,(1,bhash)), (l10_2,(1,l10hash)), (l4_2,(1,l4hash)), (l1_2,(1,l1hash)), (o3_2,(1,o3hash)), (s3_2,(1,s3hash)), (o2_2,(1,o2hash)), (s2_2,(1,s2hash)), (o1_2,(1,o1hash)), (p1_2,(1,p1hash)), (s1_2,(1,s1hash)), (b4_1,(1,bhash)), (b3_1,(1,bhash)), (p3_1,(1,p3hash)), (b2_1,(1,bhash)), (p2_1,(1,p2hash)), (b1_1,(1,bhash)), (l10_1,(1,l10hash)), (l4_1,(1,l4hash)), (l1_1,(1,l1hash)), (o3_1,(1,o3hash)), (s3_1,(1,s3hash)), (o2_1,(1,o2hash)), (s2_1,(1,s2hash)), (o1_1,(1,o1hash)), (p1_1,(1,p1hash)), (s1_1,(1,s1hash)) ] testEqAssignMap01 :: Test testEqAssignMap01 = testEq "EqAssignMap01" eq1ltst eq1lmap eq1hs1, eq1hs2 :: [Arc (ScopedLabel LabelMem)] eq1hs1 = [t10_1,t11_1,t12_1,t20_1,t21_1,t22_1] eq1hs2 = [t10_2,t11_2,t12_2,t20_2,t21_2,t22_2] eq1lmap' :: LabelMap (ScopedLabel LabelMem) eq1lmap' = tstLabelMap 2 [(s1_1,(1,142577)),(s2_1,(1,142578)),(s3_1,(1,142579)), (s1_2,(1,142577)),(s2_2,(1,142578)),(s3_2,(1,142579)), (p1_1,(1,142385)),(p2_1,(1,142386)),(p3_1,(1,142387)), (p1_2,(1,142385)),(p2_2,(1,142386)),(p3_2,(1,142387)), (o1_1,(1,142321)),(o2_1,(1,142322)),(o3_1,(1,142323)), (o1_2,(1,142321)),(o2_2,(1,142322)),(o3_2,(1,142323)), (l1_1,(1,142129)),(l4_1,(1,1709580)),(l10_1,(1,3766582)), (l1_2,(1,142129)),(l4_2,(1,1709580)),(l10_2,(1,3766582)), (b1_1,(2,3880463)),(b2_1,(2,3400925)), (b3_1,(2,3880463)), (b4_1,(2,3400925)), (b1_2,(2,3880463)),(b2_2,(2,3400925)), (b3_2,(2,3880463)), (b4_2,(2,3400925))] eq1lmap'' :: LabelMap (ScopedLabel LabelMem) eq1lmap'' = newLabelMap eq1lmap' [ (b1_1,2576315),(b2_1,3400925),(b3_1,1571691), (b1_2,2576315),(b2_2,3400925),(b3_2,1571691) ] eq1ltst'' :: LabelMap (ScopedLabel LabelMem) eq1ltst'' = tstLabelMap 3 [ (s1_1,(1,142577)),(s2_1,(1,142578)),(s3_1,(1,142579)), (p1_1,(1,142385)),(p2_1,(1,142386)),(p3_1,(1,142387)), (o1_1,(1,142321)),(o2_1,(1,142322)),(o3_1,(1,142323)), (l1_1,(1,142129)),(l4_1,(1,1709580)),(l10_1,(1,3766582)), (b1_1,(3,2576315)), (b2_1,(3,3400925)), (b3_1,(3,1571691)), (b4_1,(2,3400925)), (s1_2,(1,142577)),(s2_2,(1,142578)),(s3_2,(1,142579)), (p1_2,(1,142385)),(p2_2,(1,142386)),(p3_2,(1,142387)), (o1_2,(1,142321)),(o2_2,(1,142322)),(o3_2,(1,142323)), (l1_2,(1,142129)),(l4_2,(1,1709580)),(l10_2,(1,3766582)), (b1_2,(3,2576315)), (b2_2,(3,3400925)), (b3_2,(3,1571691)), (b4_2,(2,3400925)) ] testEqNewLabelMap07 :: Test testEqNewLabelMap07 = testEq "EqNewLabelMap07" eq1ltst'' eq1lmap'' -- Repeat same tests for as4... as41, as42 :: ArcSet (ScopedLabel LabelMem) as41 = S.map (makeScopedArc 1) as4 as42 = S.map (makeScopedArc 2) as4 eq2lmap :: LabelMap (ScopedLabel LabelMem) eq2lmap = newGenerationMap $ assignLabelMap (graphLabels as42) $ assignLabelMap (graphLabels as41) emptyMap eq2ltst :: LabelMap (ScopedLabel LabelMem) eq2ltst = tstLabelMap 2 [ (p3_2,(1,p3hash)), (b2_2,(1,bhash)), (b1_2,(1,bhash)), (p2_2,(1,p2hash)), (l10_2,(1,l10hash)), (l4_2,(1,l4hash)), (l1_2,(1,l1hash)), (o3_2,(1,o3hash)), (s3_2,(1,s3hash)), (o2_2,(1,o2hash)), (s2_2,(1,s2hash)), (o1_2,(1,o1hash)), (p1_2,(1,p1hash)), (s1_2,(1,s1hash)), (p3_1,(1,p3hash)), (b2_1,(1,bhash)), (p2_1,(1,p2hash)), (b1_1,(1,bhash)), (l10_1,(1,l10hash)), (l4_1,(1,l4hash)), (l1_1,(1,l1hash)), (o3_1,(1,o3hash)), (s3_1,(1,s3hash)), (o2_1,(1,o2hash)), (s2_1,(1,s2hash)), (o1_1,(1,o1hash)), (p1_1,(1,p1hash)), (s1_1,(1,s1hash)) ] testEqAssignMap21 :: Test testEqAssignMap21 = testEq "EqAssignMap21" eq2ltst eq2lmap eq2hs1, eq2hs2 :: [Arc (ScopedLabel LabelMem)] eq2hs1 = [t10_1,t11_1,t12_1] eq2hs2 = [t10_2,t11_2,t12_2] eq2lmap' :: LabelMap (ScopedLabel LabelMem) eq2lmap' = tstLabelMap 2 [ (s1_1,(1,142577)),(s2_1,(1,142578)),(s3_1,(1,142579)), (p1_1,(1,142385)),(p2_1,(1,142386)),(p3_1,(1,142387)), (o1_1,(1,142321)),(o2_1,(1,142322)),(o3_1,(1,142323)), (l1_1,(1,142129)),(l4_1,(1,1709580)),(l10_1,(1,3766582)), (b1_1,(2,3880463)),(b2_1,(2,3400925)), (s1_2,(1,142577)),(s2_2,(1,142578)),(s3_2,(1,142579)), (p1_2,(1,142385)),(p2_2,(1,142386)),(p3_2,(1,142387)), (o1_2,(1,142321)),(o2_2,(1,142322)),(o3_2,(1,142323)), (l1_2,(1,142129)),(l4_2,(1,1709580)),(l10_2,(1,3766582)), (b1_2,(2,3880463)),(b2_2,(2,3400925)) ] eq2lmap'' :: LabelMap (ScopedLabel LabelMem) eq2lmap'' = newLabelMap eq2lmap' [ (b2_1,3400925), (b2_2,3400925) ] eq2ltst'' :: LabelMap (ScopedLabel LabelMem) eq2ltst'' = tstLabelMap 3 [ (s1_1,(1,142577)),(s2_1,(1,142578)),(s3_1,(1,142579)), (p1_1,(1,142385)),(p2_1,(1,142386)),(p3_1,(1,142387)), (o1_1,(1,142321)),(o2_1,(1,142322)),(o3_1,(1,142323)), (l1_1,(1,142129)),(l4_1,(1,1709580)),(l10_1,(1,3766582)), (b1_1,(2,3880463)), (b2_1,(3,3400925)), (s1_2,(1,142577)),(s2_2,(1,142578)),(s3_2,(1,142579)), (p1_2,(1,142385)),(p2_2,(1,142386)),(p3_2,(1,142387)), (o1_2,(1,142321)),(o2_2,(1,142322)),(o3_2,(1,142323)), (l1_2,(1,142129)),(l4_2,(1,1709580)),(l10_2,(1,3766582)), (b1_2,(2,3880463)), (b2_2,(3,3400925)) ] testEqNewLabelMap27 :: Test testEqNewLabelMap27 = testEq "EqNewLabelMap27" eq2ltst'' eq2lmap'' -- Compare as1 with as2, in steps as11, as22 :: ArcSet (ScopedLabel LabelMem) as11 = S.map (makeScopedArc 1) as1 as22 = S.map (makeScopedArc 2) as2 eq3hs1, eq3hs2 :: ArcSet (ScopedLabel LabelMem) eq3hs1 = S.singleton t01_1 eq3hs2 = S.fromList [t01_2,t02_2,t03_2,t04_2,t05_2,t06_2] testEqGraphMap31_1, testEqGraphMap31_2 :: Test testEqGraphMap31_1 = testEq "testEqGraphMap31_1" eq3hs1 as11 testEqGraphMap31_2 = testEq "testEqGraphMap31_2" eq3hs2 as22 eq3lmap :: LabelMap (ScopedLabel LabelMem) eq3lmap = newGenerationMap $ assignLabelMap (graphLabels as11) $ assignLabelMap (graphLabels as22) emptyMap eq3ltst :: LabelMap (ScopedLabel LabelMem) eq3ltst = tstLabelMap 2 [ (o1_1,(1,o1hash)) , (p1_1,(1,p1hash)) , (s1_1,(1,s1hash)) , (l10_2,(1,l10hash)) , (l4_2,(1,l4hash)) , (l1_2,(1,l1hash)) , (o3_2,(1,o3hash)) , (s3_2,(1,s3hash)) , (o2_2,(1,o2hash)) , (s2_2,(1,s2hash)) , (o1_2,(1,o1hash)) , (p1_2,(1,p1hash)) , (s1_2,(1,s1hash)) ] testEqAssignMap32 :: Test testEqAssignMap32 = testEq "EqAssignMap32" eq3ltst eq3lmap type EquivClass = EquivalenceClass (ScopedLabel LabelMem) type EquivArgs = ((Word32, Word32), [ScopedLabel LabelMem]) ec31 :: [EquivClass] ec31 = equivalenceClasses eq3lmap (graphLabels as11) ec31test :: [EquivArgs] ec31test = sortBy (compare `on` (snd.fst)) [ ((1,o1hash),[o1_1]) , ((1,p1hash),[p1_1]) , ((1,s1hash),[s1_1]) ] ec32 :: [EquivClass] ec32 = equivalenceClasses eq3lmap (graphLabels as22) ec32test :: [EquivArgs] ec32test = sortBy (compare `on` (snd.fst)) [ ((1,l1hash),[l1_2]) , ((1,o2hash),[o2_2]) , ((1,o3hash),[o3_2]) , ((1,o1hash),[o1_2]) , ((1,p1hash),[p1_2]) , ((1,s2hash),[s2_2]) , ((1,s3hash),[s3_2]) , ((1,s1hash),[s1_2]) , ((1,l10hash),[l10_2]) , ((1,l4hash),[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)] ec3test = [ ( ((1,142321),[o1_1]), ((1,142321),[o1_2]) ) , ( ((1,142385),[p1_1]), ((1,142385),[p1_2]) ) , ( ((1,142577),[s1_1]), ((1,142577),[s1_2]) ) ] 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)) , (p1_1,(1,142385)) , (s1_1,(1,142577)) , (l10_2,(1,3766582)) , (l4_2,(1,1709580)) , (l1_2,(1,142129)) , (o3_2,(1,142323)) , (s3_2,(1,142579)) , (o2_2,(1,142322)) , (s2_2,(1,142578)) , (o1_2,(1,142321)) , (p1_2,(1,142385)) , (s1_2,(1,142577)) ] -- 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 eq3rctst1 = [] testEqReclassify35_1 = testEqv "EqReclassify35_1" (makeEntries eq3rctst1) eq3rc1 eq3rc2 = reclassify eq3hs2 eq3lmap eq3rctst2 = [] testEqReclassify35_2 = testEqv "EqReclassify35_2" (makeEntries eq3rctst2) eq3rc2 -} -- Test suite testGraphMatchStepSuite :: Test testGraphMatchStepSuite = TestList [ testEqAssignMap01 -- , testEqReclassify03_1, testEqReclassify03_2 , testEqNewLabelMap07 -- , testEqGraphMatch08 , testEqAssignMap21 -- , testEqReclassify23_1, testEqReclassify23_2 , testEqNewLabelMap27 -- , testEqGraphMatch28 , testEqGraphMap31_1, testEqGraphMap31_2 , testEqAssignMap32 , testEquivClass33_1, testEquivClass33_2 -- , testEquivClass33_3 -- , testEqAssignMap34 pairSort is not exported -- , testEqReclassify35_1, testEqReclassify35_2 ] ------------------------------------------------------------ -- Graph equality tests ------------------------------------------------------------ testGraphEq :: ( Label lb ) => String -> Bool -> GraphMem lb -> GraphMem lb -> Test testGraphEq lab eq gg1 gg2 = TestCase ( assertEqual ("testGraphEq:"++lab) eq (gg1==gg2) ) toG :: [Statement] -> GraphMem LabelMem toG stmts = GraphMem { arcs = S.fromList stmts } g1, g2, g3, g4, g5, g6, g7, g8 :: GraphMem LabelMem g1 = toG [t01] g2 = toG [t01,t02,t03,t04,t05,t06] g3 = toG [t06,t05,t04,t03,t02,t01] g4 = toG [t01,t02,t03,t04,t05,t06,t10,t11,t12] g5 = toG [t01,t02,t03,t04,t05,t06,t20,t21,t22] g6 = toG [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] g7 = toG [t01,t02] g8 = toG [t02,t01] glist :: [(String, GraphMem LabelMem)] glist = [ ("g1",g1), ("g2",g2), ("g3",g3), ("g4",g4), ("g5",g5), ("g6",g6) ] grapheqlist :: [(String, String)] grapheqlist = [ ("g2","g3") , ("g4","g5") ] testGraphEqSuitePart :: Test testGraphEqSuitePart = TestLabel "testGraphEqSuitePart" $ TestList [ testGraphEq "g1-g2" False g1 g2 , testGraphEq "g2-g1" False g2 g1 , testGraphEq "g2-g2" True g2 g2 , testGraphEq "g2-g3" True g2 g3 , testGraphEq "g1-g4" False g1 g4 , testGraphEq "g2-g4" False g2 g4 , testGraphEq "g3-g4" False g3 g4 , testGraphEq "g4-g3" False g4 g3 , testGraphEq "g4-g4" True g4 g4 , testGraphEq "g4-g5" True g4 g5 , testGraphEq "g4-g6" False g4 g6 , testGraphEq "g6-g6" True g6 g6 , testGraphEq "g7-g7" True g7 g7 , testGraphEq "g7-g8" True g7 g8 , testGraphEq "g8-g7" True g8 g7 ] testGraphEqSuite :: Test testGraphEqSuite = TestLabel "testGraphEqSuite" $ TestList [ testGraphEq (testLab ll1 ll2) (nodeTest ll1 ll2) gg1 gg2 | (ll1,gg1) <- glist , (ll2,gg2) <- glist ] where testLab ll1 ll2 = ll1 ++ "-" ++ ll2 nodeTest ll1 ll2 = (ll1 == ll2) || (ll1,ll2) `elem` grapheqlist || (ll2,ll1) `elem` grapheqlist -- Selected tests for debugging geq12, geq21, geq22, geq23, geq14, geq24, geq77, geq78, geq87 :: Test geq12 = testGraphEq "g1-g2" False g1 g2 geq21 = testGraphEq "g2-g1" False g2 g1 geq22 = testGraphEq "g2-g2" True g2 g2 geq23 = testGraphEq "g2-g3" True g2 g3 geq14 = testGraphEq "g1-g4" False g1 g4 geq24 = testGraphEq "g2-g4" False g2 g4 geq77 = testGraphEq "g7-g7" True g7 g7 geq78 = testGraphEq "g7-g8" True g7 g8 geq87 = testGraphEq "g8-g7" True g8 g7 ------------------------------------------------------------ -- More graph equality tests ------------------------------------------------------------ -- -- These tests are based on the 10-node, triply connected -- graph examples in Jeremy Carroll's paper on matching RDF -- graphs. -- Graph pattern 1: -- pentangle-in-pentangle, corresponding vertices linked upward v101, v102, v103, v104, v105, v106, v107, v108, v109, v110 :: LabelMem v101 = LV "v101" v102 = LV "v102" v103 = LV "v103" v104 = LV "v104" v105 = LV "v105" v106 = LV "v106" v107 = LV "v107" v108 = LV "v108" v109 = LV "v109" v110 = LV "v110" p101, p102, p103, p104, p105, p106, p107, p108, p109, p110, p111, p112, p113, p114, p115 :: LabelMem p101 = LV "p101" p102 = LV "p102" p103 = LV "p103" p104 = LV "p104" p105 = LV "p105" p106 = LV "p106" p107 = LV "p107" p108 = LV "p108" p109 = LV "p109" p110 = LV "p110" p111 = LV "p111" p112 = LV "p112" p113 = LV "p113" p114 = LV "p114" p115 = LV "p115" t10102, t10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 :: Statement t10102 = arc v101 p101 v102 t10203 = arc v102 p102 v103 t10304 = arc v103 p103 v104 t10405 = arc v104 p104 v105 t10501 = arc v105 p105 v101 t10106 = arc v101 p106 v106 t10207 = arc v102 p107 v107 t10308 = arc v103 p108 v108 t10409 = arc v104 p109 v109 t10510 = arc v105 p110 v110 t10607 = arc v106 p111 v107 t10708 = arc v107 p112 v108 t10809 = arc v108 p113 v109 t10910 = arc v109 p114 v110 t11006 = arc v110 p115 v106 -- Graph pattern 2: -- pentangle-in-pentangle, corresponding vertices linked downward v201, v202, v203, v204, v205, v206, v207, v208, v209, v210 :: LabelMem v201 = LV "v201" v202 = LV "v202" v203 = LV "v203" v204 = LV "v204" v205 = LV "v205" v206 = LV "v206" v207 = LV "v207" v208 = LV "v208" v209 = LV "v209" v210 = LV "v210" p201, p202, p203, p204, p205, p206, p207, p208, p209, p210, p211, p212, p213, p214, p215 :: LabelMem p201 = LV "p201" p202 = LV "p202" p203 = LV "p203" p204 = LV "p204" p205 = LV "p205" p206 = LV "p206" p207 = LV "p207" p208 = LV "p208" p209 = LV "p209" p210 = LV "p210" p211 = LV "p211" p212 = LV "p212" p213 = LV "p213" p214 = LV "p214" p215 = LV "p215" t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t21005, t20607, t20708, t20809, t20910, t21006 :: Statement t20102 = arc v201 p201 v202 t20203 = arc v202 p202 v203 t20304 = arc v203 p203 v204 t20405 = arc v204 p204 v205 t20501 = arc v205 p205 v201 t20601 = arc v206 p206 v201 t20702 = arc v207 p207 v202 t20803 = arc v208 p208 v203 t20904 = arc v209 p209 v204 t21005 = arc v210 p210 v205 t20607 = arc v206 p211 v207 t20708 = arc v207 p212 v208 t20809 = arc v208 p213 v209 t20910 = arc v209 p214 v210 t21006 = arc v210 p215 v206 -- Graph pattern 3: -- star-in-pentangle, corresponding vertices linked toward star -- Although this graph is similarly linked to patterns 1 and 2, -- it is topologically different as it contains circuits only of -- length 5, where the others have circuits of length 4 and 5 -- (ignoring direction of arcs) v301, v302, v303, v304, v305, v306, v307, v308, v309, v310 :: LabelMem v301 = LV "v301" v302 = LV "v302" v303 = LV "v303" v304 = LV "v304" v305 = LV "v305" v306 = LV "v306" v307 = LV "v307" v308 = LV "v308" v309 = LV "v309" v310 = LV "v310" p301, p302, p303, p304, p305, p306, p307, p308, p309, p310, p311, p312, p313, p314, p315 :: LabelMem p301 = LV "p301" p302 = LV "p302" p303 = LV "p303" p304 = LV "p304" p305 = LV "p305" p306 = LV "p306" p307 = LV "p307" p308 = LV "p308" p309 = LV "p309" p310 = LV "p310" p311 = LV "p311" p312 = LV "p312" p313 = LV "p313" p314 = LV "p314" p315 = LV "p315" t30102, t30203, t30304, t30405, t30501, t30106, t30207, t30308, t30409, t30510, t30608, t30709, t30810, t30906, t31007 :: Statement t30102 = arc v301 p301 v302 t30203 = arc v302 p302 v303 t30304 = arc v303 p303 v304 t30405 = arc v304 p304 v305 t30501 = arc v305 p305 v301 t30106 = arc v301 p306 v306 t30207 = arc v302 p307 v307 t30308 = arc v303 p308 v308 t30409 = arc v304 p309 v309 t30510 = arc v305 p310 v310 t30608 = arc v306 p311 v308 t30709 = arc v307 p312 v309 t30810 = arc v308 p313 v310 t30906 = arc v309 p314 v306 t31007 = arc v310 p315 v307 -- Graph pattern 4: -- pentangle-in-pentangle, corresponding vertices linked upward -- The vertices 6-10 are linked in reverse order to the -- corresponding vertices 1-5. v401, v402, v403, v404, v405, v406, v407, v408, v409, v410 :: LabelMem v401 = LV "v401" v402 = LV "v402" v403 = LV "v403" v404 = LV "v404" v405 = LV "v405" v406 = LV "v406" v407 = LV "v407" v408 = LV "v408" v409 = LV "v409" v410 = LV "v410" p401, p402, p403, p404, p405, p406, p407, p408, p409, p410, p411, p412, p413, p414, p415 :: LabelMem p401 = LV "p401" p402 = LV "p402" p403 = LV "p403" p404 = LV "p404" p405 = LV "p405" p406 = LV "p406" p407 = LV "p407" p408 = LV "p408" p409 = LV "p409" p410 = LV "p410" p411 = LV "p411" p412 = LV "p412" p413 = LV "p413" p414 = LV "p414" p415 = LV "p415" t40102, t40203, t40304, t40405, t40501, t40106, t40207, t40308, t40409, t40510, t41009, t40908, t40807, t40706, t40610:: Statement t40102 = arc v401 p401 v402 t40203 = arc v402 p402 v403 t40304 = arc v403 p403 v404 t40405 = arc v404 p404 v405 t40501 = arc v405 p405 v401 t40106 = arc v401 p406 v406 t40207 = arc v402 p407 v407 t40308 = arc v403 p408 v408 t40409 = arc v404 p409 v409 t40510 = arc v405 p410 v410 t41009 = arc v410 p411 v409 t40908 = arc v409 p412 v408 t40807 = arc v408 p413 v407 t40706 = arc v407 p414 v406 t40610 = arc v406 p415 v410 -- Graph pattern 5: -- Same as pattern 1, except same fixed property in all cases. p5 :: LabelMem p5 = LF "p5" t50102, t50203, t50304, t50405, t50501, t50106, t50207, t50308, t50409, t50510, t50607, t50708, t50809, t50910, t51006 :: Statement t50102 = arc v101 p5 v102 t50203 = arc v102 p5 v103 t50304 = arc v103 p5 v104 t50405 = arc v104 p5 v105 t50501 = arc v105 p5 v101 t50106 = arc v101 p5 v106 t50207 = arc v102 p5 v107 t50308 = arc v103 p5 v108 t50409 = arc v104 p5 v109 t50510 = arc v105 p5 v110 t50607 = arc v106 p5 v107 t50708 = arc v107 p5 v108 t50809 = arc v108 p5 v109 t50910 = arc v109 p5 v110 t51006 = arc v110 p5 v106 -- Graph pattern 6: -- Same as pattern 5, with different variables t60102, t60203, t60304, t60405, t60501, t60106, t60207, t60308, t60409, t60510, t60607, t60708, t60809, t60910, t61006 :: Statement t60102 = arc v201 p5 v202 t60203 = arc v202 p5 v203 t60304 = arc v203 p5 v204 t60405 = arc v204 p5 v205 t60501 = arc v205 p5 v201 t60106 = arc v201 p5 v206 t60207 = arc v202 p5 v207 t60308 = arc v203 p5 v208 t60409 = arc v204 p5 v209 t60510 = arc v205 p5 v210 t60607 = arc v206 p5 v207 t60708 = arc v207 p5 v208 t60809 = arc v208 p5 v209 t60910 = arc v209 p5 v210 t61006 = arc v210 p5 v206 -- arcsToGraph :: (Ord a) => [Arc a] -> GraphMem a arcsToGraph as = GraphMem { arcs = S.fromList as } -- Very simple case g100 :: GraphMem LabelMem g100 = arcsToGraph [ t10102, t10203, t10304, t10405, t10501, t10607, t10708, t10809, t10910, t11006 ] g200 :: GraphMem LabelMem g200 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20607, t20708, t20809, t20910, t21006 ] -- 10/3 node graph comparisons g101 :: GraphMem LabelMem g101 = arcsToGraph [ t10102, t10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g201 :: GraphMem LabelMem g201 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t21005, t20607, t20708, t20809, t20910, t21006 ] g301 :: GraphMem LabelMem g301 = arcsToGraph [ t30102, t30203, t30304, t30405, t30501, t30106, t30207, t30308, t30409, t30510, t30608, t30709, t30810, t30906, t31007 ] g401 :: GraphMem LabelMem g401 = arcsToGraph [ t40102, t40203, t40304, t40405, t40501, t40106, t40207, t40308, t40409, t40510, t40610, t40706, t40807, t40908, t41009 ] g501 :: GraphMem LabelMem g501 = arcsToGraph [ t50102, t50203, t50304, t50405, t50501, t50106, t50207, t50308, t50409, t50510, t50607, t50708, t50809, t50910, t51006 ] g601 :: GraphMem LabelMem g601 = arcsToGraph [ t60102, t60203, t60304, t60405, t60501, t60106, t60207, t60308, t60409, t60510, t60607, t60708, t60809, t60910, t61006 ] -- Remove one arc from each g102 :: GraphMem LabelMem g102 = arcsToGraph [ t10102, t10203, t10304, t10405, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g202 :: GraphMem LabelMem g202 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t21005, t20708, t20809, t20910, t21006 ] g302 :: GraphMem LabelMem g302 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t20607, t20708, t20809, t20910, t21006 ] -- Remove two adjacent arcs from each g103 :: GraphMem LabelMem g103 = arcsToGraph [ t10102, t10203, t10304, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g203 :: GraphMem LabelMem g203 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t21005, t20607, t20708, t21006 ] g303 :: GraphMem LabelMem g303 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20904, t20607, t20708, t20809, t21006 ] -- Remove two adjacent arcs from one, non-adjacent from another g104 :: GraphMem LabelMem g104 = arcsToGraph [ t10102, t10203, t10304, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g204 :: GraphMem LabelMem g204 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20601, t20702, t20803, t20607, t20708, t20809, t20910, t21006 ] -- Compare two rings of 5 with one ring of 10 -- (each node double-connected, but different overall topology) t10901 :: Statement t10901 = arc v109 p109 v101 g105 :: GraphMem LabelMem g105 = arcsToGraph [ t10102, t10203, t10304, t10405, t10901, t10510, t10607, t10708, t10809, t11006 ] g205 :: GraphMem LabelMem g205 = arcsToGraph [ t20102, t20203, t20304, t20405, t20501, t20607, t20708, t20809, t20910, t21006 ] -- Reverse one arc from test 01 -- (also, rearrange arcs to catch ordering artefacts) t20201 :: Statement t20201 = arc v202 p201 v201 g106 :: GraphMem LabelMem g106 = arcsToGraph [ t10102, t10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g206 :: GraphMem LabelMem g206 = arcsToGraph [ t20607, t20708, t20809, t20910, t21006, t20601, t20702, t20803, t20904, t21005, t20102, t20203, t20304, t20405, t20501 ] g306 :: GraphMem LabelMem g306 = arcsToGraph [ t20607, t20708, t20809, t20910, t21006, t20601, t20702, t20803, t20904, t21005, t20201, t20203, t20304, t20405, t20501 ] -- Similar tests to 02,03,04, -- but add identified property rather than removing arcs f01, f02 :: LabelMem f01 = LF "f01" f02 = LF "f02" -- Fix one arc from each f10102, f10501, f21006, f20510 :: Statement f10102 = arc v101 f01 v102 f10501 = arc v105 f01 v101 f21006 = arc v210 f01 v206 f20510 = arc v205 f01 v210 g107 :: GraphMem LabelMem g107 = arcsToGraph [ f10102, t10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g207 :: GraphMem LabelMem g207 = arcsToGraph [ t10102, t10203, t10304, t10405, f10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g307 :: GraphMem LabelMem g307 = arcsToGraph [ t20607, t20708, t20809, t20910, f21006, t20601, t20702, t20803, t20904, t21005, t20102, t20203, t20304, t20405, t20501 ] g407 :: GraphMem LabelMem g407 = arcsToGraph [ t20607, t20708, t20809, t20910, t21006, t20601, t20702, t20803, t20904, t21005, t20102, t20203, t20304, t20405, t20501 ] -- Fix two adjacent arcs from each f10203, f10405, f20910, f20601 :: Statement f10203 = arc v102 f01 v103 f10405 = arc v104 f01 v105 f20910 = arc v209 f01 v210 f20601 = arc v206 f01 v201 g108 :: GraphMem LabelMem g108 = arcsToGraph [ f10102, f10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g208 :: GraphMem LabelMem g208 = arcsToGraph [ t10102, t10203, t10304, f10405, f10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g308 :: GraphMem LabelMem g308 = arcsToGraph [ t20607, t20708, t20809, f20910, f21006, t20601, t20702, t20803, t20904, t21005, t20102, t20203, t20304, t20405, t20501 ] g408 :: GraphMem LabelMem g408 = arcsToGraph [ t20607, t20708, t20809, t20910, f21006, f20601, t20702, t20803, t20904, t21005, t20102, t20203, t20304, t20405, t20501 ] -- Fix two adjacent arcs with different properties g10203, g10102, g10405 :: Statement g10203 = arc v102 f02 v103 g10102 = arc v101 f02 v102 g10405 = arc v104 f02 v105 g109, g209, g309 :: GraphMem LabelMem g109 = arcsToGraph [ f10102, g10203, t10304, t10405, t10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g209 = arcsToGraph [ g10102, t10203, t10304, t10405, f10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] g309 = arcsToGraph [ t10102, t10203, t10304, g10405, f10501, t10106, t10207, t10308, t10409, t10510, t10607, t10708, t10809, t10910, t11006 ] mgeq00 :: Test mgeq00 = testGraphEq "g100-g200" True g100 g200 mgeq0112, mgeq0113, mgeq0114, mgeq0115, mgeq0116, mgeq0156 :: Test mgeq0112 = testGraphEq "g101-g201" True g101 g201 mgeq0113 = testGraphEq "g101-g301" False g101 g301 mgeq0114 = testGraphEq "g101-g401" False g101 g401 mgeq0115 = testGraphEq "g101-g501" False g101 g501 mgeq0116 = testGraphEq "g101-g601" False g101 g601 mgeq0156 = testGraphEq "g501-g601" True g501 g601 mgeq0212, mgeq0213 :: Test mgeq0212 = testGraphEq "g102-g202" True g102 g202 mgeq0213 = testGraphEq "g102-g302" False g102 g302 mgeq0312, mgeq0313 :: Test mgeq0312 = testGraphEq "g103-g203" True g103 g203 mgeq0313 = testGraphEq "g103-g303" False g103 g303 mgeq04, mgeq05 :: Test mgeq04 = testGraphEq "g104-g204" False g104 g204 mgeq05 = testGraphEq "g105-g205" False g105 g205 mgeq0612, mgeq0613 :: Test mgeq0612 = testGraphEq "g106-g206" True g106 g206 mgeq0613 = testGraphEq "g106-g306" False g106 g306 mgeq0712, mgeq0713, mgeq0714 :: Test mgeq0712 = testGraphEq "g107-g207" True g107 g207 mgeq0713 = testGraphEq "g107-g307" True g107 g307 mgeq0714 = testGraphEq "g107-g407" False g107 g407 mgeq0812, mgeq0813, mgeq0814 :: Test mgeq0812 = testGraphEq "g108-g208" True g108 g208 mgeq0813 = testGraphEq "g108-g308" True g108 g308 mgeq0814 = testGraphEq "g108-g408" False g108 g408 mgeq0912, mgeq0913 :: Test mgeq0912 = testGraphEq "g109-g209" True g109 g209 mgeq0913 = testGraphEq "g109-g309" False g109 g309 testGraphEqSuiteMore :: Test testGraphEqSuiteMore = TestList [ mgeq00 , mgeq0112, mgeq0113, mgeq0114, mgeq0115, mgeq0116, mgeq0156 , mgeq0212, mgeq0213 , mgeq0312, mgeq0313 , mgeq04 , mgeq05 , mgeq0612, mgeq0613 , mgeq0712, mgeq0713, mgeq0714 , mgeq0812, mgeq0813, mgeq0814 , mgeq0912, mgeq0913 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ -- testSelectSuite -- testSubsetSuite conv "Lab" testLabSuite , conv "Graph" testGraphSuite , conv "LabelEq" testLabelEqSuite , conv "LabelOrd" testLabelOrdSuite -- silly test of Eq instance , TF.testCase "arc neq" (assertBool "arc neq" (Arc True True True /= Arc True True False)) , conv "StmtEq" testStmtEqSuite , conv "LabelMap" testLabelMapSuite , conv "GraphMatchSupport" testGraphMatchSupportSuite , conv "GraphMatchStep" testGraphMatchStepSuite , conv "GraphEq Part" testGraphEqSuitePart , conv "GraphEq" testGraphEqSuite , conv "GraphEq More" testGraphEqSuiteMore -- test of Foldable instance of Arc , TF.testCase "foldArc" ([1::Int,2,4] @=? F.fold (Arc [1::Int] [2] [4])) ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/GraphPartitionTest.hs0000644000000000000000000004314513543702315016560 0ustar0000000000000000-------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : GraphPartitionTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : H98 -- -- This module contains test cases for graph partitioning logic. -- -------------------------------------------------------------------------------- module Main where import qualified Test.Framework as TF import Swish.GraphPartition ( PartitionedGraph(..), getArcs , GraphPartition(..), node , partitionGraph, comparePartitions ) import Swish.GraphClass (Arc(..)) import Swish.GraphMem (LabelMem(..)) import Data.List.NonEmpty (fromList) import Test.HUnit (Test(TestList)) import TestHelpers (conv, testEq, testNe , testEqv, testNotEqv ) ------------------------------------------------------------ -- Basic GraphPartition tests ------------------------------------------------------------ gp1, gp2, gp3, gp4, gp5 :: PartitionedGraph LabelMem gp1 = PartitionedGraph [ p11 ] gp2 = PartitionedGraph [ p11, p12 ] gp3 = PartitionedGraph [ p11, p13 ] 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 = 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] ga1 = [ Arc (LF "s1") (LF "p11") (LF "o11") ] ga2 = [ Arc (LF "s1") (LF "p11") (LF "o11") , Arc (LF "s2") (LF "p21") (LF "o21") , Arc (LF "s2") (LF "p22") (LF "o22") ] ga3 = [ Arc (LF "s1") (LF "p11") (LF "o11") , Arc (LF "s3") (LF "p31") (LF "o31") , Arc (LF "s3") (LF "p32") (LF "s2") , Arc (LF "s2") (LF "p21") (LF "o21") , Arc (LF "s2") (LF "p22") (LF "o22") , Arc (LF "s3") (LF "p33") (LF "s3") ] ga4 = [ Arc (LF "s1") (LF "p11") (LF "o11") , Arc (LF "s3") (LF "p31") (LF "o31") , Arc (LF "s3") (LF "p33") (LF "s3") , Arc (LF "s3") (LF "p32") (LF "s2") , Arc (LF "s2") (LF "p21") (LF "o21") , Arc (LF "s2") (LF "p22") (LF "o22") ] ga5 = [ Arc (LF "s1") (LF "p11") (LF "o11") , Arc (LF "s2") (LF "p21") (LF "o21") , Arc (LF "s2") (LF "p22") (LF "o22") , Arc (LF "s3") (LF "p31") (LF "o31") , Arc (LF "s3") (LF "p32") (LF "s2") , Arc (LF "s3") (LF "p33") (LF "s3") ] testBasic01, testBasic02, testBasic03, testBasic04, testBasic05 :: Test testBasic01 = testEq "testBasic01" gp1 gp1 testBasic02 = testEq "testBasic02" gp2 gp2 testBasic03 = testEq "testBasic03" gp3 gp3 testBasic04 = testEq "testBasic04" gp4 gp4 testBasic05 = testEq "testBasic05" gp5 gp5 testBasic06, testBasic07 :: Test testBasic06 = testNe "testBasic06" gp2 gp3 testBasic07 = testNe "testBasic07" gp3 gp4 testBasic11, testBasic12, testBasic13, testBasic14, testBasic15 :: Test testBasic11 = testEq "testBasic11" "PartitionedGraph [(!s1 !p11 !o11)]" (show gp1) testBasic12 = testEq "testBasic12" ( "PartitionedGraph "++ "[(!s1 !p11 !o11)"++ ",(!s2 !p21 !o21 ; !p22 !o22)"++ "]" ) (show gp2) testBasic13 = testEq "testBasic13" ( "PartitionedGraph "++ "[(!s1 !p11 !o11)"++ ",(!s3 !p31 !o31 ; !p32 (!s2 !p21 !o21 ; !p22 !o22) ; !p33 !s3)"++ "]" ) (show gp3) testBasic14 = testEq "testBasic14" ( "PartitionedGraph "++ "[(!s1 !p11 !o11)"++ ",(!s3 !p31 !o31 ; !p33 !s3 ; !p32 (!s2 !p21 !o21 ; !p22 !o22))"++ "]" ) (show gp4) testBasic15 = testEq "testBasic15" ( "PartitionedGraph "++ "[(!s1 !p11 !o11)"++ ",(!s2 !p21 !o21 ; !p22 !o22)"++ ",(!s3 !p31 !o31 ; !p32 !s2 ; !p33 !s3)"++ "]" ) (show gp5) testBasic21, testBasic22, testBasic23, testBasic24, testBasic25 :: Test testBasic21 = testEq "testBasic21" (LF "s1") (node p11) testBasic22 = testEq "testBasic22" (LF "s2") (node p12) testBasic23 = testEq "testBasic23" (LF "s3") (node p13) testBasic24 = testEq "testBasic24" (LF "s3") (node p14) testBasic25 = testEq "testBasic25" (LF "s3") (node p15) testBasic31, testBasic32, testBasic33, testBasic34, testBasic35, testBasic36, testBasic37, testBasic38 :: Test testBasic31 = testEq "testBasic31" ga1 (getArcs gp1) testBasic32 = testEq "testBasic32" ga2 (getArcs gp2) testBasic33 = testEq "testBasic33" ga3 (getArcs gp3) testBasic34 = testEq "testBasic34" ga4 (getArcs gp4) testBasic35 = testEq "testBasic35" ga5 (getArcs gp5) testBasic36 = testNotEqv "testBasic36" (getArcs gp2) (getArcs gp3) testBasic37 = testEqv "testBasic37" (getArcs gp3) (getArcs gp4) testBasic38 = testEqv "testBasic38" (getArcs gp3) (getArcs gp5) testBasicSuite :: Test testBasicSuite = TestList [ testBasic01 , testBasic02 , testBasic03 , testBasic04 , testBasic05 , testBasic06 , testBasic07 , testBasic11 , testBasic12 , testBasic13 , testBasic14 , testBasic15 , testBasic21 , testBasic22 , testBasic23 , testBasic24 , testBasic25 , testBasic31 , testBasic32 , testBasic33 , testBasic34 , testBasic35 , testBasic36 , testBasic37 , testBasic38 ] ------------------------------------------------------------ -- Creating GraphPartition tests ------------------------------------------------------------ pa1, pa2, pa3, pa4, pa5, pa6 :: [Arc LabelMem] pa1 = [ Arc (LF "s1") (LF "p") (LF "o11") ] pa2 = [ Arc (LF "s1") (LF "p") (LF "o11") , Arc (LF "s2") (LF "p1") (LF "o21") , Arc (LF "s2") (LF "p2") (LF "o22") ] pa3 = [ Arc (LF "s1") (LF "p") (LF "o11") , Arc (LF "s2") (LF "p1") (LF "o21") , Arc (LF "s2") (LF "p2") (LF "o22") , Arc (LV "b3") (LF "p") (LF "o31") , Arc (LV "b3") (LF "p") (LF "s2") , Arc (LV "b3") (LF "p") (LV "b3") ] pa4 = [ Arc (LF "s1") (LF "p") (LF "o11") , Arc (LF "s2") (LF "p1") (LF "o21") , Arc (LF "s2") (LF "p2") (LF "o22") , Arc (LV "b3") (LF "p") (LF "o31") , Arc (LV "b3") (LF "p") (LF "s2") , Arc (LV "b3") (LF "p") (LV "b3") , Arc (LV "b3") (LF "p") (LV "b4") , Arc (LV "b4") (LF "p") (LF "s2") , Arc (LV "b4") (LF "p") (LV "b3") ] pa5 = [ Arc (LF "s1") (LF "p") (LF "o11") , Arc (LF "s2") (LF "p1") (LF "o21") , Arc (LF "s2") (LF "p2") (LF "o22") , Arc (LV "b3") (LF "p") (LF "o31") , Arc (LV "b3") (LF "p") (LF "s2") , Arc (LV "b3") (LF "p") (LV "b3") , Arc (LV "b3") (LF "p") (LV "b4") , Arc (LV "b4") (LF "p") (LF "s2") , Arc (LV "b4") (LF "p") (LV "b3") , Arc (LV "b5a") (LF "p") (LV "b5b") , Arc (LV "b5b") (LF "p") (LV "b5c") , Arc (LV "b5c") (LF "p") (LV "b5a") ] pa6 = [ Arc (LF "s1") (LF "p") (LF "o11") , Arc (LF "s2") (LF "p1") (LF "o21") , Arc (LF "s2") (LF "p2") (LF "o22") , Arc (LV "b3") (LF "p") (LF "o31") , Arc (LV "b3") (LF "p") (LF "s2") , Arc (LV "b3") (LF "p") (LV "b3") , Arc (LV "b3") (LF "p") (LV "b4") , Arc (LV "b4") (LF "p") (LF "s2") , Arc (LV "b4") (LF "p") (LV "b3") , Arc (LV "b4") (LF "p") (LV "b5b") , Arc (LV "b5a") (LF "p") (LV "b5b") , Arc (LV "b5b") (LF "p") (LV "b5c") , Arc (LV "b5c") (LF "p") (LV "b5a") ] pp1, pp2f, pp2r, pp3f, pp3r, pp4f, pp4r, pp5f, pp5r, pp6f, pp6r :: PartitionedGraph LabelMem pp1 = PartitionedGraph [ ps1 ] pp2f = PartitionedGraph [ ps1, ps2f ] pp2r = PartitionedGraph [ ps2r, ps1 ] pp3f = PartitionedGraph [ ps1, ps2f, pb3f ] pp3r = PartitionedGraph [ ps2r, ps1, pb3r ] pp4f = PartitionedGraph [ ps1, ps2f, pb3af ] pp4r = PartitionedGraph [ ps2r, ps1, pb3ar ] pp5f = PartitionedGraph [ ps1, ps2f, pb3af, pb5a1 ] pp5r = PartitionedGraph [ ps2r, ps1, pb3ar, pb5c3 ] pp6f = PartitionedGraph [ ps1, ps2f, pb3bf, pb5b2 ] pp6r = PartitionedGraph [ ps2r, ps1, pb5b2, pb3br ] ps1, ps2f, ps2r, pb3f, pb3r, pb3af, pb3ar, pb4af, pb4ar :: GraphPartition LabelMem 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 = 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 = 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 = 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 = 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 = 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 testPartition11 = testEq "testPartition11" pp1 (partitionGraph pa1) testPartition12 = testEq "testPartition12" pp2f (partitionGraph pa2) testPartition13 = testEq "testPartition13" pp3f (partitionGraph pa3) testPartition14 = testEq "testPartition15" pp4f (partitionGraph pa4) testPartition15 = testEq "testPartition14" pp5f (partitionGraph pa5) testPartition16 = testEq "testPartition16" pp6f (partitionGraph pa6) testPartition21, testPartition22, testPartition23, testPartition24, testPartition25, testPartition26 :: Test testPartition21 = testEq "testPartition21" pp1 (partitionGraph $ reverse pa1) testPartition22 = testEq "testPartition22" pp2r (partitionGraph $ reverse pa2) testPartition23 = testEq "testPartition23" pp3r (partitionGraph $ reverse pa3) testPartition24 = testEq "testPartition24" pp4r (partitionGraph $ reverse pa4) testPartition25 = testEq "testPartition25" pp5r (partitionGraph $ reverse pa5) testPartition26 = testEq "testPartition26" pp6r (partitionGraph $ reverse pa6) testPartition31, testPartition32, testPartition33, testPartition34, testPartition35, testPartition36 :: Test testPartition31 = testEqv "testPartition31" pa1 (getArcs pp1) testPartition32 = testEqv "testPartition32" pa2 (getArcs pp2f) testPartition33 = testEqv "testPartition33" pa3 (getArcs pp3f) testPartition34 = testEqv "testPartition35" pa4 (getArcs pp4f) testPartition35 = testEqv "testPartition34" pa5 (getArcs pp5f) testPartition36 = testEqv "testPartition36" pa6 (getArcs pp6f) testPartition41, testPartition42, testPartition43, testPartition44, testPartition45, testPartition46 :: Test testPartition41 = testEqv "testPartition41" pa1 (getArcs pp1 ) testPartition42 = testEqv "testPartition42" pa2 (getArcs pp2r) testPartition43 = testEqv "testPartition43" pa3 (getArcs pp3r) testPartition44 = testEqv "testPartition44" pa4 (getArcs pp4r) testPartition45 = testEqv "testPartition45" pa5 (getArcs pp5r) testPartition46 = testEqv "testPartition46" pa6 (getArcs pp6r) testPartition51, testPartition52, testPartition53, testPartition54, testPartition55, testPartition56, testPartition57, testPartition58, testPartition59 :: Test testPartition51 = testEqv "testPartition51" [] (comparePartitions pp1 pp1) testPartition52 = testEqv "testPartition52" [] (comparePartitions pp2f pp2r) testPartition53 = testEqv "testPartition53" [] (comparePartitions pp3f pp3r) testPartition54 = testEqv "testPartition54" [] (comparePartitions pp4f pp4r) testPartition55 = testEqv "testPartition55" [] (comparePartitions pp5f pp5r) testPartition56 = testEqv "testPartition56" [] (comparePartitions pp6f pp6r) testPartition57 = testEqv "testPartition57" [(Nothing,Just $ toPV "b3" [(LF "p",pb4af)])] (comparePartitions pp3f pp4f) testPartition58 = testEqv "testPartition58" [(Nothing,Just pb5a1)] (comparePartitions pp4f pp5f) testPartition59 = testEqv "testPartition59" [(Nothing,Just $ toPV "b4" [(LF "p",PartObj (LV "b5b"))])] (comparePartitions pp5f pp6f) testPartitionSuite :: Test testPartitionSuite = TestList [ testPartition11 , testPartition12 , testPartition13 , testPartition14 , testPartition15 , testPartition16 , testPartition21 , testPartition22 , testPartition23 , testPartition24 , testPartition25 , testPartition26 , testPartition31 , testPartition32 , testPartition33 , testPartition34 , testPartition35 , testPartition36 , testPartition41 , testPartition42 , testPartition43 , testPartition44 , testPartition45 , testPartition46 , testPartition51 , testPartition52 , testPartition53 , testPartition54 , testPartition55 , testPartition56 , testPartition57 , testPartition58 , testPartition59 ] ------------------------------------------------------------ -- GraphPartition compare test with partial matching ------------------------------------------------------------ pgc1a, pgc1b :: PartitionedGraph LabelMem pgc1a = PartitionedGraph [ c11, c12a ] pgc1b = PartitionedGraph [ c11, c12b ] c11, c12a, c12b, c13a, c13b :: GraphPartition LabelMem c11 = toPF "s1" [ (LF "p11",PartObj (LF "o11")) ] c12a = toPF "s2" [ (LF "p21",c13a) , (LF "p22",PartObj (LF "o22")) ] c12b = toPF "s2" [ (LF "p22",PartObj (LF "o22")) , (LF "p21",c13b) ] 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" [(Just (PartObj (LF "o33a")),Just (PartObj (LF "o33b")))] (comparePartitions pgc1a pgc1b) testCompareSuite :: Test testCompareSuite = TestList [ testCompare01 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "basic" testBasicSuite , conv "partiton" testPartitionSuite , conv "compare" testCompareSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/tests/BuiltInMapTest.hs0000644000000000000000000001450613543702315015630 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- -- | -- Module : BuiltInMapTest -- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012, 2013 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental -- Portability : OverloadedStrings -- -- This module contains test cases for accessing built-in variable -- binding modifiers. -- -------------------------------------------------------------------------------- module Main where import qualified Test.Framework as TF import qualified Data.Map as M import Swish.Namespace (makeNSScopedName) import Swish.Ruleset (getMaybeContextAxiom, getMaybeContextRule) import Swish.RDF.BuiltIn ( findRDFOpenVarBindingModifier , findRDFDatatype , rdfRulesetMap , allRulesets ) import Swish.RDF.Datatype.XSD.Integer (typeNameXsdInteger, namespaceXsdInteger) import Swish.RDF.Vocabulary ( swishName , scopeRDF , scopeRDFS , scopeRDFD , namespaceXsdType ) import Test.HUnit ( Test(TestCase,TestList) , assertEqual ) import TestHelpers (conv, testJust) ------------------------------------------------------------ -- Test finding built-in variable binding modifiers ------------------------------------------------------------ testVarMod01, testVarMod02, testVarMod03, testVarMod04, testVarMod05, testVarMod06, testVarMod07 :: Test testVarMod01 = testJust "testVarMod01" $ findRDFOpenVarBindingModifier (swishName "rdfVarBindingUriRef") testVarMod02 = testJust "testVarMod02" $ findRDFOpenVarBindingModifier (swishName "rdfVarBindingDatatyped") testVarMod03 = testJust "testVarMod03" $ findRDFOpenVarBindingModifier (swishName "varFilterNE") testVarMod04 = testJust "testVarMod04" $ findRDFOpenVarBindingModifier (swishName "nullVarBindingModify") testVarMod05 = testJust "testVarMod05" $ findRDFOpenVarBindingModifier (makeNSScopedName namespaceXsdInteger "abs") testVarMod06 = testJust "testVarMod06" $ findRDFOpenVarBindingModifier (makeNSScopedName namespaceXsdInteger "divmod") testVarMod07 = testJust "testVarMod07" $ findRDFOpenVarBindingModifier (makeNSScopedName namespaceXsdInteger "ge") testVarModSuite :: Test testVarModSuite = TestList [ testVarMod01, testVarMod02, testVarMod03, testVarMod04 , testVarMod05, testVarMod06, testVarMod07 -- the following just exposes a few "edge" cases (a Show instance -- and using the namespace part of the swish namespace) , TestCase (assertEqual "show:rdfVarBindingUriRef" (Just "swish:rdfVarBindingUriRef") $ fmap show (findRDFOpenVarBindingModifier (swishName "rdfVarBindingUriRef"))) ] ------------------------------------------------------------ -- Test finding built-in datatypes ------------------------------------------------------------ testDatatype01 :: Test testDatatype01 = testJust "testDatatype01" $ findRDFDatatype typeNameXsdInteger testDatatypeSuite :: Test testDatatypeSuite = TestList [ testDatatype01 ] ------------------------------------------------------------ -- Test finding built-in rulesets ------------------------------------------------------------ testRuleset01 :: Test testRuleset01 = testJust "testRuleset01" $ M.lookup scopeRDF rdfRulesetMap testRulesetSuite :: Test testRulesetSuite = TestList [ testRuleset01 ] ------------------------------------------------------------ -- Test finding arbitrary axioms and rules ------------------------------------------------------------ testFindAxiom01, testFindAxiom02, testFindAxiom03 :: Test testFindAxiom01 = testJust "testFindAxiom01" $ getMaybeContextAxiom (makeNSScopedName scopeRDF "a1") allRulesets testFindAxiom02 = testJust "testFindAxiom02" $ getMaybeContextAxiom (makeNSScopedName scopeRDFS "a01") allRulesets testFindAxiom03 = testJust "testFindAxiom03" $ getMaybeContextAxiom (makeNSScopedName (namespaceXsdType "integer") "dt") allRulesets testFindAxiomSuite :: Test testFindAxiomSuite = TestList [ testFindAxiom01, testFindAxiom02, testFindAxiom03 ] testFindRule01, testFindRule02, testFindRule03, testFindRule04 :: Test testFindRule01 = testJust "testFindRule01" $ getMaybeContextRule (makeNSScopedName scopeRDF "r1") allRulesets testFindRule02 = testJust "testFindRule02" $ getMaybeContextRule (makeNSScopedName scopeRDFS "r1") allRulesets testFindRule03 = testJust "testFindRule03" $ getMaybeContextRule (makeNSScopedName scopeRDFD "r1") allRulesets testFindRule04 = testJust "testFindRule04" $ getMaybeContextRule (makeNSScopedName (namespaceXsdType "integer") "Abs") allRulesets testFindRuleSuite :: Test testFindRuleSuite = TestList [ testFindRule01, testFindRule02, testFindRule03, testFindRule04 ] ------------------------------------------------------------ -- All tests ------------------------------------------------------------ allTests :: [TF.Test] allTests = [ conv "VarMod" testVarModSuite , conv "Datatype" testDatatypeSuite , conv "Ruleset" testRulesetSuite , conv "FindAxiom" testFindAxiomSuite , conv "FindRule" testFindRuleSuite ] main :: IO () main = TF.defaultMain allTests -------------------------------------------------------------------------------- -- -- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, -- 2011, 2012, 2013 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 -- -------------------------------------------------------------------------------- swish-0.10.4.0/scripts/SwishExample.ss0000644000000000000000000001730013543702315015730 0ustar0000000000000000# Extracted from # http://www.ninebynine.org/RDFNotes/Swish/Intro.html # 09 April 2011 # # it is the same as the script in # http://www.ninebynine.org/Software/Swish-0.2.0.html # bar some minor formatting differences. # # -- 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. # NOTE: the automatic prefix declarations are no-longer provided by # Swish # @prefix rdf: . @prefix rdfs: . @prefix rdfd: . @prefix ex: . @prefix pv: . @prefix xsd: . @prefix xsd_integer: . @prefix rs_rdf: . @prefix rs_rdfs: . @prefix : . # -- 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 # The comment (';' to end of line) is included in any message generated 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 -- # # Write graph as Notation3 to standard output. # The comment is included in the output. @write ex:Rule01fwd ; Charles is male and has parent Tom # -- Write graph to file -- # # The comment is included at the head of the file. # (TODO: support for output to Web using HTTP.) @write ex:Rule01fwd ; Charles is male and has parent Tom # -- Read graph from file -- # # Creates a new named graph in the Swish environment. # (TODO: support for input from Web using HTTP.) @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:Input01 :- { ex:foo ex:prop "a" . } ex:Result :- { ex:foo ex:prop _:a . _:a rdf:type rdfs:Resource . } # This is the version from # http://www.ninebynine.org/RDFNotes/Swish/Intro.html#ScriptExample # which does not work. It appears that ex:Step01c can not be proved, # so we split it into two steps in the version below. # #@proof ex:Proof01 ( rs_rdf:rules rs_rdfs:rules ) # @input ex:Input01 # @step rs_rdfs:r3 ( rs_rdfs:a10 rs_rdfs:a39 ) # => ex:Step01a :- { rdfs:Literal rdf:type rdfs:Class . } # @step rs_rdfs:r8 ( ex:Step01a ) # => ex:Step01b :- { rdfs:Literal rdfs:subClassOf rdfs:Resource . } # @step rs_rdfs:r1 ( ex:Input01 ) # => ex:Step01c :- { ex:foo ex:prop _:a . _:a rdf:type rdfs:Literal . } # @step rs_rdfs:r9 ( ex:Step01b ex:Step01c ) # => ex:Step01d :- { _:a rdf:type rdfs:Resource . } # @step rs_rdf:se ( ex:Step01c ex:Step01d ) => ex:Result # @result ex:Result @proof ex:Proof01 ( rs_rdf:rules rs_rdfs:rules ) @input ex:Input01 @step rs_rdfs:r3 ( rs_rdfs:a10 rs_rdfs:a39 ) => ex:Step01a :- { rdfs:Literal rdf:type rdfs:Class . } @step rs_rdfs:r8 ( ex:Step01a ) => ex:Step01b :- { rdfs:Literal rdfs:subClassOf rdfs:Resource . } @step rs_rdf:lg ( ex:Input01 ) => ex:Step01c1 :- { ex:foo ex:prop _:a . _:a rdf:_allocatedTo "a" . } @step rs_rdfs:r1 ( ex:Step01c1 ) => ex:Step01c2 :- { _:a rdf:type rdfs:Literal . } @step rs_rdfs:r9 ( ex:Step01b ex:Step01c2 ) => ex:Step01d :- { _:a rdf:type rdfs:Resource . } @step rs_rdf:se ( ex:Step01c1 ex:Step01c2 ex:Step01d ) => 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 swish-0.10.4.0/scripts/VehicleCapacity.ss0000644000000000000000000000406613543702315016361 0ustar0000000000000000# $Id: VehicleCapacity.ss,v 1.1 2004/02/09 22:22:44 graham Exp $ # # Swish script: vehicle capacity examples # # --------+---------+---------+---------+---------+---------+---------+--------- @prefix ex: . @prefix pv: . @prefix xsd: . @prefix xsd_integer: . @prefix rdfd: . @prefix : . # Deduce total capacity using simple deduction with variable binding modifier ex:Test01Inp :- { _:a1 a :PassengerVehicle ; :seatedCapacity "98"^^xsd:integer ; :standingCapacity "12"^^xsd:integer . } ex:Rule01Ant :- { _:a1 a :PassengerVehicle ; :seatedCapacity ?c1 ; :standingCapacity ?c2 . } ex:Rule01Con :- { _:a1 :totalCapacity ?ct . } @rule ex:Rule1 :- ( ex:Rule01Ant ) => ex:Rule01Con | ( xsd_integer:sum ?ct ?c1 ?c2 ) @ruleset pv:rules1 :- () ; ( ex:Rule1 ) @fwdchain pv:rules1 ex:Rule1 ex:Test01Inp => :t1f @write :t1f ; Forward chain result :t1f # Deduce total capacity using general restriction ex:VehicleRule2 :- { :PassengerVehicle a rdfd:GeneralRestriction ; rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; rdfd:constraint xsd_integer:sum ; rdfd:maxCardinality "1"^^xsd:nonNegativeInteger . } @constraints pv:rules2 :- ( ex:VehicleRule2 ) | xsd:integer @fwdchain pv:rules2 :PassengerVehicle ex:Test01Inp => :t2f @write :t2f ; Forward chain result :t2f @bwdchain pv:rules2 :PassengerVehicle ex:Test01Inp <= :t2b @write :t2b ; Backward chain result :t2b # $Log: VehicleCapacity.ss,v $ # Revision 1.1 2004/02/09 22:22:44 graham # Graph matching updates: change return value to give some indication # of the extent match achieved in the case of no match. # Added new module GraphPartition and test cases. # Add VehicleCapcity demonstration script. # swish-0.10.4.0/scripts/SwishTest.ss0000644000000000000000000001657713543702315015273 0ustar0000000000000000# $Id: SwishTest.ss,v 1.8 2003/12/18 20:46:24 graham Exp $ # # Swish script: test script # # --------+---------+---------+---------+---------+---------+---------+--------- @prefix rdf: . @prefix rdfs: . @prefix ex: . @prefix pv: . @prefix xsd: . @prefix xsd_integer: . @prefix rdfd: . @prefix rs_rdf: . @prefix rs_rdfs: . @prefix : . # Simple inference tests ex:VehicleRule :- { :PassengerVehicle a rdfd:GeneralRestriction ; rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; rdfd:constraint xsd_integer:sum . } ex:VehicleRule1 :- { :PassengerVehicle1 a rdfd:GeneralRestriction ; rdfd:onProperties (:totalCapacity :seatedCapacity :standingCapacity) ; rdfd:constraint xsd_integer:sum ; rdfd:maxCardinality "1"^^xsd:nonNegativeInteger . } @merge ( ex:VehicleRule ex:VehicleRule1 ) => ex:VehicleRules @write ex:VehicleRules ; Vehicle rules file @read ex:VehicleRuleFile @asserteq ex:VehicleRuleFile ex:VehicleRules ; Compare read and internal graphs ex:Test01Inp :- { _:a1 a :PassengerVehicle ; :seatedCapacity "30"^^xsd:integer ; :standingCapacity "20"^^xsd:integer . } ex:Test01Fwd :- { _:a1 :totalCapacity "50"^^xsd:integer . } 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 . } ex:Test01Bwd :- ( ex:Test01Bwd0 ex:Test01Bwd1 ) @constraints pv:rules :- ( ex:VehicleRule ex:VehicleRule1 ) | xsd:integer @fwdchain pv:rules :PassengerVehicle ex:Test01Inp => :t1f # @write :t1f ; Forward chain result :t1f @asserteq :t1f ex:Test01Fwd ; Forward chain test @bwdchain pv:rules :PassengerVehicle ex:Test01Inp <= :t1b # @write :t1b ; Backward chain result :t1b # @write ex:Test01Bwd ; Backward chain expected ex:Test01Bwd @asserteq :t1b ex:Test01Bwd ; Backward chain test @assertin ex:Test01Bwd0 :t1b ; Backward chain component test (0) @assertin ex:Test01Bwd1 :t1b ; Backward chain component test (1) # Proof test, using simple built-in RDF ruleset # # To prove: # ex:foo ex:prop "a" . # RDFS-entails # ex:foo ex:prop _:x . # _:x rdf:type rdfs:Resource . # ex:Input01 :- { ex:foo ex:prop "a" . } ex:Step01a :- { rdfs:Literal rdf:type rdfs:Class . } ex:Step01b :- { rdfs:Literal rdfs:subClassOf rdfs:Resource . } ex:Step01c :- { ex:foo ex:prop _:a . _:a rdf:_allocatedTo "a" . } ex:Step01d :- { _:a rdf:type rdfs:Literal . } ex:Step01e :- { _:a rdf:type rdfs:Resource . } ex:Result :- { ex:foo ex:prop _:a . _:a rdf:type rdfs:Resource . } @proof ex:Proof01 ( rs_rdf:rules rs_rdfs:rules ) @input ex:Input01 @step rs_rdfs:r3 ( rs_rdfs:a10 rs_rdfs:a39 ) => ex:Step01a @step rs_rdfs:r8 ( ex:Step01a ) => ex:Step01b @step rs_rdf:lg ( ex:Input01 ) => ex:Step01c @step rs_rdfs:r1 ( ex:Step01c ) => ex:Step01d @step rs_rdfs:r9 ( ex:Step01b ex:Step01d ) => ex:Step01e @step rs_rdf:se ( ex:Step01c ex:Step01e ) => ex:Result @result ex:Result #@fwdchain rs_rdfs:rules rs_rdfs:r9 ( ex:Step01b ex:Step01c ) => ex:Step01dd #@write ex:Step01b ; ex:Step01b #@write ex:Step01c ; ex:Step01c #@write ex:Step01dd ; Forward chain simple rule rs_rdfs:r9 # Simple deduction rule test ex:Rule01Ant :- { ?p ex:son ?o . } ex:Rule01Con :- { ?o a ex:Male ; ex:parent ?p . } ex:Rule02Ant :- { ?p ex:daughter ?o . } ex:Rule02Con :- { ?o a ex:Female ; ex:parent ?p . } ex:Rule03Ant :- { ?o1 a ex:Male ; ex:parent ?p . ?o2 a ex:Female ; ex:parent ?p . } ex:Rule03Con :- { ?o1 ex:sister ?o2 . ?o2 ex:brother ?o1 . } @rule ex:Rule01 :- ( ex:Rule01Ant ) => ex:Rule01Con @rule ex:Rule02 :- ( ex:Rule02Ant ) => ex:Rule02Con @rule ex:Rule03 :- ( ex:Rule03Ant ) => ex:Rule03Con @ruleset ex:rules :- () ; ( ex:Rule01 ex:Rule02 ex:Rule03 ) @proof ex:Proof02 ( ex:rules ) @input ex:inp :- { _:p ex:son ex:s ; ex:daughter ex:d . } @step ex:Rule01 ( ex:inp ) => ex:st1 :- { ex:s a ex:Male ; ex:parent _:a . } @step ex:Rule02 ( ex:inp ) => ex:st2 :- { ex:d a ex:Female ; ex:parent _:a . } @step ex:Rule03 ( ex:st1 ex:st2 ) => ex:res :- { ex:s ex:sister ex:d . ex:d ex:brother ex:s . } @result ex:res #ex:proof01inp :- { _:p ex:son ex:s ; ex:daughter ex:d . } #@fwdchain ex:rules ex:Rule01 ex:proof01inp => ex:rule01fwd #@write ex:rule01fwd ; Forward chain simple rule 01 #@fwdchain ex:rules ex:Rule02 ex:proof01inp => ex:rule02fwd #@write ex:rule02fwd ; Forward chain simple rule 02 #@fwdchain ex:rules ex:Rule03 (ex:rule01fwd ex:rule02fwd) => ex:rule03fwd #@write ex:rule03fwd ; Forward chain simple rule 03 # TODO: test rule with variable binding modifiers # Merge, I/O and compare tests ex:TestMerge :- { _:b1 a :PassengerVehicle . _:b1 :totalCapacity "50"^^xsd:integer . _:b1 :seatedCapacity "30"^^xsd:integer . _:b2 a :PassengerVehicle . _:b2 :totalCapacity "50"^^xsd:integer . _:b2 :standingCapacity "20"^^xsd:integer . } @merge ( ex:Test01Bwd0 ex:Test01Bwd1 ) => ex:tmout @asserteq ex:TestMerge ex:tmout ; Check merged graph @write ex:tmout ; Test graph merge and read/write @write ex:TestMerge ; Test graph merge and read/write @read ex:tmin @asserteq ex:TestMerge ex:tmin ; Check graph read back @compare ex:tmin ex:tmout # @compare ex:tmin ex:VehicleRule # $Log: SwishTest.ss,v $ # Revision 1.8 2003/12/18 20:46:24 graham # Added xsd:string module to capture equivalence of xsd:string # and plain literals without a language tag # # Revision 1.7 2003/12/11 19:11:07 graham # Script processor passes all initial tests. # # Revision 1.6 2003/12/10 14:43:00 graham # Backup. # # Revision 1.5 2003/12/10 03:48:58 graham # SwishScript nearly complete: BwdChain and PrrofCheck to do. # # Revision 1.4 2003/12/08 23:55:36 graham # Various enhancements to variable bindings and proof structure. # New module BuiltInMap coded and tested. # Script processor is yet to be completed. # # Revision 1.3 2003/12/05 02:31:32 graham # Script parsing complete. # Some Swish script functions run successfully. # Command execution to be completed. # # Revision 1.2 2003/12/04 02:53:28 graham # More changes to LookupMap functions. # SwishScript logic part complete, type-checks OK. # # Revision 1.1 2003/12/01 18:51:38 graham # Described syntax for Swish script. # Created Swish scripting test data. # Edited export/import lists in Swish main program modules. # swish-0.10.4.0/README.md0000644000000000000000000000747714403410712012547 0ustar0000000000000000 [![Hackage](https://img.shields.io/hackage/v/swish.svg)](https://hackage.haskell.org/package/swish) [![Pipeline status](https://gitlab.com/dburke/swish/badges/main/pipeline.svg)](https://gitlab.com/dburke/swish/-/commits/main) [![Dependencies status](https://img.shields.io/hackage-deps/v/swish.svg)](http://packdeps.haskellers.com/feed?needle=swish) # Introduction Swish - which stands for Semantic Web Inference Scripting in Haskell - was written by Graham Klyne as a framework, written in the purely functional programming language Haskell, for performing deductions in RDF data using a variety of techniques. Swish was conceived as a toolkit for experimenting with RDF inference, and for implementing stand-alone RDF file processors (usable in similar style to CWM, but with a view to being extensible in declarative style through added Haskell function and data value declarations). One of the aims was to explore Haskell as "[a scripting language for the Semantic Web](http://www.ninebynine.org/RDFNotes/Swish/Intro.html)". It was updated from version 0.2.1 by Vasili I Galchin so that it would build with the current version of GHC, and [released on Hackage](http://hackage.haskell.org/package/swish-0.2.1). Since then it has been updated to take advantage of recent developments in the Haskell ecosystem, add support for the NTriples and Turtle serialisation formats, and a number of convenience functions. Development is done on GitLab at https://gitlab.com/dburke/swish and the previous [bitbucket site](https://bitbucket.org/doug_burke/swish/) is now *outdated* (you may also find a version on GitHub which should also be ignored). I attempt to keep Swish buildable on recent GHC versions but it is done on a best-effort basis, so support for "older" versions of GHC is not guaranteed. # Aim Current development has essentially stalled - I was using this as a RDF library for I/O with limited querying rather than for inferencing or use as a flexible graph-processing library (e.g. for extensions to non-RDF models) - but that project has stopped. # Copyright (c) 2003, 2004 G. Klyne (c) 2009 Vasili I Galchin (c) 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023 Doug Burke All rights reserved. # License [LGPL V2.1](https://gitlab.com/dburke/swish/raw/master/LICENSE) # Haskell and the Semantic Web Other Haskell packages for RDF support include * [rdf4h](http://hackage.haskell.org/package/rdf4h) * [hsparql](http://hackage.haskell.org/package/hsparql) * [hasparql-client](http://hackage.haskell.org/package/hasparql-client) # Installation The following commands will install a command-line tool `Swish` along with the modules in the `Swish` namespace; documentation can be found [on Hackage](http://hackage.haskell.org/package/swish). ## With cabal Install a recent version of the [Haskell platform](http://hackage.haskell.org/platform/) and then try % cabal update % cabal install swish ## With stack Swish is available as part of the stackage curated package set. There are several stack configuration files, for different GHC versions: % cd swish % stack install % STACK_YAML=stack-9.2.yaml stack install % STACK_YAML=stack-9.0.yaml stack install % STACK_YAML=stack-8.10.yaml stack install % STACK_YAML=stack-8.8.yaml stack install % STACK_YAML=stack-8.6.yaml stack install % STACK_YAML=stack-8.4.yaml stack install % STACK_YAML=stack-8.2.yaml stack install % STACK_YAML=stack-8.0.yaml stack install % STACK_YAML=stack-7.10.yaml stack install ## With nix There is now support for building with the [nix](https://nixos.org/nix/) package manager: % nix-shell ... nix-shell% cabal test or % nix-shell --argstr compiler ghc921 ... nix-shell% cabal test or, with a flake, either of % nix build % nix develop dev[swish] > cabal test swish-0.10.4.0/CHANGELOG0000644000000000000000000005621414403410712012473 0ustar00000000000000000.10.4.0: Allow compilation with GHC 9.6.1 (base 4.18). 0.10.3.0: We can now compile with GHC 9.4.4, so support for base 4.17 has been added. Swish will not build with earlier versions of GHC 9.4, but I don't know how best to mark these as "do not install". Added autogen-modules fields for Paths_swish to appease Stack's sdist check. 0.10.2.0: Check we can build with stack lts-19 (GHC 9.0) and spaces around operators to please GHC 9.2. Dropped support for time < 1.5 as it hasn't been tested for a long while. 0.10.1.0: Support building with GHC 9.2. The Swish.Datatype module complains about non-exhaustive matches but it's in an irrefutable match so I'm not sure how to avoid this. 0.10.0.9: Support the semigroups 0.20 and initial support of the text 2.0 release (not all dependencies have been updated yet). 0.10.0.8: Support hashable 1.4 release. 0.10.0.7: Support time 1.13 release. 0.10.0.6: Support recent time, network-uri, and semigroups releases. Bumped the minimum base version to 4.8 (GHC 7.10). 0.10.0.5: Support for base from ghc 9.0. 0.10.0.4: Support for base from ghc 8.10. Switched tested version to 8.8.3 in swish.cabal. 0.10.0.3: No change to 0.10.0.3 other than a polyparse constraint (changed '<= 1.13' to '< 1.14'), moved to GHC 8.8 as the build version, and updated the copyright year. Removed the GHC 7.8 stack YAML file as it won't work with recent stack versions. 0.10.0.2: Switched hosting from bitbucket to gitlab (and mercurial to git). The new "home" location is https://gitlab.com/dburke/swish Bumped base to a maximum of 4.14 to support GHC 8.8, and bumped hashable to support version 1.3. Add conditional rules to avoid warnings when building with GHC 8.8. 0.10.0.1: Bump to support polyparse and its GHC 8.6 compatibility. 0.10.0.0: Updated packages to support building with ghc 8.6 (increase base and containers limit). The reason for the version bump is that there has been some internal build cleanup and removal of un-needed imports (thanks to weeder), which was done a while ago and I now forget whether there were any changes due to imported instances, so it is safer to increase the minor version number. There has been *no* change to functionality. Default stack.yaml file is now ghc 8.4, and added a ghc 8.2 version. 0.9.2.1: Updated the minimum base package to 4.5.0.0 (GHC 7.4.1), and removed some old code for supporting older GHC/package versions. There are some warnings when compiling with GHC pre version 8 (redudant imports) which I am currently too lazy to fix, but patches are welcome. Support for building with older versions of GHC is on a best-effort basis. Applied some HLint suggestions. Updated to allow time-1.9.1 (but not time-1.9.0). Updated to lts 11.1 in stack.yaml. 0.9.2.0: Initial support for ghc 8.4. Updated to lts 10.8 in stack.yaml so was able to drop extra intern dependency version. Now builds with -Wcompat if ghc 8.0 or later is used. 0.9.1.10: Updated the upper bound on time to work with ghc 8.2.1. Updated stack.yaml to use lts 9.1. 0.9.1.9: Updated the upper bound on HUnit. This only affects the tests. Finally added a stack.yaml file (partly addressing issue #27). 0.9.1.8: Updated the upper bound on polyparse and directory. Fixed build failure of RDFGraphTest with time >= 1.6. Updated the copyright years in README.md. 0.9.1.7: Turns out one of the constraints is needed by GHC 7.6. 0.9.1.6: Updated dependencies to support GHC 8.0 (RC1) and updated the code to remove the un-needed constraints pointed out to me by the new compiler. 0.9.1.5: Removed the developer flag as it causes problems with 'cabal upload' and added 2015 to the copyright statement in the cabal file. There are no code changes compared to 0.9.1.3. 0.9.1.4: Updated the upper bound on the semigroups and HUnit dependencies. This never got released on hackage due to a disagreement between myself and Cabal. 0.9.1.3: Updated ghc 7.10 support. 0.9.1.2: Updated the upper bound on the polyparse dependency and fixed an error in the Swish.RDF.Query documentation (issue #25). Initial support for ghc 7.10. The list of changes has been removed from the cabal file since it is in the CHANGELOG. 0.9.1.1: Updated the upper bound on the semigroups and polyparse dependencies. 0.9.1.0: The network-uri flag has been added, which uses the network-uri package to provide Network.URI. This has lead to the minimum version of the network package being bumped to 2.4.0.0 to avoid some CPP issues during building. The Network.URI.Ord module now really does nothing. Updated the upper bound on the text dependency (requires an update to intern to use). Updated the upper bound on the time dependency to 1.5 (at this time the test suite will not build due to a failing dependency, so it is untested). 0.9.0.15: Updated the upper bound on the semigroups dependency. Renamed README to README.md 0.9.0.14: Updated the upper bound on the network dependency. 0.9.0.13: Updated the upper bound on the semigroups dependency (Issue #20). 0.9.0.12: Updated the upper bound on the text dependency to include version 1.1 (requires an update to semigroups to use). 0.9.0.11: Hackage has a better chance of finding the CHANGELOG file if it is included in the distribution! There are no changes to the library or examples. 0.9.0.10: Renamed CHANGES to CHANGELOG in the hope it will get picked up by Hackage. There are no changes to the library or examples. 0.9.0.9: Updated the upper bound on the semigroups dependency (thanks to Leif Warner). Updated the upper bound on the text dependency (however, requires changes to intern and semigroups to use). 0.9.0.8: Updated the upper bound on the semigroups dependency (thanks to Leif Warner). Display library version when running the runw3ctests executable and ensure there is a space between file name and test result in the screen output. 0.9.0.7 Minor documentation fix for Swish.RDF.Graph.quote. 0.9.0.6: Turtle/N3 output: \f characters in literals are converted to \u000C to work around some interoperability issues. Changed the test handling to use test-framework. 0.9.0.5: Turtle/N3 output: more changes for string literals containing double-quote characters. N3 Parser: parsing of string literals within three quote marks has been updated to match the Turtle parser. Turtle Parser: a few more error messages have been added. 0.9.0.4: Turtle parser: updated to the Candidate Recommendation (19 February 2013) specification; added minor improvements to error messages when given invalid syntax. As part of the upgrade, there is no longer a default namespace set up for the empty prefix and numeric literals are no-longer converted into a 'canonical' form. Turtle/N3 output: improved string formatting (better handling of string literals with three or more consecutive " characters); blank node handling has been improved but the output may not be as elegant. NTriples parser: now accepts upper-case language tags such as en-UK (case is preserved). Swish.QName.LName names can now contain #, : and / characters. Added tests for the Turtle parser and formatter. The new w3ctests flag will build the runw3ctests executable, which will run the W3C Turtle tests (if downloaded from http://www.w3.org/2013/TurtleTests/). Minor fixes and additions to the documentation. 0.9.0.3: Fix minor Haddock issue with Swish.RDF.Parser.Utils.appendURIs. 0.9.0.2: Updated the upper bound on the polyparse dependency. 0.9.0.1: Updated the upper bound on the semigroups dependency (thanks to Leif Warner). 0.9.0.0: The module now builds against version 1.2 or 1.1 of the hashable package; as there have been significant changes to hashable in the 1.2 release I have decided to bump up the version number to 0.9 as a precaution. Fix failing test on 64-bit GHC (no library change). Very minor hlint changes. 0.8.0.3: Remove hashtable restriction (rewrite tests), remove binary constraint as it was apparently unneeded. Updates to support network version 2.4.0.0: the package now provides an Ord instance for Network.URI so Network.URI.Ord is now a no-op if network >= 2.4.0.0 is installed; fix up code to handle change to the API of relativeTo. 0.8.0.2: Restrict hashable to < 1.1.2.4 to try and avoid test failures - see http://travis-ci.org/#!/DougBurke/swish/builds/2360859 This is a hack and the tests should be updated. Updated directory constraint to allow 1.2 on ghc 7.6. 0.8.0.1: Internal changes to Turtle/N3 formatting. No user-visible changes. 0.8.0.0: The LDGraph class now uses Set (Arc lb), rather than [Arc lb], for setArcs, getArcs, and update. Several data types - e.g. NSGraph - now use sets rather than lists. There are a number of API tweaks - e.g. the addition of Ord constraints and the removal of Functor, Foldable, and Traversable instances. Not all list of Arcs have been converted since a review is needed to see where it makes sense and where it does not. This definitely speeds up some operations but a full analysis has not been attempted. Replaced used of Data.LookupMap with Data.Map.Map. This has led to the removal of a number of language extensions from some modules. Added Network.URI.Ord to provide an ordering for URIs. A few other minor changes have been made: the removal of subset and equiv from Swish.Utils.ListHelpers; the ordering used for RDFLabel values has changed; added a Monoid instance for VarBinding; added Ord instances for a number of containers; removed some un-needed constraints; added Network.URI.Ord. The containers upper limit has been increased to support version 0.5. 0.7.0.2: Swish.QName.LName now requires all characters to be ASCII. This avoids downstream later when trying to convert a QName to a URI. 0.7.0.1: URI parsing has changed slightly. The only user-visible change is that error messages will be slightly different, in particular when given an IRI in Turtle or NTriples format. Unfortunately IRIs are still not supported. 0.7.0.0: 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.*. 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.*. - 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. - Parsing modules are now in the Swish.RDF.Parser hierarchy and Swish.RDF.RDFParser has been renamed to Swish.RDF.Parser.Utils. - Formatting modules are now in the Swish.RDF.Formatter hierarchy. - RDF literals are now stored using the Lit, LangLit, or TypedLit constructors (from RDFLabel) rather than using just Lit. Language codes are now represented by Swish.RDF.Vocabulary.LanguageTag rather than as a ScopedName. - 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. - Make use of Data.List.NonEmpty in a few cases. - Removed mkTypedLit from Swish.RDF.RDFParser; use Swish.RDF.RDFDatatype.makeDataTypedLiteral instead. - Removed asubj, apred and aobj from Swish.RDF.GraphClass and Swish.RDF.RDFGraph; use arcSubj, arcPred or arcObj instead. - Clarified that Swish.RDF.RDFDatatypeXsdDecimal is for xsd:decimal rather than xsd:double. - Removed the containedIn element of the LDGraph type class as it was un-used. The arguments to setArcs have been flipped, replaceArcs removed, add renamed to addGraphs, and emptyGraph added. - Removed various exported symbols from a range of modules as they were un-used. - Use Word32 rather than Int for label indexes (Swish.GraphMatch.LabelIndex) and in the bnode counts when formatting to N3/Turtle. - 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. - Removed the Swish.Utils.MiscHelpers module and moved single-use functionality out of Swish.Utils.ListHelpers. - Removed partCompareOrd, partCompareMaybe, partCompareListOrd and partCompareListPartOrd from Swish.Utils.PartOrderedCollection. - Do not define swap if using GHC >= 7.0.1. - Bump the upper constraint on the containers package to include version 0.5. - Support version 0.9 of intern using conditional compilation in Data.Interned.URI (for ghc 7.4) - Switch to Control.Exception.try from System.IO.Error.try to avoid complaints from ghc 7.4.2 0.6.5.3: - Updated cabal file so that tests depend on the library rather than individual modules. - fix intern to 0.8 for ghc < 7.4 and 0.8.* for greater 0.6.5.2: - Upgrade polyparse upper limit to include version 1.8. 0.6.5.1: - Haddock fixes. 0.6.5.0: - Dependency updates (updated filepath and removed array). 0.6.4.0: - Added support for xsd:decimal with Swish.RDF.RDFDatatypeXsdDecimal and Swish.RDF.MapXsdDecimal thanks to William Waites (). 0.6.3.0: - Added Swish.RDF.Vocabulary.SIOC. 0.6.2.1: - hackage build fixes only 0.6.2.0: - Split out vocabularies into Swish.RDF.Vocabulary.DublinCore, Swish.RDF.Vocabulary.FOAF, Swish.RDF.Vocabulary.Geo, Swish.RDF.Vocabulary.OWL, Swish.RDF.Vocabulary.RDF, and Swish.RDF.Vocabulary.XSD (some of these are new and additional terms added to the pre-existing vocabularies). A few have also been added to Swish.RDF.RDFGraph. - Minimum Cabal version has been updated to 1.9.2 as the tests have been converted to take advantage of the support now in Cabal; this means that the tests flag has been replaced by the --enable-tests option. - Change to the internal labelling of the RDFS container-property axioms in Swish.RDF.RDFProofContext. - Moved src/ to app/, and took advantage of the emptiness to move the library code into src/. 0.6.1.2: - corrected mtl constraint from >= 1 to >= 2 as the code does not build with mtl=1 and increased the upper limit on time to 1.4. 0.6.1.1: - minor improvements to error message when parsing Turtle, N3 or Ntriples format; a fragment of the remaining text to be parsed is included to provide some context for the user (it is still not as useful as the error message provided when parsec was being used). 0.6.1.0: - add support for reading and writing Turtle format and the Swish.RDF.TurtleFormatter and Swish.RDF.TurtleParser modules. No tests are provided at this time, although the parser handles most of the W3C test files; the issues include Network.URI not recognizing some IRI's and issues with equating XSD decimal and double values due to canonicalization. 0.6.0.1: - use the hashing interface provided by Data.Hashable rather than Swish.Utils.MiscHelpers. 0.6.0.0: - use the intern package to create Data.Interned.URI and use this within QName to speed up the equality check. 0.5.0.3: - Missed a FlexibleInstances pragma for ghc 7.2. 0.5.0.2: - Removed random and bytesttring package constraints and moved HUnit constraint to only apply if the tests flag is used. Added FlexibleInstances pragma for ghc 7.2 compatability. 0.5.0.1: - updated package constraints in cabal file to try and support building with ghc 7.2. No code change. 0.5.0.0: - The constructors for ScopedName and QName have been removed in order to allow a simple experimental optimisation (partly added in 0.4.0.0). A similar change has been added for Namespace (but no optimisation). 0.4.0.0: - Use polyparse rather than parsec-2 for parsing. As part of this, the parsing is done using Text rather than String values, where sensible. Some parsing should be faster now, but that is more due to a better use of parser combinators than differences in the parsing library used. No serious attempt at optimisation has been attempted. Unfortunately the error messages created on invalid input are significantly less helpfull than in the previous version. - removed Swish.Utils.DateTime and Swish.Utils.TraceHelpers - removed the following exported symbols from Swish.Utils.LookupMap: mapSortByKey, mapSortByVal - removed the following exported symbols from Swish.Utils.ListHelpers: allf, anyf, combinations, ffold, hasPartitions, mapset, pairsUngroup, powerSequences, powerSequences_inf - removed the following exported symbols from Swish.Utils.MiscHelpers: assert, stricmp, lower, quote - removed _ from exported symbols; the conversion is mainly to camel case but some may retain lower case parts (e.g. xxx_1_1_inv to xxx11inv). - Namespace now uses Maybe Text to store the optional prefix rather than an ad-hoc ""/"?" solution and URI rather than String for the URI. The local part of ScopedName is now Text. QName also uses URIs and no longer exports the constructor so newQName or related should be used to create QNames. We have currently lost N3 formatting of the default prefix (any default prefix elements end up getting written out fully qualified). The output is still valid N3 but perhaps not what you'd expect. 0.3.2.1: - use foldl' rather than foldl in some modules - Swish.Utils.*: - marked routines as deprecated 0.3.2.0: - Swish.RDF.N3Parser: - the parser no longer has a set of pre-defined namespaces with the aim of reducing un-needed statements on output. There is no API change worthy of a bump of the minor version but the behavioural change is large enough to make it worth while. 0.3.1.2: - Swish.RDF.RDFGraph: - toRDFGraph now uses the supplied labels to set up the namespace rather than using an empty namespace map. - minor documentation improvements. 0.3.1.1: - N3 I/O: - strings ending in a double-quote character are now written out correctly. - xsd:double values are not written using XSD canonical form/capital E but with using a lower-case exponent. - in input, xsd:double literals are converted to XSD canonical form (as stored in 'RDFLabel'), which can make simple textual comparison of literals fail. - RDFLabel: - the Eq instance now ignores the case of the language tag for literals - the Show instance uses the XSD canonical form for xsd:boolean, xsd:integer, xsd:decimal and xsd:double literals. - The ToRDFLable and FromRDFLabel classes replicate existing functionality in Swish.RDF.RDFDatatype; this should be cleaned up. 0.3.1.0: - NSGraph: - added Monoid instance with a Label constraint. - RDFLabel: - added IsString instance. - added ToRDFLabel and FromRDFLabel type classes for converting to and from RDFLabel along with instances for some standard Haskell types. - RDFTriple: - added toRDFTriple and fromRDFTriple functions that take advantage of the To/FromRDFLabel typeclasses to ease conversion from/to Arcs. - QName and ScopedName: - added IsString instance. - UTCTime support (To/FromRDFLabel) has required adding old-locale and time to the package constraints. - added xsd_dateTime export to Swish.RDF.Vocabulary. - added Swish and Swish.RDF modules for documentation purposes. - marked Swish.Utils.DateTime as deprecated. - the N3 formatter now writes true, 1, 1.2, 1.2e34 rather than "true"^^xsd:boolean, "1"^^xsd:integer, "1.2"^^xsd:decimal and "1.2e34"^^xsd:double. - improved test coverage. 0.3.0.3: - changed scripts/SwishExample.ss script so that the proof succeeds. - minor documentation improvements, including the addition of the Swish script format in Swish.RDF.SwishScript. - minor changes to behavior of Swish in several edge cases. 0.3.0.2: - bugfix: stop losing triples with a bnode subject when using the N3 Formatter which also makes the scripts/SwishTest.ss script run successfully. - several commands in Swish scripts now create screen output as an aid to debugging. - added the developer flag. 0.3.0.1: - updated 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. 0.2.1 to 0.3.0.0: - Renamed module hierarchy from Swish.HaskellRDF.* Swish.HaskellUtils.* to Swish.RDF.* Swish.Utils.* - removed modules, either because un-needed or replaced by other libraries: *) replaced with Data.Traversable instances Swish.HaskellUtils.FunctorM *) replaced with routines from Network.URI Swish.HaskellRDF.ProcessURI Swish.HaskellRDF.ParseURI *) copy of a Parsec module Swish.HaskellRDF.ParsecLanguage *) Replaced with Data.List.sort as only used the stableQuickSort routine Swish.HaskellRDF.Sort.* *) Replaced use with simple parsec parser Swish.HaskellRDF.Dfa.Dfa *) Replaced with 'Either String' Swish.HaskellUtils.ErrorM *) Un-needed Swish.HaskellRDF.Parse Swish.HaskelUtils.AccumulateM Swish.HaskellUtils.TestHelpers - removed Either String instance from ErrorM - should now compile with mtl-2 - added upper and lower bounds to package dependencies - a number of Test executables have been removed, either because of a removed module or missing data files. - updated Haddock documentation to build - added the following flags tests - compile tests or not? hpc - compile tests with -hpc? - support for the NTriples format has been added (e.g. the -nt flag in Swish) - the N3 parser and formatter have been re-written to better match the latest specification. Some previously valid N3 files will likely no-linger parse since support for constructs like 'this' and ':-' have been removed. The N3 parser does not handle @forAll statements and ignores any @forSome statements. It is also slower than the original parser. The formatter has been updated to make better use of the '[]', '()' and '{}' syntactic short cuts. Strings containing "unexpected" escape combinations - such as \a - may not be handled correctluy. - change in behavior of Swish command-line tool when given invalid arguments as it now errors out if given an invalid argument before processing any input. swish-0.10.4.0/stack.yaml0000644000000000000000000000013114277171470013253 0ustar0000000000000000flags: {} packages: - '.' # Match the version used in .gitlab-ci.yml resolver: lts-19.19 swish-0.10.4.0/default.nix0000644000000000000000000000011614277002403013416 0ustar0000000000000000{ compiler ? "ghc902" }: (import ./release.nix { compiler = compiler; }).exe swish-0.10.4.0/shell.nix0000644000000000000000000000012014277002356013103 0ustar0000000000000000{ compiler ? "ghc902" }: (import ./release.nix { compiler = compiler; }).shell swish-0.10.4.0/flake.nix0000644000000000000000000000257714305465575013110 0ustar0000000000000000{ # inspired by: https://serokell.io/blog/practical-nix-flakes#packaging-existing-applications description = "Swish: a semantic web toolkit for Haskell (experimantal)"; inputs.nixpkgs.url = "nixpkgs"; outputs = { self, nixpkgs }: let supportedSystems = [ "x86_64-linux" "x86_64-darwin" ]; # supportedSystems = [ "x86_64-linux" ]; forAllSystems = f: nixpkgs.lib.genAttrs supportedSystems (system: f system); nixpkgsFor = forAllSystems (system: import nixpkgs { inherit system; overlays = [ self.overlay ]; }); in { overlay = (final: prev: { swish = final.haskellPackages.callCabal2nix "swish" ./. {}; }); packages = forAllSystems (system: { swish = nixpkgsFor.${system}.swish; }); defaultPackage = forAllSystems (system: self.packages.${system}.swish); checks = self.packages; devShell = forAllSystems (system: let haskellPackages = nixpkgsFor.${system}.haskellPackages; in haskellPackages.shellFor { packages = p: [self.packages.${system}.swish]; withHoogle = true; buildInputs = with haskellPackages; [ haskell-language-server hlint cabal-install ]; # Change the prompt to show that you are in a devShell shellHook = "export PS1='\\e[1;34mdev[swish] > \\e[0m'"; }); }; } swish-0.10.4.0/flake.lock0000644000000000000000000000077414305465575013237 0ustar0000000000000000{ "nodes": { "nixpkgs": { "locked": { "lastModified": 1662096612, "narHash": "sha256-R+Q8l5JuyJryRPdiIaYpO5O3A55rT+/pItBrKcy7LM4=", "owner": "NixOS", "repo": "nixpkgs", "rev": "21de2b973f9fee595a7a1ac4693efff791245c34", "type": "github" }, "original": { "id": "nixpkgs", "type": "indirect" } }, "root": { "inputs": { "nixpkgs": "nixpkgs" } } }, "root": "root", "version": 7 } swish-0.10.4.0/.hlint.yaml0000644000000000000000000000024113767237337013354 0ustar0000000000000000# HLint configuration file # https://github.com/ndmitchell/hlint ########################## - ignore: {name: Use camelCase} - ignore: {name: Use fewer imports} swish-0.10.4.0/LICENSE0000644000000000000000000006363713543702315012304 0ustar0000000000000000 GNU LESSER GENERAL PUBLIC LICENSE Version 2.1, February 1999 Copyright (C) 1991, 1999 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. [This is the first released version of the Lesser GPL. It also counts as the successor of the GNU Library Public License, version 2, hence the version number 2.1.] Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public Licenses are intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This license, the Lesser General Public License, applies to some specially designated software packages--typically libraries--of the Free Software Foundation and other authors who decide to use it. You can use it too, but we suggest you first think carefully about whether this license or the ordinary General Public License is the better strategy to use in any particular case, based on the explanations below. When we speak of free software, we are referring to freedom of use, not price. Our General Public Licenses are designed to make sure that you have the freedom to distribute copies of free software (and charge for this service if you wish); that you receive source code or can get it if you want it; that you can change the software and use pieces of it in new free programs; and that you are informed that you can do these things. To protect your rights, we need to make restrictions that forbid distributors to deny you these rights or to ask you to surrender these rights. These restrictions translate to certain responsibilities for you if you distribute copies of the library or if you modify it. For example, if you distribute copies of the library, whether gratis or for a fee, you must give the recipients all the rights that we gave you. You must make sure that they, too, receive or can get the source code. If you link other code with the library, you must provide complete object files to the recipients, so that they can relink them with the library after making changes to the library and recompiling it. And you must show them these terms so they know their rights. We protect your rights with a two-step method: (1) we copyright the library, and (2) we offer you this license, which gives you legal permission to copy, distribute and/or modify the library. To protect each distributor, we want to make it very clear that there is no warranty for the free library. Also, if the library is modified by someone else and passed on, the recipients should know that what they have is not the original version, so that the original author's reputation will not be affected by problems that might be introduced by others. Finally, software patents pose a constant threat to the existence of any free program. We wish to make sure that a company cannot effectively restrict the users of a free program by obtaining a restrictive license from a patent holder. Therefore, we insist that any patent license obtained for a version of the library must be consistent with the full freedom of use specified in this license. Most GNU software, including some libraries, is covered by the ordinary GNU General Public License. This license, the GNU Lesser General Public License, applies to certain designated libraries, and is quite different from the ordinary General Public License. We use this license for certain libraries in order to permit linking those libraries into non-free programs. When a program is linked with a library, whether statically or using a shared library, the combination of the two is legally speaking a combined work, a derivative of the original library. The ordinary General Public License therefore permits such linking only if the entire combination fits its criteria of freedom. The Lesser General Public License permits more lax criteria for linking other code with the library. We call this license the "Lesser" General Public License because it does Less to protect the user's freedom than the ordinary General Public License. It also provides other free software developers Less of an advantage over competing non-free programs. These disadvantages are the reason we use the ordinary General Public License for many libraries. However, the Lesser license provides advantages in certain special circumstances. For example, on rare occasions, there may be a special need to encourage the widest possible use of a certain library, so that it becomes a de-facto standard. To achieve this, non-free programs must be allowed to use the library. A more frequent case is that a free library does the same job as widely used non-free libraries. In this case, there is little to gain by limiting the free library to free software only, so we use the Lesser General Public License. In other cases, permission to use a particular library in non-free programs enables a greater number of people to use a large body of free software. For example, permission to use the GNU C Library in non-free programs enables many more people to use the whole GNU operating system, as well as its variant, the GNU/Linux operating system. Although the Lesser General Public License is Less protective of the users' freedom, it does ensure that the user of a program that is linked with the Library has the freedom and the wherewithal to run that program using a modified version of the Library. The precise terms and conditions for copying, distribution and modification follow. Pay close attention to the difference between a "work based on the library" and a "work that uses the library". The former contains code derived from the library, whereas the latter must be combined with the library in order to run. GNU LESSER GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any software library or other program which contains a notice placed by the copyright holder or other authorized party saying it may be distributed under the terms of this Lesser General Public License (also called "this License"). Each licensee is addressed as "you". A "library" means a collection of software functions and/or data prepared so as to be conveniently linked with application programs (which use some of those functions and data) to form executables. The "Library", below, refers to any such software library or work which has been distributed under these terms. A "work based on the Library" means either the Library or any derivative work under copyright law: that is to say, a work containing the Library or a portion of it, either verbatim or with modifications and/or translated straightforwardly into another language. (Hereinafter, translation is included without limitation in the term "modification".) "Source code" for a work means the preferred form of the work for making modifications to it. For a library, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the library. Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running a program using the Library is not restricted, and output from such a program is covered only if its contents constitute a work based on the Library (independent of the use of the Library in a tool for writing it). Whether that is true depends on what the Library does and what the program that uses the Library does. 1. You may copy and distribute verbatim copies of the Library's complete source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and distribute a copy of this License along with the Library. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Library or any portion of it, thus forming a work based on the Library, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) The modified work must itself be a software library. b) You must cause the files modified to carry prominent notices stating that you changed the files and the date of any change. c) You must cause the whole of the work to be licensed at no charge to all third parties under the terms of this License. d) If a facility in the modified Library refers to a function or a table of data to be supplied by an application program that uses the facility, other than as an argument passed when the facility is invoked, then you must make a good faith effort to ensure that, in the event an application does not supply such function or table, the facility still operates, and performs whatever part of its purpose remains meaningful. (For example, a function in a library to compute square roots has a purpose that is entirely well-defined independent of the application. Therefore, Subsection 2d requires that any application-supplied function or table used by this function must be optional: if the application does not supply it, the square root function must still compute square roots.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Library, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Library, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Library. In addition, mere aggregation of another work not based on the Library with the Library (or with a work based on the Library) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may opt to apply the terms of the ordinary GNU General Public License instead of this License to a given copy of the Library. To do this, you must alter all the notices that refer to this License, so that they refer to the ordinary GNU General Public License, version 2, instead of to this License. (If a newer version than version 2 of the ordinary GNU General Public License has appeared, then you can specify that version instead if you wish.) Do not make any other change in these notices. Once this change is made in a given copy, it is irreversible for that copy, so the ordinary GNU General Public License applies to all subsequent copies and derivative works made from that copy. This option is useful when you wish to copy part of the code of the Library into a program that is not a library. 4. You may copy and distribute the Library (or a portion or derivative of it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange. If distribution of object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place satisfies the requirement to distribute the source code, even though third parties are not compelled to copy the source along with the object code. 5. A program that contains no derivative of any portion of the Library, but is designed to work with the Library by being compiled or linked with it, is called a "work that uses the Library". Such a work, in isolation, is not a derivative work of the Library, and therefore falls outside the scope of this License. However, linking a "work that uses the Library" with the Library creates an executable that is a derivative of the Library (because it contains portions of the Library), rather than a "work that uses the library". The executable is therefore covered by this License. Section 6 states terms for distribution of such executables. When a "work that uses the Library" uses material from a header file that is part of the Library, the object code for the work may be a derivative work of the Library even though the source code is not. Whether this is true is especially significant if the work can be linked without the Library, or if the work is itself a library. The threshold for this to be true is not precisely defined by law. If such an object file uses only numerical parameters, data structure layouts and accessors, and small macros and small inline functions (ten lines or less in length), then the use of the object file is unrestricted, regardless of whether it is legally a derivative work. (Executables containing this object code plus portions of the Library will still fall under Section 6.) Otherwise, if the work is a derivative of the Library, you may distribute the object code for the work under the terms of Section 6. Any executables containing that work also fall under Section 6, whether or not they are linked directly with the Library itself. 6. As an exception to the Sections above, you may also combine or link a "work that uses the Library" with the Library to produce a work containing portions of the Library, and distribute that work under terms of your choice, provided that the terms permit modification of the work for the customer's own use and reverse engineering for debugging such modifications. You must give prominent notice with each copy of the work that the Library is used in it and that the Library and its use are covered by this License. You must supply a copy of this License. If the work during execution displays copyright notices, you must include the copyright notice for the Library among them, as well as a reference directing the user to the copy of this License. Also, you must do one of these things: a) Accompany the work with the complete corresponding machine-readable source code for the Library including whatever changes were used in the work (which must be distributed under Sections 1 and 2 above); and, if the work is an executable linked with the Library, with the complete machine-readable "work that uses the Library", as object code and/or source code, so that the user can modify the Library and then relink to produce a modified executable containing the modified Library. (It is understood that the user who changes the contents of definitions files in the Library will not necessarily be able to recompile the application to use the modified definitions.) b) Use a suitable shared library mechanism for linking with the Library. A suitable mechanism is one that (1) uses at run time a copy of the library already present on the user's computer system, rather than copying library functions into the executable, and (2) will operate properly with a modified version of the library, if the user installs one, as long as the modified version is interface-compatible with the version that the work was made with. c) Accompany the work with a written offer, valid for at least three years, to give the same user the materials specified in Subsection 6a, above, for a charge no more than the cost of performing this distribution. d) If distribution of the work is made by offering access to copy from a designated place, offer equivalent access to copy the above specified materials from the same place. e) Verify that the user has already received a copy of these materials or that you have already sent this user a copy. For an executable, the required form of the "work that uses the Library" must include any data and utility programs needed for reproducing the executable from it. However, as a special exception, the materials to be distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. It may happen that this requirement contradicts the license restrictions of other proprietary libraries that do not normally accompany the operating system. Such a contradiction means you cannot use both them and the Library together in an executable that you distribute. 7. You may place library facilities that are a work based on the Library side-by-side in a single library together with other library facilities not covered by this License, and distribute such a combined library, provided that the separate distribution of the work based on the Library and of the other library facilities is otherwise permitted, and provided that you do these two things: a) Accompany the combined library with a copy of the same work based on the Library, uncombined with any other library facilities. This must be distributed under the terms of the Sections above. b) Give prominent notice with the combined library of the fact that part of it is a work based on the Library, and explaining where to find the accompanying uncombined form of the same work. 8. You may not copy, modify, sublicense, link with, or distribute the Library except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense, link with, or distribute the Library is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 9. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Library or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Library (or any work based on the Library), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Library or works based on it. 10. Each time you redistribute the Library (or any work based on the Library), the recipient automatically receives a license from the original licensor to copy, distribute, link with or modify the Library subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties with this License. 11. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), conditions are imposed on you (whether by court order, agreement or otherwise) that contradict the conditions of this License, they do not excuse you from the conditions of this License. If you cannot distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Library at all. For example, if a patent license would not permit royalty-free redistribution of the Library by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Library. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply, and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 12. If the distribution and/or use of the Library is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Library under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 13. The Free Software Foundation may publish revised and/or new versions of the Lesser General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Library specifies a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Library does not specify a license version number, you may choose any version ever published by the Free Software Foundation. 14. If you wish to incorporate parts of the Library into other free programs whose distribution conditions are incompatible with these, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE LIBRARY "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE LIBRARY IS WITH YOU. SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS How to Apply These Terms to Your New Libraries If you develop a new library, and you want it to be of the greatest possible use to the public, we recommend making it free software that everyone can redistribute and change. You can do so by permitting redistribution under these terms (or, alternatively, under the terms of the ordinary General Public License). To apply these terms, attach the following notices to the library. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) This library is free software; you can redistribute it and/or modify it under the terms of the GNU Lesser General Public License as published by the Free Software Foundation; either version 2.1 of the License, or (at your option) any later version. This library 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 Lesser General Public License for more details. You should have received a copy of the GNU Lesser General Public License along with this library; if not, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the library, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the library `Frob' (a library for tweaking knobs) written by James Random Hacker. , 1 April 1990 Ty Coon, President of Vice That's all there is to it! swish-0.10.4.0/Setup.hs0000644000000000000000000000011013543702315012704 0ustar0000000000000000#!/usr/bin/env runhaskell import Distribution.Simple main = defaultMain swish-0.10.4.0/swish.cabal0000644000000000000000000003610414403410712013376 0ustar0000000000000000Cabal-Version: 2.4 Name: swish Version: 0.10.4.0 Stability: experimental License: LGPL-2.1-or-later License-file: LICENSE Author: Graham Klyne - GK@ninebynine.org Copyright: (c) 2003, 2004 G. Klyne; 2009 Vasili I Galchin; 2011, 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022 Doug Burke; All rights reserved. Maintainer: dburke@cfa.harvard.edu Category: Semantic Web Synopsis: A semantic web toolkit. Tested-With: GHC==9.0.2 Homepage: https://gitlab.com/dburke/swish Bug-reports: https://gitlab.com/dburke/swish/issues Description: Swish is a framework, written in the purely functional programming language Haskell, for performing deductions in RDF data using a variety of techniques. Swish is conceived as a toolkit for experimenting with RDF inference, and for implementing stand-alone RDF file processors (usable in similar style to CWM, but with a view to being extensible in declarative style through added Haskell function and data value declarations). It explores Haskell as \"a scripting language for the Semantic Web\". . Swish is a work-in-progress, and currently incorporates: . * Turtle, Notation3 and NTriples input and output. The N3 support is incomplete (no handling of @\@forAll@). . * RDF graph isomorphism testing and merging. . * Display of differences between RDF graphs. . * Inference operations in forward chaining, backward chaining and proof-checking modes. . * Simple Horn-style rule implementations, extendable through variable binding modifiers and filters. . * Class restriction rule implementation, primarily for datatype inferences. . * RDF formal semantics entailment rule implementation. . * Complete, ready-to-run, command-line and script-driven programs. . Changes are given in the file. . References: . - . - . - CWM: . Build-Type: Simple Extra-Source-Files: README.md CHANGELOG stack.yaml default.nix shell.nix flake.nix flake.lock .hlint.yaml Data-Files: scripts/*.ss Source-repository head type: git location: https://gitlab.com/dburke/swish.git -- Removed in 0.9.15 since I haven't been using it and it causes -- problems with 'cabal upload', since Cabal doesn't seem to recognize -- that -Werror is not on by default. -- -- Flag developer -- Description: Turn on developer flags -- Default: False Flag w3ctests Description: Build the RunW3CTests application Default: False -- Prior to network-2.6, Network.URI was in network; -- for >= 2.6 it's in network-uri. -- -- TODO: check; perhaps we don't need to install -- network if we have network-uri, particularly for the -- tests. If so, do we need network-uri < 2.6? -- Flag network-uri Description: Get Network.URI from the network-uri package Default: True Library Default-Language: Haskell2010 Build-Depends: base >= 4.8 && < 4.19, containers >= 0.5 && < 0.7, directory >= 1.0 && < 1.4, filepath >= 1.1 && < 1.5, -- Early versions of hashable 1.2 are problematic hashable (>= 1.1 && < 1.2) || (>= 1.2.0.6 && <1.6), intern >= 0.8 && < 1.0, mtl >= 2 && < 3, polyparse >= 1.6 && < 1.14, text >= 0.11 && < 2.1, -- I don't think 1.9.0 will work and it was quickly replaced -- so do not support it time (>= 1.5 && < 1.9) || (>= 1.9.1 && < 1.14) if flag(network-uri) build-depends: network-uri >= 2.6 && < 2.8 else build-depends: network-uri < 2.6 , network >= 2.4 && < 2.6 -- Taken from https://twitter.com/ChShersh/status/1459829796087738375 -- except for the orphans warning -- ghc-options: -Wall -fno-warn-orphans if impl(ghc >= 8.0) -- I assume these are added in 8.0 ghc-options: -Wcompat -Widentities -Wincomplete-record-updates -Wincomplete-uni-patterns -Wnoncanonical-monad-instances if impl(ghc >= 8.2) ghc-options: -fhide-source-paths if impl(ghc >= 8.4) ghc-options: -Wmissing-export-lists -Wpartial-fields if impl(ghc >= 8.8) ghc-options: -Wmissing-deriving-strategies -fwrite-ide-info -hiedir=.hie if impl(ghc >= 8.10) ghc-options: -Wunused-packages if impl(ghc >= 9.0) ghc-options: -Winvalid-haddock if impl(ghc >= 9.2) ghc-options: -Wredundant-bang-patterns -Woperator-whitespace if impl(ghc < 8.0.0) build-depends: semigroups >= 0.16 && < 0.21 -- if flag(developer) -- ghc-options: -Werror -- ghc-prof-options: -auto-all Hs-Source-Dirs: src/ Other-Modules: Swish.RDF.Formatter.Internal Exposed-Modules: Data.Interned.URI Data.Ord.Partial Data.String.ShowLines Network.URI.Ord 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.BuiltIn Swish.RDF.BuiltIn.Datatypes Swish.RDF.BuiltIn.Rules Swish.RDF.ClassRestrictionRule Swish.RDF.Datatype 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.ProofContext Swish.RDF.Query Swish.RDF.Ruleset Swish.RDF.VarBinding Swish.RDF.Vocabulary Swish.RDF.Vocabulary.DublinCore Swish.RDF.Vocabulary.FOAF Swish.RDF.Vocabulary.Geo Swish.RDF.Vocabulary.OWL Swish.RDF.Vocabulary.Provenance Swish.RDF.Vocabulary.RDF Swish.RDF.Vocabulary.SIOC Swish.RDF.Vocabulary.XSD Swish.Rule Swish.Ruleset Swish.Script Swish.Utils.ListHelpers Swish.VarBinding Test-Suite test-builtinmap type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: BuiltInMapTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit >= 1.2 && < 1.7, swish, test-framework, test-framework-hunit == 0.3.* Test-Suite test-graphpartition type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: GraphPartitionTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, semigroups, swish, test-framework, test-framework-hunit == 0.3.* Test-Suite test-graph type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: GraphTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, hashable, HUnit, swish, test-framework, test-framework-hunit == 0.3.* Test-Suite test-nt type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: NTTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text Test-Suite test-turtle type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: TurtleTest.hs ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-n3parser type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: N3ParserTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-n3formatter type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: N3FormatterTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfdatatypexsdinteger type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFDatatypeXsdIntegerTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfgraph type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFGraphTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text, time if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfproofcontext type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFProofContextTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfproof type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFProofTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfquery type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFQueryTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-rdfruleset type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: RDFRulesetTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network Test-Suite test-varbinding type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: VarBindingTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.* Test-Suite test-qname type: exitcode-stdio-1.0 Default-Language: Haskell2010 Hs-Source-Dirs: tests/ Main-Is: QNameTest.hs Other-Modules: TestHelpers ghc-options: -Wall -fno-warn-orphans Build-Depends: base, containers, HUnit, swish, test-framework, test-framework-hunit == 0.3.*, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network -- we do not have the data files to run this test -- Executable SwishTest -- Main-Is: tests/SwishTest.hs -- How can we include data files that are only used for -- benchmark/tests and do not get installed? -- Benchmark bench-ntriples -- Type: exitcode-stdio-1.0 -- Hs-Source-Dirs: bench/ -- Other-Modules: Paths_swish -- Main-Is: NTriples.hs -- Build-Depends: base, -- criterion, -- deepseq, -- network, -- swish, -- text -- -- ghc-options: -Wall -fno-warn-orphans Executable Swish Main-Is: SwishApp.hs Default-Language: Haskell2010 Hs-Source-Dirs: app/ Other-Modules: Paths_swish Autogen-Modules: Paths_swish ghc-options: -Wall -fno-warn-orphans -- if flag(developer) -- ghc-options: -Werror -- ghc-prof-options: -auto-all Build-Depends: base, swish Executable runw3ctests Main-Is: RunW3CTests.hs Default-Language: Haskell2010 Hs-Source-Dirs: app/ Other-Modules: Paths_swish Autogen-Modules: Paths_swish ghc-options: -Wall -fno-warn-orphans -- if flag(developer) -- ghc-options: -Werror -- ghc-prof-options: -auto-all if flag(w3ctests) Build-Depends: base, containers, directory, filepath, swish, text if flag(network-uri) build-depends: network-uri else build-depends: network-uri , network else Buildable: False