diff --git a/Swish/HaskellRDF/BuiltInDatatypes.hs b/Swish/HaskellRDF/BuiltInDatatypes.hs deleted file mode 100644 --- a/Swish/HaskellRDF/BuiltInDatatypes.hs +++ /dev/null @@ -1,96 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: BuiltInDatatypes.hs,v 1.2 2003/12/18 20:46:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInDatatypes --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module collects references and provides access to all of the --- datatypes built in to Swish. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.BuiltInDatatypes - ( allDatatypes, findRDFDatatype ) -where - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype - ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..), mapFindMaybe - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - -import Swish.HaskellRDF.RDFDatatypeXsdString - ( rdfDatatypeXsdString ) - -import Swish.HaskellRDF.RDFDatatypeXsdInteger - ( rdfDatatypeXsdInteger ) - ------------------------------------------------------------- --- Declare datatype map ------------------------------------------------------------- - -allDatatypes :: [RDFDatatype] -allDatatypes = - [ rdfDatatypeXsdString - , rdfDatatypeXsdInteger - ] - -findRDFDatatype :: ScopedName -> Maybe RDFDatatype -findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes) - ------------------------------------------------------------- --- Declare datatype subtypes map ------------------------------------------------------------- - -allDatatypeSubtypes :: [xxx] -allDatatypeSubtypes = [] --- [[[details TBD]]] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/BuiltInDatatypes.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: BuiltInDatatypes.hs,v $ --- Revision 1.2 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.1 2003/12/17 16:56:39 graham --- Split content of BuiltInMap into separate modules, to avoid recursive --- module dependency with RDFProofContext. --- diff --git a/Swish/HaskellRDF/BuiltInMap.hs b/Swish/HaskellRDF/BuiltInMap.hs deleted file mode 100644 --- a/Swish/HaskellRDF/BuiltInMap.hs +++ /dev/null @@ -1,77 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: BuiltInMap.hs,v 1.5 2003/12/18 18:27:46 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInMap --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- 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.HaskellRDF.BuiltInMap - ( findRDFOpenVarBindingModifier - , findRDFDatatype - , rdfRulesetMap - , allRulesets, allDatatypeRulesets - ) -where - -import Swish.HaskellRDF.BuiltInDatatypes -import Swish.HaskellRDF.BuiltInRules - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/BuiltInMap.hs,v $ --- $Author: graham $ --- $Revision: 1.5 $ --- $Log: BuiltInMap.hs,v $ --- Revision 1.5 2003/12/18 18:27:46 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.4 2003/12/17 16:56:39 graham --- Split content of BuiltInMap into separate modules, to avoid recursive --- module dependency with RDFProofContext. --- --- Revision 1.3 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.2 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.1 2003/12/08 23:56:07 graham --- Various enhancements to variable bindings and proof structure. --- New module BuiltInMap coded and tested. --- Script processor is yet to be completed. --- diff --git a/Swish/HaskellRDF/BuiltInMapTest.hs b/Swish/HaskellRDF/BuiltInMapTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/BuiltInMapTest.hs +++ /dev/null @@ -1,299 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: BuiltInMapTest.hs,v 1.5 2004/01/06 13:53:10 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInMapTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for thje funtion for accessing built-in --- variable binding modifiers. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.BuiltInMapTest where - -import Swish.HaskellRDF.BuiltInMap - ( findRDFOpenVarBindingModifier - , findRDFDatatype - , rdfRulesetMap - , allRulesets - ) - -import Swish.HaskellRDF.RDFDatatypeXsdInteger - ( typeNameXsdInteger, namespaceXsdInteger - ) - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - , getContextAxiom, getMaybeContextAxiom - , getContextRule, getMaybeContextRule - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - -import Swish.HaskellRDF.Vocabulary - ( swishName - , scopeRDF - , scopeRDFS - , scopeRDFD - , namespaceXsdType - ) - -import Swish.HaskellUtils.LookupMap - ( mapFindMaybe ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , Assertion - , assertBool, assertEqual, assertString, assertFailure - , runTestTT, runTestText, putTextToHandle - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Control.Monad - ( unless ) - -import Data.List - ( sort, union, intersect ) - -import Data.Maybe - ( isJust, fromJust, fromMaybe ) - - ------------------------------------------------------------- --- 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 bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - -testElem :: (Eq a, Show a) => String -> a -> [a] -> Test -testElem lab a1 as = - TestCase ( assertMember ("testElem:"++lab) a1 as ) - -testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test -testLe lab eq a1 a2 = - TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) - --- Test for Just x or Nothing - -testJust :: String -> Maybe a -> Test -testJust lab av = - TestCase ( assertBool ("testJust:"++lab) (isJust av) ) - -testNothing :: String -> Maybe a -> Test -testNothing lab av = - TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) - --- Compare lists and lists of lists and Maybe lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - -testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqvEqv lab a1 a2 = - TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest $ map ListTest a1 - ma2 = ListTest $ map ListTest a2 - -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test -testHasEqv lab a1 a2 = - TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest a1 - ma2 = map ListTest a2 - -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv lab a1 a2 = - TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) - where - ma1 = (MaybeListTest a1) - ma2 = (MaybeListTest a2) - ------------------------------------------------------------- --- Test finding built-in variable binding modifiers ------------------------------------------------------------- - -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 (ScopedName namespaceXsdInteger "abs") -testVarMod06 = testJust "testVarMod06" $ - findRDFOpenVarBindingModifier (ScopedName namespaceXsdInteger "divmod") -testVarMod07 = testJust "testVarMod07" $ - findRDFOpenVarBindingModifier (ScopedName namespaceXsdInteger "ge") - -testVarModSuite = TestList - [ testVarMod01, testVarMod02, testVarMod03, testVarMod04 - , testVarMod05, testVarMod06, testVarMod07 - ] - ------------------------------------------------------------- --- Test finding built-in datatypes ------------------------------------------------------------- - -testDatatype01 = testJust "testDatatype01" $ findRDFDatatype typeNameXsdInteger - -testDatatypeSuite = TestList - [ testDatatype01 - ] - ------------------------------------------------------------- --- Test finding built-in rulesets ------------------------------------------------------------- - -testRuleset01 = testJust "testRuleset01" $ - mapFindMaybe scopeRDF rdfRulesetMap - -testRulesetSuite = TestList - [ testRuleset01 - ] - ------------------------------------------------------------- --- Test finding arbitrary axioms and rules ------------------------------------------------------------- - -testFindAxiom01 = testJust "testFindAxiom01" $ - getMaybeContextAxiom (ScopedName scopeRDF "a1") allRulesets -testFindAxiom02 = testJust "testFindAxiom02" $ - getMaybeContextAxiom (ScopedName scopeRDFS "a01") allRulesets -testFindAxiom03 = testJust "testFindAxiom03" $ - getMaybeContextAxiom (ScopedName (namespaceXsdType "integer") "dt") - allRulesets - -testFindAxiomSuite = TestList - [ testFindAxiom01, testFindAxiom02, testFindAxiom03 - ] - -testFindRule01 = testJust "testFindRule01" $ - getMaybeContextRule (ScopedName scopeRDF "r1") allRulesets -testFindRule02 = testJust "testFindRule02" $ - getMaybeContextRule (ScopedName scopeRDFS "r1") allRulesets -testFindRule03 = testJust "testFindRule03" $ - getMaybeContextRule (ScopedName scopeRDFD "r1") allRulesets -testFindRule04 = testJust "testFindRule04" $ - getMaybeContextRule (ScopedName (namespaceXsdType "integer") "Abs") - allRulesets - -testFindRuleSuite = TestList - [ testFindRule01, testFindRule02, testFindRule03, testFindRule04 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testVarModSuite - , testDatatypeSuite - , testRulesetSuite - , testFindAxiomSuite - , testFindRuleSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/BuiltInMapTest.hs,v $ --- $Author: graham $ --- $Revision: 1.5 $ --- $Log: BuiltInMapTest.hs,v $ --- Revision 1.5 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.4 2003/12/18 18:27:46 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.3 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.2 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.1 2003/12/08 23:56:07 graham --- Various enhancements to variable bindings and proof structure. --- New module BuiltInMap coded and tested. --- Script processor is yet to be completed. --- diff --git a/Swish/HaskellRDF/BuiltInRules.hs b/Swish/HaskellRDF/BuiltInRules.hs deleted file mode 100644 --- a/Swish/HaskellRDF/BuiltInRules.hs +++ /dev/null @@ -1,175 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: BuiltInRules.hs,v 1.2 2003/12/18 18:27:46 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : BuiltInRules --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- 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.HaskellRDF.BuiltInRules - ( findRDFOpenVarBindingModifier - , rdfRulesetMap - , allRulesets, allDatatypeRulesets - ) -where - -import Swish.HaskellRDF.BuiltInDatatypes - ( allDatatypes ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFOpenVarBindingModify - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFRuleset, RDFRulesetMap ) - -import Swish.HaskellRDF.RDFProofContext - ( rulesetRDF - , rulesetRDFS - , rulesetRDFD ) - -import Swish.HaskellRDF.VarBinding - ( nullVarBindingModify - , makeVarFilterModify - , varFilterEQ, varFilterNE - ) - -import Swish.HaskellRDF.Datatype - ( typeRules - , typeMkModifiers - ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) - , mapFindMaybe - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - ------------------------------------------------------------- --- Declare variable binding filters list ------------------------------------------------------------- - --- |List of rdfOpenVarBindingModify values for predefined filters --- -rdfVarBindingFilters :: [RDFOpenVarBindingModify] -rdfVarBindingFilters = - [ filter1 rdfVarBindingUriRef - , filter1 rdfVarBindingBlank - , filter1 rdfVarBindingLiteral - , filter1 rdfVarBindingUntypedLiteral - , filter1 rdfVarBindingTypedLiteral - , filter1 rdfVarBindingXMLLiteral - , filter1 rdfVarBindingMemberProp - , filter2 rdfVarBindingDatatyped - -- , filterN nullVarBindingModify - , filter2 varFilterEQ - , filter2 varFilterNE - ] - where - filter1 f lbs = makeVarFilterModify $ f (lbs!!0) - filter2 f lbs = makeVarFilterModify $ f (lbs!!0) (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 = concatMap dtVarBindingModifiers allDatatypes -dtsVarBindingModifiers = concatMap typeMkModifiers allDatatypes - -{- -dtVarBindingModifiers dtval = - map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) --} - -findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify -findRDFOpenVarBindingModifier nam = - mapFindMaybe nam (LookupMap allOpenVarBindingModify) - ------------------------------------------------------------- --- Lookup map for built-in rulesets ------------------------------------------------------------- - -rdfRulesetMap :: RDFRulesetMap -rdfRulesetMap = LookupMap allRulesets - -allRulesets :: [RDFRuleset] -allRulesets = - [ rulesetRDF - , rulesetRDFS - , rulesetRDFD - ] - ++ allDatatypeRulesets - -allDatatypeRulesets :: [RDFRuleset] -allDatatypeRulesets = map typeRules allDatatypes - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/BuiltInRules.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: BuiltInRules.hs,v $ --- Revision 1.2 2003/12/18 18:27:46 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.1 2003/12/17 16:56:39 graham --- Split content of BuiltInMap into separate modules, to avoid recursive --- module dependency with RDFProofContext. --- diff --git a/Swish/HaskellRDF/ClassRestrictionRule.hs b/Swish/HaskellRDF/ClassRestrictionRule.hs deleted file mode 100644 --- a/Swish/HaskellRDF/ClassRestrictionRule.hs +++ /dev/null @@ -1,666 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} --------------------------------------------------------------------------------- --- $Id: ClassRestrictionRule.hs,v 1.15 2004/01/07 19:49:12 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ClassRestrictionRule --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module implements an inference rule based on a restruction on class --- membership of one or more values. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.ClassRestrictionRule - ( ClassRestriction(..), ClassRestrictionFn - , makeDatatypeRestriction, makeDatatypeRestrictionFn - , makeRDFClassRestrictionRules - , makeRDFDatatypeRestrictionRules - , falseGraph, falseGraphStr - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , getScopedName - , RDFGraph - , getArcs - , merge - , toRDFGraph, emptyRDFGraph - , Arc(..) - , res_rdf_type - , res_rdfd_maxCardinality - ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFRule - , makeRDFGraphFromN3String - ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatypeVal - , fromRDFLabel, toRDFLabel - ) - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryFind - , rdfFindValSubj, rdfFindPredVal, rdfFindPredInt - , rdfFindList - ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding ) - -import Swish.HaskellRDF.Datatype - ( DatatypeVal(..) - , DatatypeRel(..), DatatypeRelFn - ) - -import Swish.HaskellRDF.Rule - ( Rule(..) - , bwdCheckInference - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDFD - ) - -import Swish.HaskellUtils.PartOrderedCollection - ( minima, maxima - , partCompareEq, partComparePair - , partCompareListMaybe - , partCompareListSubset - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFindMaybe - ) - -import Swish.HaskellUtils.ListHelpers - ( powerSet ) - -import Data.Maybe - ( Maybe(..) - , isJust, fromJust, fromMaybe, catMaybes ) - -import Data.List - ( delete, nub, (\\) ) - -import Control.Monad - ( liftM ) - -import Swish.HaskellUtils.TraceHelpers - ( trace ) - ------------------------------------------------------------- --- 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 - } - -instance Eq ClassRestriction where - cr1 == cr2 = crName cr1 == crName cr2 - -instance Show ClassRestriction where - show cr = "ClassRestriction:"++(show $ crName cr) - -instance LookupEntryClass ClassRestriction ScopedName ClassRestriction - where - newEntry (_,fn) = fn - keyVal cr = (crName cr, 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) - } - --- |Make a class restriction function from a datatype relation function. --- --- The core logic 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. --- --- ClassRestrictionFn = [Maybe RDFLabel] -> Maybe [[RDFLabel]] --- -makeDatatypeRestrictionFn :: - RDFDatatypeVal vt -> DatatypeRelFn vt -> ClassRestrictionFn -makeDatatypeRestrictionFn dtv dtrelfn = - liftM (catMaybes . map toLabels) . dtrelfn . (map frLabel) - where - frLabel Nothing = Nothing - frLabel (Just l) = fromRDFLabel dtv l - toLabels = sequence . map toLabel -- Maybe [RDFLabel] - toLabel = toRDFLabel dtv - ------------------------------------------------------------- --- Make rules from supplied class restrictions and graph ------------------------------------------------------------- - -ruleQuery :: RDFGraph -ruleQuery = makeRDFGraphFromN3String $ - "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ - " ?c a rdfd:GeneralRestriction ; " ++ - " rdfd:onProperties ?p ; " ++ - " rdfd:constraint ?r . " - --- Placeholder false graph for now. -falseGraph :: RDFGraph -falseGraph = makeRDFGraphFromN3String $ - "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ - falseGraphStr - -falseGraphStr :: String -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 = - catMaybes $ ( map constructRule . queryForRules ) gr - where - queryForRules = rdfQueryFind ruleQuery - constructRule = makeRestrictionRule1 crs gr - -makeRestrictionRule1 :: - [ClassRestriction] -> RDFGraph -> RDFVarBinding -> Maybe RDFRule -makeRestrictionRule1 crs gr vb = - {- - trace "\nmakeRestrictionRule1:" $ - -- seq (traceShow "\ngr:" gr) - seq (traceShow "\nvb:" vb) $ - seq (traceShow "\nc:" c) $ - seq (traceShow "\np:" p) $ - seq (traceShow "\nr:" r) $ - seq (traceShow "\nps:" ps) $ - -- seq (traceShow "\nrn:" rn) $ - -} - 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 res_rdfd_maxCardinality gr - ps = rdfFindList gr p - rn = mapFindMaybe (getScopedName r) (LookupMap crs) - -makeRestrictionRule2 :: - Maybe ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] - -> Maybe RDFRule -makeRestrictionRule2 (Just restriction) cls@(Res cname) props cs = - {- - trace "\nmakeRestrictionRule2:" $ - seq (traceShow "\ncls:" cls) - seq (traceShow "\nprops:" props) $ - -} - 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 _ _ _ _ = - trace "\nmakeRestrictionRule: missing class restriction" $ - Nothing - --- Forward apply class restriction. -fwdApplyRestriction :: - ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> [RDFGraph] - -> [RDFGraph] -fwdApplyRestriction restriction cls props cs antgrs = - if isJust newgrs then concat $ fromJust newgrs else [falseGraph] - where - -- Instances of the named class in the graph: - ris = nub $ rdfFindValSubj res_rdf_type 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 = sequence $ map 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 = - {- - trace "\nfwdApplyRestriction1:" $ - seq (traceShow "\nci:" ci) - seq (traceShow "\nprops:" props) - seq (traceShow "\nantgr:" 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 = catMaybes $ map sequence sts - -- Make new graph from results, including only newly generated arcs - newarcs = nub [Arc ci p v | vs <- nts, (p,v) <- zip props vs ] - \\ getArcs antgr - newgrs = if 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 = - if isJust newgrs then fromJust newgrs else [[falseGraph]] - where - -- Instances of the named class in the graph: - ris = rdfFindValSubj res_rdf_type 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 = liftM (map concat . sequence) $ sequence $ map 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 - {- - trace "\nfwdApplyRestriction1:" $ - seq (traceShow "\nci:" ci) - seq (traceShow "\nprops:" props) - seq (traceShow "\ncongr:" congr) $ - -} - 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 - makeGraphs = map (toRDFGraph . (:[])) . ((Arc ci res_rdf_type 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 = sequence $ map (\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 = sequence $ map 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 = map sndFromJust $ filter (isJust . snd) (zip pts rts) - -- 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 - -- Remove Maybe wrapper from second component of a pair - sndFromJust :: (a,Maybe b) -> (a,b) - sndFromJust (a,Just b) = (a,b) - --- 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) $ powerSet cts - cts = minima (partComparePair partCompareListMaybe partCompareEq) dts - coverspvs cts = coversVals delete (map snd cts) 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 (t:ts) (vs:vss) = dropVal t vs:dropUsed ts vss - 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 supplied datatype and graph ------------------------------------------------------------- - -makeRDFDatatypeRestrictionRules :: RDFDatatypeVal vt -> RDFGraph -> [RDFRule] -makeRDFDatatypeRestrictionRules dtval gr = - makeRDFClassRestrictionRules dcrs gr - where - dcrs = map (makeDatatypeRestriction dtval) (tvalRel dtval) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/ClassRestrictionRule.hs,v $ --- $Author: graham $ --- $Revision: 1.15 $ --- $Log: ClassRestrictionRule.hs,v $ --- Revision 1.15 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.14 2003/12/20 12:53:39 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.13 2003/12/20 12:00:14 graham --- Introduced new TraceHelpers module for Hugs-2003 compatibility. --- --- Revision 1.12 2003/12/19 21:01:25 graham --- Change Debug.Trace import (from Hugs.Trace) --- --- Revision 1.11 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.10 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.9 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.8 2003/11/27 11:35:49 graham --- Variable modifier tests all run. --- Initial class constraint reasoning tests pass. --- Fixed bug in class constraint backward-chained reasoning that returned --- multiple instances of some statements, and did not filter out all occurrences --- of the original statements. --- --- Revision 1.7 2003/11/24 22:13:09 graham --- Working on reworking datatype variable modifiers to work with --- revised datatype framework. --- --- Revision 1.6 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.5 2003/11/20 17:58:09 graham --- Class-constraint backward chaining: all test cases passed. --- --- Revision 1.4 2003/11/19 22:13:03 graham --- Some backward chaining tests passed --- --- Revision 1.3 2003/11/17 21:53:30 graham --- Datatype inference forward chaining updated to allow inconsistent --- partial inputs to be detected. All forward chaining test cases passed. --- Need to develop backward chaining test cases. --- --- Revision 1.2 2003/11/14 21:48:35 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.1 2003/11/13 01:15:23 graham --- Working on ClassRestrictionRule. --- Code almost complete, some test cases missing. --- diff --git a/Swish/HaskellRDF/Datatype.hs b/Swish/HaskellRDF/Datatype.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Datatype.hs +++ /dev/null @@ -1,1082 +0,0 @@ -{-# OPTIONS -XExistentialQuantification #-} -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- $Id: Datatype.hs,v 1.21 2003/12/18 18:27:46 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Datatype --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + existential types + rank 2 polymorphism --- --- This module defines the structures used by Swish to represent and --- manipulate datatypes. It is designed as a basis for handling datatyped --- RDF literals, but the functions in this module are more generic. --- --- Testing note: this module supports a number of specific datatypes. --- It is intended that functionality in this module will be tested via --- modules RDFDatatype, ClassRestrictionRule and RDFDatatypeXsdInteger. --- See also module ClassRestrictionRuleTest for test cases. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.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 - , makeVmod_1_1_inv, makeVmod_1_1 - , makeVmod_2_1_inv, makeVmod_2_1 - , makeVmod_2_0 - , makeVmod_2_2 - , makeVmod_N_1 - , DatatypeSub(..) - ) -where - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - , getRulesetAxiom, getRulesetRule - ) - -import Swish.HaskellRDF.Rule - ( Formula(..) - , Rule(..) - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( swishName ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , addVarBinding - , VarBindingModify(..), OpenVarBindingModify, nullVarBindingModify - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFindMaybe - ) - -import Swish.HaskellUtils.ListHelpers - ( flist - , deleteIndex - ) - -import Data.Maybe( isJust, catMaybes ) - -import Control.Monad( join, liftM ) - ------------------------------------------------------------- --- 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. --- --- Note, the 'forall' is used in the sense of existentially quantified: --- see the Glasgow Haskell Compiler (GHC) user guide, section 7.3.12 --- -data Datatype ex lb vn = forall vt . Datatype (DatatypeVal ex vt lb vn) - -instance LookupEntryClass - (Datatype ex lb vn) ScopedName (Datatype ex lb vn) - where - newEntry (_,dt) = dt - keyVal dt = (typeName dt, dt) - --- |Get type name from Datatype value -typeName :: Datatype ex lb vn -> ScopedName -typeName (Datatype dtv) = tvalName dtv - --- |Get static rules from Datatype value -typeRules :: Datatype ex lb vn -> Ruleset ex -typeRules (Datatype dtv) = tvalRules dtv - --- |Make rules for Datatype value based on supplied expression -typeMkRules :: Datatype ex lb vn -> ex -> [Rule ex] -typeMkRules (Datatype dtv) = tvalMkRules dtv - --- |Make variable binding modifiers based on values supplied -typeMkModifiers :: Datatype ex lb vn -> [OpenVarBindingModify lb vn] -typeMkModifiers (Datatype dtv) = tvalMkMods dtv - --- |Get named axiom from Datatype value -getTypeAxiom :: ScopedName -> Datatype ex lb vn -> Maybe (Formula ex) -getTypeAxiom nam dt = getRulesetAxiom nam (typeRules dt) - --- |Get named rule from Datatype value -getTypeRule :: ScopedName -> Datatype ex lb vn -> Maybe (Rule ex) -getTypeRule nam dt = getRulesetRule nam (typeRules dt) - --- |Get cacnonical form of datatype value -typeMkCanonicalForm :: Datatype ex lb vn -> String -> Maybe String -typeMkCanonicalForm (Datatype dtv) valstr = tvalMkCanonicalForm dtv valstr - ------------------------------------------------------------- --- 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 (whos 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 (above) in which the internal detail --- of the value type is hidden from users of the Datatype class.) --- --- The datatype characteristic functions have two goals: --- - to support the general datatype entailment rules defined by --- the RDF semantics specification, and --- - 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: --- (a) by variable binding modifiers that can be combined with the --- query results during forward- for backward-chaining of --- inference rules, and --- (b) 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.]]] - } - --- Other accessor functions - -getDTRel :: - ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt) -getDTRel nam dtv = - mapFindMaybe nam (LookupMap (tvalRel dtv)) - -getDTMod :: - ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) -getDTMod nam dtv = - mapFindMaybe nam (LookupMap (tvalMod dtv)) - --- |Get canonical form of datatype value, or None --- -tvalMkCanonicalForm :: DatatypeVal ex vt lb vn -> String -> Maybe String -tvalMkCanonicalForm dtv str = can - where - val = mapL2V (tvalMap dtv) str - can = join $ liftM (mapV2L (tvalMap dtv)) 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. --- -data DatatypeMap vt = DatatypeMap - { mapL2V :: String -> Maybe vt - -- ^ Function to map lexical string to - -- 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 String - -- ^ 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: --- (a) 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. --- (b) Just an empty list is returned if the supplied values are --- insufficient to compute any complete sets of values in the --- relation. --- (c) Nothing if the supplied values are not consistent with --- the relation. --- -type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] - --- |Type for datatype relation predicate: accepts a list of values --- and determines whether or not they satisfy the relation. --- -type DatatypeRelPr vt = [vt] -> Bool - --- |Datatype for a named relation on values of a datatype. --- -data DatatypeRel vt = DatatypeRel - { dtRelName :: ScopedName - , dtRelFunc :: DatatypeRelFn vt - } - -instance LookupEntryClass (DatatypeRel vt) ScopedName (DatatypeRel vt) - where - newEntry (_,relf) = relf - keyVal dtrel = (dtRelName dtrel, dtrel) - --- |Datatype value modifier functions type --- --- Each function accepts a list of values and returns a list of values. --- The exact significance of the different values supplied and returned --- depends on the variable binding pattern used (cf. ApplyModifier), --- but in all cases an empty list returned means that the corresponding --- inputs are not consistent with the function and cannot be used. --- -type ModifierFn vn = [vn] -> [vn] - --- |Type of function used to apply a data value modifier to specified --- variables in a supplied variable binding. It also accepts the --- name of the datatype modifier and carries it into the resulting --- variable binding modifier. --- --- (Note that vn is not necessarily the same as vt, the datatype value --- type: the modifier functions may be "lifted" or otherwise adapted --- to operate on some other type from which the raw data values are --- extracted.) --- -type ApplyModifier lb vn = - ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - --- |Wrapper for data type variable binding modifier included in --- a datatype value. --- -data DatatypeMod vt lb vn = DatatypeMod - { dmName :: ScopedName - , dmModf :: [ModifierFn vt] - , dmAppf :: ApplyModifier lb vn - } - -instance LookupEntryClass - (DatatypeMod vt lb vn) ScopedName (DatatypeMod vt lb vn) - where - newEntry (_,dmod) = dmod - keyVal dmod = (dmName dmod, dmod) - --- |Null datatype value modifier -nullDatatypeMod :: DatatypeMod vt lb vn -nullDatatypeMod = DatatypeMod - { dmName = swishName "nullDatatypeMod" - , dmModf = [] - , dmAppf = nullAppf - } - where - -- nullAppf :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - nullAppf nam _ lbs = (nullVarBindingModify lbs) { vbmName = nam } - -{- --- |Apply datatype variable binding modifier value to list of labels and --- a variable binding. -applyDatatypeMod :: (Eq lb, Show lb, Eq vn, Show vn) - => DatatypeMod vt lb vn -> OpenVarBindingModify lb vn -applyDatatypeMod dtmod = dmAppf dtmod (dmName dtmod) (dmModf dtmod) --} - -{- -dmName dtmod :: ScopedName -dmModf dtmod :: [ModifierFn vt] - :: [[vt] -> [vt]] -dmAppf dtmod :: ApplyModifier lb vn - :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn - :: ScopedName -> [[vn] -> [vn]] -> OpenVarBindingModify lb vn -dmAppf dtmod (dmName dtmod) - :: [[vn] -> [vn]] -> OpenVarBindingModify lb vn --} - --------------------------------------------------------------- --- Functions for creating datatype variable binding modifiers --------------------------------------------------------------- - --- |ApplyModifier function for use with DatatypeMod in cases --- when the value mapping is a 1->1 function and inverse, such --- as negate. --- --- nam ia 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. --- --- type ApplyModifer lb vn = [ModifierFn vn] -> [lb] -> VarBindingModify lb vn --- -makeVmod_1_1_inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_1_1_inv 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 _ _ = [] -makeVmod_1_1_inv _ _ _ = - error "makeVmod_1_1_inv: 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 ia 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. --- -makeVmod_1_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_1_1 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 _ _ = [] -makeVmod_1_1 _ _ _ = - error "makeVmod_1_1: 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 ia 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. --- -makeVmod_2_1_inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_2_1_inv 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 _ _ = [] -makeVmod_2_1_inv _ _ _ = - error "makeVmod_2_1_inv: 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 ia 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. --- -makeVmod_2_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_2_1 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 _ _ = [] -makeVmod_2_1 _ _ _ = - error "makeVmod_2_1: 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 ia 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. --- -makeVmod_2_0 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_2_0 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 _ _ = [] -makeVmod_2_0 _ _ _ = - error "makeVmod_2_0: 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 ia 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.]]] --- -makeVmod_2_2 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_2_2 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 _ _ = [] -makeVmod_2_2 _ _ _ = - error "makeVmod_2_2: 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 ia 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. --- -makeVmod_N_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn -makeVmod_N_1 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 -makeVmod_N_1 _ _ _ = - error "makeVmod_N_1: requires 2 functions and at 1 or more labels" - --------------------------------------------------------- --- Local helper functions for makeVmodXXX variants --------------------------------------------------------- - --- Add value to variable variable binding, if value is singleton list, --- otherwise return empty list. -addv :: (Eq lb, Show lb, Eq vt, Show vt) - => lb -> [vt] -> VarBinding lb vt - -> [VarBinding lb vt] -addv lb [val] vbind = [addVarBinding lb val vbind] -addv _ _ _ = [] - --- Add two entries to variable variable binding, if value supplied is --- a doubleton list, otherwise return empty list. -addv2 :: (Eq lb, Show lb, Eq vt, Show vt) - => lb -> lb -> [vt] -> VarBinding lb vt - -> [VarBinding lb vt] -addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $ - addVarBinding lb2 val2 vbind] -addv2 _ _ _ _ = [] - --- If supplied value is non-empty list return supplied variable binding, --- otherwise return empty list. -selv :: [vt] -> varBinding lb vt -> [varBinding lb vt] -selv [] _ = [] -selv _ vbind = [vbind] - --------------------------------------------------------------- --- Functions for evaluating arguments in a datatype relation --------------------------------------------------------------- --- --- altArgs is a generic function for evaluating datatype relation --- values, based on suppied functions and argument values --- --- UnaryFnDescr, UnaryFnApply and unaryFnApp: --- are support types and function for using altArgs to --- evaluate relations on unary functions (binary relations). --- --- BinaryFnDescr, BinaryFnApply and binaryFnApp: --- are support types and function for using altArgs to --- evaluate relations on binary functions (3-way relations). --- --- ListFnDescr, ListFnApply and listFnApp: --- are support types and function for using altArgs to --- evaluate relations on list functions (n-way relations), --- where the first member of the list is the value of a --- fold of a function over the rest of the list. --- --- See experimental module spike-altargs.hs for test cases and --- development steps for this function. - --- |Given a list of argument values and a list of functions for --- calculating new values from supplied values, return a list --- of argument values, or Nothing if the supplied values are --- inconsistent with the calculations specified. --- --- Each list of values returned corresponds to a set of values that --- satisfy the relation, consistent with the values supplied. --- --- Functions are described as tuple consisting of --- (a) a predicate that the argument is required to satisfy --- (b) a function to apply, --- (c) a function to apply function (b) to a list of arguments --- (d) argument list index values to which the function is applied. --- --- Each supplied argument is of the form 'Maybe a', where the argument --- has value type a. 'Nothing' indicates arguments of unknown value. --- --- The basic idea is that, for each argument position in the relation, --- a function may be supplied to calculate that argument's possible values --- from some combination of the other arguments. The results calculated --- in this way are compared with the original arguments provided: --- if the values conflict then the relation is presumed to be --- unsatisfiable with the supplied values, and 'Nothing' is returned; --- if there are any calculated values for arguments supplied without --- any values, then tbe calculated values are used. --- If there are any arguments for which no values are supplied or --- calculated, then the relation is presumed to be underdetermined, --- and 'Just []' is returned. --- --- fnss is 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.) --- apfn is 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. --- The value used must match the type of 'fnss' used. --- --- Returns a 'DatatypeRelFn vt' value that can be used as the --- 'dtRelFunc' component of a DatatypeRel value. --- cf. type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] --- --- type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] --- type DatatypeRelPr vt = [vt] -> Bool --- -altArgs :: (Eq vt) - => DatatypeRelPr vt -> [(vt->Bool,[b])] - -> ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) - -> DatatypeRelFn vt -altArgs pr fnss apfn args = cvals4 cvals3 - where - -- Calculate new value(s) for each argument from supplied values, and - -- lift inconsistency indicator (Just/Nothing) to outermost Monad. - -- cvals1 :: [Maybe [vt]] - cvals1 = flist (map (applyFdescToTuple apfn) fnss) args - -- Merge calculated values with supplied arguments, and again - -- lift inconsistency indicator (Just/Nothing) to outermost Monad. - -- cvals2 :: Maybe [[vt]] - cvals2 = sequence $ mergeTupleVals (map fst fnss) args cvals1 - -- Map list of alternative values for each tuple member to - -- a list of alternative tuples. - cvals3 = liftM sequence cvals2 - -- Check each tuple against the supplied predicate. - -- If any of the alternative tuples does not match the predicate - -- then signal an inconsistency. - cvals4 Nothing = Nothing - cvals4 cvs@(Just ts) = if all pr ts then cvs else Nothing - --- Perform alternative calculations for single result value --- Each result value is a list of zero or more alternatives --- that can be calculated from available parameters, or --- Nothing if the available parameters are inconsistent. --- --- apfn is the function that actually applies an element of --- the function descriptor to a tuple of Maybe arguments --- (where Nothing is used to indicate an unknown value) --- (p,fns) is a pair consisting of a value-checking predicate --- for the corresponding tuple member, and a list of --- function descriptors that each return one or more --- values the tuple member, calculated from other values --- that are present. Just [] means no values are --- calculated for this member, and Nothing means the --- calculation has detected tuple values supplied that --- are inconsistent with the datatype relation concerned. --- args is a tuple of Maybe tuple elements, (where Nothing --- indicates an unknown value). --- --- Returns Maybe a list of alternative values for the member, --- Just [] to indicate insufficient information to calculate --- any new values, and Nothing to indicate an inconsistency. --- -applyFdescToTuple :: - ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) -> (vt->Bool,[b]) -> [Maybe vt] - -> Maybe [vt] -applyFdescToTuple apfn (p,fns) args = - liftM concat $ sequence cvals - where - -- cvals :: [Maybe [vt]] - cvals = flist (map (apfn p) fns) args - --- Merge calculated tuple values with supplied tuple, checking for consistency. --- --- ps predicates used for isolated validation of each tuple member --- args supplied tuple values, with Nothing for unknown values --- cvals list of alternative calculated values for each tuple member, --- or Nothing if an inconsistency has been detected by the --- tuple-calculation functions. Note that this list may contain --- more entries than args; the surplus entries are ignored --- (see list functions for how this is used). --- --- Returns a tuple of Maybe lists of values for each tuple member, --- containing Nothing if an inconsistency has been detected in the --- supplied values. --- -mergeTupleVals :: (Eq a) => [a->Bool] -> [Maybe a] -> [Maybe [a]] -> [Maybe [a]] -mergeTupleVals _ _ (Nothing:_) = [Nothing] -mergeTupleVals (_:ps) (Nothing:a1s) (Just a2s:a2ss) - = Just a2s:mergeTupleVals ps a1s a2ss -mergeTupleVals (p:ps) (Just a1:a1s) (Just []:a2ss) - | p a1 = Just [a1]:mergeTupleVals ps a1s a2ss - | otherwise = [Nothing] -mergeTupleVals (p:ps) (Just a1:a1s) (Just a2s:a2ss) - | p a1 && elem a1 a2s = Just [a1]:mergeTupleVals ps a1s a2ss - | otherwise = [Nothing] -mergeTupleVals _ [] _ = [] -mergeTupleVals _ _ _ = [Nothing] - --- |altArgs support for unary functions: function descriptor type -type UnaryFnDescr a = (a->a,Int) - --- |altArgs support for unary functions: function descriptor table type -type UnaryFnTable a = [(a->Bool,[UnaryFnDescr a])] - --- |altArgs support for unary functions: function applicator type -type UnaryFnApply a = (a->Bool) -> UnaryFnDescr a -> [Maybe a] -> Maybe [a] - --- |altArgs support for unary functions: function applicator -unaryFnApp :: UnaryFnApply a -unaryFnApp p (f1,n) args = apf p f1 (args!!n) - where - apf p f1 (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 p f (args!!n1) (args!!n2) - where - apf p f (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 p f (args!!n1) (args!!n2) - where - apf p f (Just a1) (Just a2) = if pm r then r else Nothing - where - r = f a1 a2 - pm Nothing = False - pm (Just r) = all p r - 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 p $ foldr (apf f) (Just [z]) args - | otherwise = - app p $ apf g a0 (foldr (apf f) (Just [z]) (args `deleteIndex` (n-1))) - where - apf :: (a->a->a) -> Maybe a -> Maybe [a] -> Maybe [a] - apf f (Just a1) (Just [a2]) = Just [f a1 a2] - apf _ _ _ = Just [] - app :: (a->Bool) -> Maybe [a] -> Maybe [a] - app p Nothing = Nothing - app p r@(Just [a]) = if p a then r else Nothing - app _ _ = Just [] - --------------------------------------------------------- --- 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: --- (a) supertypes may be introduced retrospectively, --- (b) the relationship expressed with respect to a single datatype --- cannot indicate hiow 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Datatype.hs,v $ --- $Author: graham $ --- $Revision: 1.21 $ --- $Log: Datatype.hs,v $ --- Revision 1.21 2003/12/18 18:27:46 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.20 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.19 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.18 2003/12/08 17:29:19 graham --- Moved OpenVarBinding type definitions from -Datatype to -VarBinding modules. --- --- Revision 1.17 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.16 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.15 2003/11/27 11:35:49 graham --- Variable modifier tests all run. --- Initial class constraint reasoning tests pass. --- Fixed bug in class constraint backward-chained reasoning that returned --- multiple instances of some statements, and did not filter out all occurrences --- of the original statements. --- --- Revision 1.14 2003/11/25 23:02:17 graham --- Reworked datatype variable modifier logic. --- Limited range of test cases so far all pass. --- --- Revision 1.13 2003/11/24 22:13:09 graham --- Working on reworking datatype variable modifiers to work with --- revised datatype framework. --- --- Revision 1.12 2003/11/17 21:53:31 graham --- Datatype inference forward chaining updated to allow inconsistent --- partial inputs to be detected. All forward chaining test cases passed. --- Need to develop backward chaining test cases. --- --- Revision 1.11 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.10 2003/11/11 21:02:55 graham --- Working on datatype class-constraint inference rule. Incomplete. --- --- Revision 1.9 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.8 2003/11/06 17:58:33 graham --- About to rework Datatype to better support class-based reasoning. --- --- Revision 1.7 2003/10/24 21:05:08 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.6 2003/10/22 15:47:46 graham --- Working on datatype inference support. --- --- Revision 1.5 2003/10/09 13:58:59 graham --- Sync with CVS. Preparing to eliminate QueryBindingFilter in favour --- of using just QueryBindingModifier. --- --- Revision 1.4 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.3 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.2 2003/09/22 23:25:01 graham --- Add some tweaks to the datatyping framework --- --- Revision 1.1 2003/07/03 20:31:07 graham --- Add initial draft of datatype framework. --- diff --git a/Swish/HaskellRDF/Dfa/Dfa.lhs b/Swish/HaskellRDF/Dfa/Dfa.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Dfa/Dfa.lhs +++ /dev/null @@ -1,614 +0,0 @@ -> {-# OPTIONS -fglasgow-exts #-} -> {-# LANGUAGE UndecidableInstances #-} - -> module Swish.HaskellRDF.Dfa.Dfa ( -> Re(..), -> matchRe, -> matchRe2 -> ) where - -> import Control.Monad.Identity -> import Control.Monad.Reader -> import Control.Monad.State -> import qualified Data.List as L -> import qualified Data.Map as M -> import qualified Data.Array as A -> import Data.Maybe - -import IOExts - - -The type of a regular expression. - -> data Re t -> = ReOr [Re t] -> | ReCat [Re t] -> | ReStar (Re t) -> | RePlus (Re t) -> | ReOpt (Re t) -> | ReTerm [t] -> deriving (Show) - - -The internal type of a regular expression. - -> type SimplRe t = Int -> data SimplRe' t -> = SReOr (SimplRe t) (SimplRe t) -> | SReCat (SimplRe t) (SimplRe t) -> | SReStar (SimplRe t) -> | SReLambda -> | SReNullSet -> | SReTerm t -> deriving (Eq, Ord, Show) - - -The regular expression builder monad. - -> data (Ord t) => ReRead t -> = ReRead { -> rerNullSet :: SimplRe t, -> rerLambda :: SimplRe t -> } - -> data (Ord t) => ReState t -> = ReState { -> resFwdMap :: M.Map (SimplRe t) (ReInfo t), -> resBwdMap :: M.Map (SimplRe' t) (SimplRe t), -> resNext :: Int, -> resQueue :: ([SimplRe t], [SimplRe t]), -> resStatesDone :: [SimplRe t] -> } - -> type ReM m t a = StateT (ReState t) (ReaderT (ReRead t) m) a - - - -Running the monad is tricky because the reader transformer (which -is the _inner_ transformer) requires information gained from -initialising the mutable state. We could do some trickiness with -lazy evaluation, but it would be hard to get right. - -What we do instead is run a "bootstrap" monad which does the -initialisation then returns the state. Then we construct a new -monad using that initial state. Simple but effective. The only -thing to be careful about is to make sure that the bootstrap code -does not depend on the reader state. As it happens, we only call -remInsert which only touches mutable state. - - -> remRun :: (ReVars m t) => ReM m t a -> m a -> remRun m -> = do (inits, initr) <- runReaderT (evalStateT bootstrap initState) initRead -> runReaderT (evalStateT m inits) initr -> where -> initState -> = ReState { -> resFwdMap = M.empty, -> resBwdMap = M.empty, -> resNext = 0, -> resQueue = ([],[]), -> resStatesDone = [] -> } -> initRead -> = ReRead { rerNullSet = undefined, rerLambda = undefined } -> bootstrap -> = do -> nulli <- remInsert (reiMake SReNullSet False) -> lami <- remInsert (reiMake SReLambda True) -> s <- get -> r <- ask -> return (s, r { rerNullSet = nulli, rerLambda = lami }) - - - - -Utility typeclasses for enforcing all the constraints we need -on our monad's free type variables. Note that this requires both --fglasgow-exts and -fallow-undecidable-instances in GHC to work -properly. - -> class (Monad m, Ord t) => ReVars m t where { } -> instance (Monad m, Ord t) => ReVars m t where { } - - -Operations on the monad. - -> remNullSet :: (ReVars m t) => ReM m t (SimplRe t) -> remNullSet = asks rerNullSet - -> remLambda :: (ReVars m t) => ReM m t (SimplRe t) -> remLambda = asks rerLambda - -> remStateDone :: (ReVars m t) => SimplRe t -> ReM m t () -> remStateDone re -> = do s <- get -> put (s { resStatesDone = re:resStatesDone s }) - -> remPush :: (ReVars m t) => [SimplRe t] -> ReM m t () -> remPush res -> = do s <- get -> let (qf,qb) = resQueue s -> put (s { resQueue = (qf, res ++ qb) }) - -> remPop :: (ReVars m t) => ReM m t (Maybe (SimplRe t)) -> remPop -> = get >>= \s -> -> let (qf,qb) = resQueue s -> in -> case qf of -> (re:res) -> put (s { resQueue = (res,qb) }) >> return (Just re) -> [] -> if null qb then return Nothing -> else put (s { resQueue = (reverse qb,[]) }) -> >> remPop - - - -> remInsert :: (ReVars m t) => ReInfo t -> ReM m t (SimplRe t) -> remInsert reinfo -> = do s <- get -> let fwd = resFwdMap s -> bwd = resBwdMap s -> newre = resNext s -> put (s { resFwdMap = M.insert newre reinfo fwd, -- PROBLEM -> resBwdMap = M.insert (reiSRE reinfo) newre bwd, -> resNext = newre + 1 }) -> return newre - - -> remLookupFwd :: (ReVars m t) => SimplRe t -> ReM m t (ReInfo t) -> remLookupFwd re -> = do fwd <- gets resFwdMap -> let { Just reinfo = M.lookup re fwd } -- PROBLEM -> return reinfo - - -> remLookupBwd :: (ReVars m t) => SimplRe' t -> -> ReM m t (Maybe (SimplRe t)) -> remLookupBwd re -> = do bwd <- gets resBwdMap -> return (M.lookup re bwd) -- PROBLEM - - -remAdd implements hash consing. Given a SimplRe' in as close -to "canonical" form as possible, this tries to find a SimplRe -that matches (if possible), and otherwise constructs a new one. - -> remAdd :: (ReVars m t) => SimplRe' t -> ReM m t (SimplRe t) -> remAdd sre -> = remLookupBwd sre >>= \ maybere -> -> case maybere of -> Just re -> return re -> Nothing -> doInsert -> where -> doInsert -> = remNullable sre >>= \nullable -> -> remInsert (reiMake sre nullable) - - -> remSetDfaState :: (ReVars m t) => SimplRe t -> ReDfaState t -> -> ReM m t (ReDfaState t) -> remSetDfaState re dfa -> = do s <- get -> let Just reinfo = M.lookup re (resFwdMap s) -- PROBLEM -> reinfo' = reinfo { reiDfa = Just dfa } -> put (s { resFwdMap = M.insert re reinfo' (resFwdMap s) }) -- PROBLEM -> return dfa - - -The ReInfo type - -> data ReInfo t -> = ReInfo { -> reiSRE :: SimplRe' t, -> reiNullable :: Bool, -> reiDfa :: Maybe (ReDfaState t) -> } -> deriving (Show) - -> reiMake :: SimplRe' t -> Bool -> ReInfo t -> reiMake re nullable -> = ReInfo { reiSRE = re, reiNullable = nullable, reiDfa = Nothing } - - -Regular expression builder. - -> remNullable :: (ReVars m t) => SimplRe' t -> ReM m t Bool -> remNullable (SReOr e1 e2) -> = do ei1 <- remLookupFwd e1 -> ei2 <- remLookupFwd e2 -> return $ reiNullable ei1 || reiNullable ei2 -> remNullable (SReCat e1 e2) -> = do ei1 <- remLookupFwd e1 -> ei2 <- remLookupFwd e2 -> return $ reiNullable ei1 && reiNullable ei2 -> remNullable (SReStar _) -> = return True -> remNullable SReLambda -> = return True -> remNullable SReNullSet -> = return False -> remNullable (SReTerm _) -> = return False - - - -> remBuildOne :: (ReVars m t) => SimplRe' t -> -> ReM m t (SimplRe t) - -> remBuildOne re@(SReOr e1 e2) -> | e1 == e2 = return e1 -> | e1 > e2 = remBuildOne (SReOr e2 e1) -> | otherwise -> = do ei1 <- remLookupFwd e1 -> ei2 <- remLookupFwd e2 -> remBuildOr e1 e2 (reiSRE ei1) (reiSRE ei2) -> where -> remBuildOr _ e3 (SReOr e1 e2) _ -> = remBuildOne (SReOr e2 e3) >>= \ e2' -> -> remBuildOne (SReOr e1 e2') -> remBuildOr _ e2 SReNullSet _ = return e2 -> remBuildOr e1 _ _ SReNullSet = return e1 -> remBuildOr _ _ _ _ = remAdd re - -> remBuildOne re@(SReCat e1 e2) -> = do ei1 <- remLookupFwd e1 -> ei2 <- remLookupFwd e2 -> remBuildCat e1 e2 (reiSRE ei1) (reiSRE ei2) -> where -> remBuildCat _ e3 (SReCat e1 e2) _ -> = remBuildOne (SReCat e2 e3) >>= \ e2' -> -> remBuildOne (SReCat e1 e2') -> remBuildCat e1 _ SReNullSet _ = return e1 -> remBuildCat _ e2 SReLambda _ = return e2 -> remBuildCat _ e2 _ SReNullSet = return e2 -> remBuildCat e1 _ _ SReLambda = return e1 -> remBuildCat _ _ _ _ = remAdd re - -> remBuildOne re@(SReStar e) -> = do ei <- remLookupFwd e -> remBuildStar e (reiSRE ei) -> where -> remBuildStar e (SReStar _) = return e -> remBuildStar e SReLambda = return e -> remBuildStar e SReNullSet = remLambda -> remBuildStar _ _ = remAdd re - -> remBuildOne re@SReLambda = remLambda - -> remBuildOne re@SReNullSet = remNullSet - -> remBuildOne re@(SReTerm t) = remAdd re - - - -> remBuild :: (ReVars m t) => Re t -> ReM m t (SimplRe t) -> remBuild (ReOr []) -> = remNullSet -> remBuild (ReOr [e]) -> = remBuild e -> remBuild (ReOr (e:es)) -> = do es' <- remBuild (ReOr es) -> e' <- remBuild e -> remBuildOne (SReOr e' es') -> remBuild (ReCat []) -> = remLambda -> remBuild (ReCat [e]) -> = remBuild e -> remBuild (ReCat (e:es)) -> = do es' <- remBuild (ReCat es) -> e' <- remBuild e -> remBuildOne (SReCat e' es') -> remBuild (ReOpt e) -> = do e2 <- remBuild e -> e1 <- remLambda -> remBuildOne (SReOr e1 e2) -> remBuild (ReStar e) -> = do e' <- remBuild e -> remBuildOne (SReStar e') -> remBuild (RePlus e) -> = do e1 <- remBuild e -> e2 <- remBuildOne (SReStar e1) -> remBuildOne (SReCat e1 e2) -> remBuild (ReTerm []) -> = remLambda -> remBuild (ReTerm [t]) -> = remBuildOne (SReTerm t) -> remBuild (ReTerm (t:ts)) -> = do ts' <- remBuild (ReTerm ts) -> t' <- remBuildOne (SReTerm t) -> remBuildOne (SReCat t' ts') - - -Dfa construction - -> data ReDfaState t -> = ReDfaState { -> dfaFinal :: Bool, -> dfaTrans :: [(t, SimplRe t)] -> } -> deriving (Show) - -> remMakeDfa :: (ReVars m t) => SimplRe t -> ReM m t () -> remMakeDfa start -> = do lams <- remLambda -> nulls <- remNullSet -> remPush [lams, nulls, start] -> remMakeDfa' -> where -> remMakeDfa' -> = remPop >>= \ maybere -> -> case maybere of -> Just re -> processState re >> remStateDone re >> remMakeDfa' -> Nothing -> return () - -> processState re -> = remLookupFwd re >>= \ info -> -> case reiDfa info of -> Just dfa -> return dfa -> Nothing -> expandState re info (reiSRE info) - -> expandState re info (SReCat e1 e2) -> = do dfa1 <- processState e1 -> trans1 <- makeCatTrans (dfaTrans dfa1) e2 -> trans <- if dfaFinal dfa1 -> then processState e2 >>= \dfa2 -> -> makeOrTrans trans1 (dfaTrans dfa2) -> else return trans1 -> remPush (map snd trans) -> remSetDfaState re -> (ReDfaState { -> dfaFinal = reiNullable info, -> dfaTrans = trans -> }) -> expandState re info (SReOr e1 e2) -> = do dfa1 <- processState e1 -> dfa2 <- processState e2 -> trans <- makeOrTrans (dfaTrans dfa1) (dfaTrans dfa2) -> remPush (map snd trans) -> remSetDfaState re -> (ReDfaState { -> dfaFinal = reiNullable info, -> dfaTrans = trans -> }) -> expandState re info (SReStar e) -> = do dfa <- processState e -> let trans' = dfaTrans dfa -> trans <- makeCatTrans trans' re -> remPush (map snd trans) -> remSetDfaState re -> (ReDfaState { -> dfaFinal = True, -> dfaTrans = trans -> }) -> expandState re info (SReTerm t) -> = do e2' <- remLambda -> remPush [e2'] -> remSetDfaState re -> (ReDfaState { -> dfaFinal = False, -> dfaTrans = [(t,e2')] -> }) -> expandState re info SReLambda -> = remSetDfaState re (ReDfaState { dfaFinal = True, dfaTrans = [] }) -> expandState re info SReNullSet -> = remSetDfaState re (ReDfaState { dfaFinal = False, dfaTrans = [] }) - -> makeOrTrans :: (ReVars m t) => [(t, SimplRe t)] -> -> [(t, SimplRe t)] -> ReM m t [(t, SimplRe t)] -> makeOrTrans [] ts2 -> = return ts2 -> makeOrTrans ts1 [] -> = return ts1 -> makeOrTrans ts1'@(tr1@(t1,s1):ts1) ts2'@(tr2@(t2,s2):ts2) -> | t1 < t2 = makeOrTrans ts1 ts2' >>= \ts -> return (tr1:ts) -> | t1 > t2 = makeOrTrans ts1' ts2 >>= \ts -> return (tr2:ts) -> | otherwise = remBuildOne (SReOr s1 s2) >>= \t -> -> makeOrTrans ts1 ts2 >>= \ts -> -> return ((t1,t):ts) - -> makeCatTrans :: (ReVars m t) => [(t, SimplRe t)] -> -> SimplRe t -> ReM m t [(t, SimplRe t)] -> makeCatTrans [] _ -> = return [] -> makeCatTrans ((t,s):ts) next -> = do -> s' <- remBuildOne (SReCat s next) -> ts' <- makeCatTrans ts next -> return ((t,s'):ts') - - -Recursive Dfa - -> data RDfa t -> = RDfa Bool [(t, RDfa t)] - -> matchRecursiveDfa :: (Ord t) => RDfa t -> [t] -> Bool -> matchRecursiveDfa (RDfa final trans) [] -> = final -> matchRecursiveDfa (RDfa final trans) (x:xs) -> = case [ s | (t, s) <- trans, t == x ] of -> [] -> False -> (s:_) -> matchRecursiveDfa s xs - -> remMakeRecursiveDfa :: (ReVars m t) => SimplRe t -> ReM m t (RDfa t) -> remMakeRecursiveDfa start -> = do max1 <- gets resNext -> fwd <- gets resFwdMap -> let max = max1 - 1 -> stateArray = A.array (0,max) -> [ (i, makeState stateArray fwd i) | i <- [0..max] ] -> return (stateArray A.! start) -- PROBLEM -> where -> makeState :: (Ord t) => A.Array (SimplRe t) (RDfa t) -> -> M.Map (SimplRe t) (ReInfo t) -> -> SimplRe t -> RDfa t -> makeState stateArray fwd s -> = RDfa (dfaFinal dfastate) [ (t, stateArray A.! ts) -- PROBLEM -> | (t, ts) <- dfaTrans dfastate ] -> where -> Just reinfo = M.lookup s fwd -- PROBLEM -> Just dfastate = reiDfa reinfo - - -Code generation. This is very, very ugly. - -> data BinTree a = BTZ | BTB (BinTree a) a (BinTree a) deriving (Show) - -> listToBinTree :: [a] -> BinTree a -> listToBinTree l -> = listToBinTree' (length l) l -> where -> listToBinTree' _ [] = BTZ -> listToBinTree' n ls -> = BTB (listToBinTree' n2 (take n2 ls)) t (listToBinTree' (n-n2-1) ts) -> where -> n2 = n `div` 2 -> t:ts = drop n2 ls - -> remCodeGen :: (ReVars m t) => SimplRe t -> ReM m t ([t] -> Bool) -> remCodeGen start -> = do max1 <- gets resNext -> fwd <- gets resFwdMap -> let max = max1 - 1 -> stateArray = A.array (0,max) -> [ (i, makeState stateArray fwd i) | i <- [0..max] ] -> return $ (stateArray A.! start) -- PROBLEM -> where -> globalFail = False -> globalSucc = True -> -> makeState :: (Ord t) => A.Array (SimplRe t) ([t] -> Bool) -> -> M.Map (SimplRe t) (ReInfo t) -> -> SimplRe t -> ([t] -> Bool) -> makeState stateArray fwd s -> | dfaFinal dfastate -> = \ts -> -- trace ("In state " ++ show s) $ -> case ts of -> [] -> globalSucc -> (t:ts) -> transition t ts -> | otherwise -> = \ts -> -- trace ("In state " ++ show s) $ -> case ts of -> [] -> globalFail -> (t:ts) -> transition t ts -> where -> Just reinfo = M.lookup s fwd -- PROBLEM -> Just dfastate = reiDfa reinfo -> -> transition t ts -> = transition' (listToBinTree (dfaTrans dfastate)) t ts -> where -> transition' BTZ = \t ts -> globalFail -> transition' (BTB BTZ (x,st) BTZ) -> = \t ts -> -> if x == t then (stateArray A.! st) ts -- PROBLEM -> else globalFail -> transition' (BTB l (x,st) r) -> = \t ts -> -> if t < x then transition' l t ts -> else if t > x then transition' r t ts -> else (stateArray A.! st) ts - -Debug code. Note that we need some extra constraints so we can -actually show regular expression states. - -> class (ReVars m t, MonadIO m, Show t) => ReVarsIO m t where { } -> instance (ReVars m t, MonadIO m, Show t) => ReVarsIO m t where { } - -> remDump :: (ReVarsIO m t) => ReM m t () -> remDump -> = do states <- gets (M.toList . resFwdMap) -> remDumpStates states -> where -> remDumpStates [] = return () -> remDumpStates ((s,sr):ss) -> = do info <- remLookupFwd s -> liftIO . putStrLn $ show s ++ ": " ++ show sr -> remDumpStates ss - -> remDumpDfa :: (ReVarsIO m t) => SimplRe t -> ReM m t () -> remDumpDfa start -> = do states <- gets (nodups . L.sort . resStatesDone) -> liftIO (putStrLn $ "Initial state: " ++ show start) -> remDumpStates states -> where -> nodups [] = [] -> nodups (x:xs) -> = x : nodups (dropWhile (==x) xs) -> remDumpStates [] = return () -> remDumpStates (s:ss) -> = do info <- remLookupFwd s -> let Just dfaState = reiDfa info -> liftIO . putStrLn $ show s ++ ": " ++ show dfaState -> remDumpStates ss - -> remTestBuild :: (ReVarsIO m t) => Re t -> m () -> remTestBuild re -> = remRun testBuild -> where -> testBuild -> = do s <- remBuild re -> liftIO . putStrLn $ "Initial node: " ++ show s -> remDump - -> remTestDfa :: (ReVarsIO m t) => Re t -> m () -> remTestDfa re -> = remRun testDfa -> where -> testDfa -> = do s <- remBuild re -> remMakeDfa s -> remDumpDfa s - -Wrapper - -> makeDfa :: (Ord t) => Re t -> RDfa t -> makeDfa re -> = runIdentity . remRun $ builder -> where -> builder -> = do s <- remBuild re -> remMakeDfa s -> remMakeRecursiveDfa s - -> makeCode :: (Ord t) => Re t -> [t] -> Bool -> makeCode re -> = runIdentity . remRun $ builder -> where -> builder -> = do s <- remBuild re -> remMakeDfa s -> remCodeGen s - -> matchRe :: (Ord t) => Re t -> [t] -> Bool -> matchRe re -> = makeCode re - -> matchRe2 :: (Ord t) => Re t -> [t] -> Bool -> matchRe2 re -> = matchRecursiveDfa (makeDfa re) - -Test cases - -> re1 :: Re Char -> re1 = ReOr [ReStar (ReCat [re0, re01]), ReStar (ReCat [re01, re0])] -> where -> re01 = ReOr [re0, re1] -> re0 = ReTerm "0" -> re1 = ReTerm "1" - -[+\-]?{digit}*(\.{digit}+)?([eE][+\-]?{digit}+)? - -> re2 :: Re Char -> re2 = ReCat [ReOpt (alt "+-"), -> ReOr [ReCat [digits1, ReOpt (ReCat [dot, digits0])], -> ReCat [digits0, dot, digits1]], -> ReOpt (ReCat [alt "eE", ReOpt (alt "+-"), digits1])] -> where -> alt cs = ReOr $ map (\c -> ReTerm [c]) cs -> digits0 = ReStar digit -> digits1 = RePlus digit -> digit = alt "0123456789" -> dot = ReTerm "." - diff --git a/Swish/HaskellRDF/GraphClass.hs b/Swish/HaskellRDF/GraphClass.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphClass.hs +++ /dev/null @@ -1,271 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} - - --------------------------------------------------------------------------------- --- $Id: GraphClass.hs,v 1.16 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphClass --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a Labelled Directed Graph and Label classes, --- and the Arc datatype. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Define LDGraph, arc and related classes and types ------------------------------------------------------------- - -module Swish.HaskellRDF.GraphClass - ( LDGraph(..), replaceArcs - , Label(..) - , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple - , Selector - , hasLabel, arcLabels - ) -where - -import Swish.HaskellUtils.ListHelpers - ( subset ) - -import Swish.HaskellUtils.FunctorM - ( FunctorM(..) ) - -import Data.List - ( nub, union, (\\) ) - --------------------------------- --- Labelled Directed Graph class --------------------------------- --- --- Minimum required implementation: setArcs, getArcs --- --- 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. -class (Eq (lg lb), Eq lb ) => LDGraph lg lb - where - -- empty graph - -- emptyGr :: lg lb [[[TODO?]]] - -- component-level operations - setArcs :: [Arc lb] -> lg lb -> lg lb -- setarcs [arcs] in g2 -> g3 - getArcs :: lg lb -> [Arc lb] -- g1 -> [arcs] - -- extract arcs from a graph - extract :: Selector lb -> lg lb -> lg lb -- select f1 from g2 -> g3 - extract sel = update (filter sel) - -- graph-level operations - add :: lg lb -> lg lb -> lg lb -- g1 + g2 -> g3 - add addg = update (union (getArcs addg)) - delete :: lg lb -> lg lb -> lg lb -- g2 - g1 -> g3 - delete delg = update (flip (\\) (getArcs delg)) - -- enumerate distinct labels contained in a graph - labels :: lg lb -> [lb] -- g1 -> [labels] - labels g = foldl union [] (map arcLabels (getArcs g)) - -- enumerate distinct labels contained in a graph - nodes :: lg lb -> [lb] -- g1 -> [labels] - nodes g = foldl union [] (map arcNodes (getArcs g)) - -- test for graph containment in another - containedIn :: lg lb -> lg lb -> Bool -- g1 <= g2? - -- g1 update arcs in a graph using a supplied function: - update :: ( [Arc lb] -> [Arc lb] ) -> lg lb -> lg lb - update f g = setArcs ( f (getArcs g) ) g - --- |Function to replace arcs in a graph with a given list of arcs -replaceArcs :: (LDGraph lg lb) => lg lb -> [Arc lb] -> lg lb -replaceArcs gr as = update (const as) gr - ---------------- --- Label class ---------------- --- --- A label may have a fixed binding, which means that the label identifies (is) a --- particular graph node, and different such labels are always distinct nodes. --- Alternatively, a label may be unbound (variable), which means that it is a --- placeholder for an unknown node label. Unbound node labels are used as --- graph-local identifiers for indicating when the same node appears in --- several arcs. --- --- For the purposes of graph-isomorphism testing, fixed labels are matched when they --- are the same. Variable labels may be matched with any other variable label. --- Our definition of isomorphism (for RDF graphs) does not match variable labels --- with fixed labels. - -class (Eq lb, Show lb, Ord lb) => Label lb where - labelIsVar :: lb -> Bool -- does this node have a variable binding? - labelHash :: Int -> lb -> Int -- calculate hash of label using supplied seed - getLocal :: lb -> String -- extract local id from variable node - makeLabel :: String -> lb -- make label value given local id - -- compare :: lb -> lb -> Ordering - -- compare l1 l2 = compare (show l1) (show l2) - ------------- --- Arc type ------------- - -data Arc lb = Arc { asubj, apred, aobj :: lb } - deriving Eq - -arcSubj :: Arc lb -> lb -arcSubj = asubj - -arcPred :: Arc lb -> lb -arcPred = apred - -arcObj :: Arc lb -> lb -arcObj = aobj - -arc :: lb -> lb -> lb -> Arc lb -arc s p o = Arc s p o - -arcToTriple :: Arc lb -> (lb,lb,lb) -arcToTriple a = (asubj a,apred a,aobj a) - -arcFromTriple :: (lb,lb,lb) -> Arc lb -arcFromTriple (s,p,o) = Arc s p o - -instance Ord lb => Ord (Arc lb) where - compare (Arc s1 p1 o1) (Arc s2 p2 o2) = - if cs /= EQ then cs else - if cp /= EQ then cp else co - where - cs = compare s1 s2 - cp = compare p1 p2 - co = compare o1 o2 - (Arc s1 p1 o1) <= (Arc s2 p2 o2) = - if (s1 /= s2) then (s1 <= s2) else - if (p1 /= p2) then (p1 <= p2) else (o1 <= o2) - -instance Functor Arc where - -- fmap :: (lb -> l2) -> Arc lb -> Arc l2 - fmap f (Arc s p o) = Arc (f s) (f p) (f o) - -instance FunctorM Arc where - -- fmapM :: (lb -> m l2) -> Arc lb -> m (Arc l2) - fmapM f (Arc s p o) = - do { s' <- f s - ; p' <- f p - ; o' <- f o - ; return $ Arc s' p' o' - } - -instance (Show lb) => Show (Arc lb) where - show (Arc lb1 lb2 lb3) = - "("++(show lb1)++","++(show lb2)++","++(show lb3)++")" - -type Selector lb = Arc lb -> Bool - -hasLabel :: (Eq lb) => lb -> Arc lb -> Bool -hasLabel lbv (Arc lb1 lb2 lb3) = (lbv==lb1) || (lbv==lb2) || (lbv==lb3) - -arcLabels :: Arc lb -> [lb] -arcLabels (Arc lb1 lb2 lb3) = [lb1,lb2,lb3] - -arcNodes :: Arc lb -> [lb] -arcNodes (Arc lb1 _ lb3) = [lb1,lb3] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphClass.hs,v $ --- $Author: graham $ --- $Revision: 1.16 $ --- $Log: GraphClass.hs,v $ --- Revision 1.16 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. --- --- Revision 1.15 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.14 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.13 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.12 2003/06/10 17:38:34 graham --- Remove some unneeded calss constraints from data type declarations --- Reworked NSGraph to be an instance of Functor, replacing function --- gmap with fmap. Graph formulae are still not handled well: the data types --- will need re-working so that a "Formula lb" type constructor can be --- introduced having the correct (* -> *) kind to be a Functor. --- --- Revision 1.11 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.10 2003/05/30 15:04:56 graham --- Fix references to defunct GraphHelpers module --- --- Revision 1.9 2003/05/29 01:50:56 graham --- More performance tuning, courtesy of GHC profiler. --- All modules showing reasonable performance now. --- --- Revision 1.8 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.7 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.6 2003/05/23 16:29:20 graham --- Partial code cleanup: --- - Arc is an alebraic type --- - Arc is an instance of Functor --- - add gmap function to Graph interface --- - remove some duplicate functions from GraphMatch --- This in preparation for adding graph merge facility with --- blank node renaming. --- --- Revision 1.5 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.4 2003/04/10 13:35:34 graham --- Separated GraphMatch logic from GraphMem --- --- Revision 1.3 2003/04/10 08:36:06 graham --- Graph matching passes battery of new tests --- Started work on RDF graph --- --- Revision 1.2 2003/03/31 20:52:23 graham --- Restructure graph matching to deal with same unbound node names in --- different graphs. It shows signs that it might be working now. --- More testing is needed. --- --- Revision 1.1 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- diff --git a/Swish/HaskellRDF/GraphMatch.hs b/Swish/HaskellRDF/GraphMatch.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphMatch.hs +++ /dev/null @@ -1,741 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XTypeSynonymInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- $Id: GraphMatch.hs,v 1.19 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphMatch --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains graph-matching logic. --- --- The algorithm used is derived from a paper on RDF graph matching --- by Jeremy Carroll [1]. --- --- [1] http://www.hpl.hp.com/techreports/2001/HPL-2001-293.html --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.GraphMatch - ( graphMatch, - -- The rest exported for testing only - 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.HaskellUtils.LookupMap -import Swish.HaskellUtils.ListHelpers -import Swish.HaskellUtils.MiscHelpers -import Swish.HaskellUtils.TraceHelpers( trace, traceShow ) -import Swish.HaskellRDF.GraphClass -import Data.Maybe( isJust ) -import Data.List( nub, sortBy, partition ) -import qualified Data.List - --------------------------- --- Label index value type --------------------------- --- --- LabelIndex is a unique value assigned to each label, such that --- labels with different values are definitely different values --- in the graph; e.g. do not map to each other in the graph --- bijection. The first member is a generation counter that --- ensures new values are distinct from earlier passes. - -type LabelIndex = (Int,Int) - -nullLabelVal :: LabelIndex -nullLabelVal = (0,0) - ------------------------ --- Label mapping types ------------------------ - -data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv - -type LabelEntry lb = GenLabelEntry lb LabelIndex - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => LookupEntryClass (GenLabelEntry lb lv) lb lv where - keyVal (LabelEntry k v) = (k,v) - newEntry (k,v) = LabelEntry k v - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Show (GenLabelEntry lb lv) where - show = entryShow - -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Eq (GenLabelEntry lb lv) where - (==) = entryEq - --- Type for label->index lookup table -data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = - LabelMap Int (LookupMap (GenLabelEntry lb lv)) - -type LabelMap lb = GenLabelMap lb LabelIndex - -instance (Label lb) => Show (LabelMap lb) where - show = showLabelMap - -instance (Label lb) => Eq (LabelMap lb) where - LabelMap gen1 lmap1 == LabelMap gen2 lmap2 = - (gen1 == gen2) && (es1 `equiv` es2) - where - es1 = listLookupMap lmap1 - es2 = listLookupMap lmap2 - -emptyMap :: (Label lb) => LabelMap lb -emptyMap = LabelMap 1 $ makeLookupMap [] - --------------------------- --- Equivalence class type --------------------------- --- --- Type for equivalence class description --- (An equivalence class is a collection of labels with --- the same LabelIndex value.) - -type EquivalenceClass lb = (LabelIndex,[lb]) - -ecIndex :: EquivalenceClass lb -> LabelIndex -ecIndex = fst - -ecLabels :: EquivalenceClass lb -> [lb] -ecLabels = snd - -ecSize :: EquivalenceClass lb -> Int -ecSize (_,ls) = length ls - -ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb -ecRemoveLabel (lv,ls) l = (lv,Data.List.delete l ls) - ------------------------------------------------------------- --- Augmented graph label value - for graph matching ------------------------------------------------------------- --- --- This instance of class label adds a graph identifier to --- each variable label, so that variable labels from --- different graphs are always seen as distinct values. --- --- The essential logic added by this class instance is embodied --- in the eq and hash functions. Note that variable label hashes --- depend only on the graph in which they appear, and non-variable --- label hashes depend only on the variable. Label hash values are --- used when initializing a label equivalence-class map (and, for --- non-variable labels, also for resolving hash collisions). - -data (Label lb) => ScopedLabel lb = ScopedLabel Int lb - -makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb -makeScopedLabel scope lab = ScopedLabel scope lab - -makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb) -makeScopedArc scope a1 = arc (s arcSubj a1) (s arcPred a1) (s arcObj a1) - where - s f a = (ScopedLabel scope (f a)) - -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 = hash seed $ (show scope)++"???" - | otherwise = labelHash seed lab - -instance (Label lb) => Eq (ScopedLabel lb) where - (ScopedLabel s1 l1) == (ScopedLabel s2 l2) - = ( l1 == l2 ) && (s1 == s2) - -instance (Label lb) => Show (ScopedLabel lb) where - show (ScopedLabel s1 l1) = (show s1) ++ ":" ++ (show l1) - -instance (Label lb) => Ord (ScopedLabel lb) where - compare (ScopedLabel s1 l1) (ScopedLabel s2 l2) = - case (compare s1 s2) of - LT -> LT - EQ -> compare l1 l2 - GT -> GT - --------------- --- graphMatch --------------- --- --- Graph matching function accepting two lists of arcs and --- returning a node map if successful --- --- matchable --- is 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.) --- gs1 is the first of two graphs to be compared, --- supplied as a list of arcs. --- gs2 is the second of two graphs to be compared, --- supplied as a list of arcs. --- --- returns a label map that maps each label to an equivalence --- class identifier, or Nothing if the graphs cannot be --- matched. - -graphMatch :: (Label lb) => - (lb -> lb -> Bool) -> [Arc lb] -> [Arc lb] - -> (Bool,LabelMap (ScopedLabel lb)) -graphMatch matchable gs1 gs2 = - let - sgs1 = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1 - sgs2 = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2 - ls1 = {- traceShow "ls1 " $ -} graphLabels sgs1 - ls2 = {- traceShow "ls2 " $ -} graphLabels sgs2 - lmap = {- traceShow "lmap " $ -} - newGenerationMap $ - assignLabelMap ls1 $ - assignLabelMap ls2 emptyMap - ec1 = {- traceShow "ec1 " $ -} equivalenceClasses lmap ls1 - ec2 = {- traceShow "ec2 " $ -} equivalenceClasses lmap ls2 - ecpairs = zip (pairSort ec1) (pairSort ec2) - matchableScoped (ScopedLabel _ l1) (ScopedLabel _ l2) = matchable l1 l2 - match = graphMatch1 False matchableScoped sgs1 sgs2 lmap ecpairs - in - if (length ec1) /= (length ec2) then (False,emptyMap) else match - --- Recursive graph matching function --- This function assumes that no variable label appears in both graphs. --- (Function graphMatch, which calls this, ensures that all variable --- labels are distinct.) --- --- matchable --- is 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. --- guessed is True if a guess has been used before trying this comparison, --- False if nodes are being matched without any guesswork. --- gs1 is the first of two lists of arcs (triples) to be compared --- gs2 is the second of two lists of arcs (triples) to be compared --- lmap is the map so far used to map label values to equivalence --- class values --- ecpairs 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. --- --- returns a pair (match,map), where 'match' is Tue 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. --- --- [[[TODO: replace Equivalence class pair by (index,[lb],[lb]) ?]]] --- [[[TODO: possible optimization: the graphMapEq test should be --- needed only if graphMatch2 has been used to guess a --- mapping; either (a) supply flag saying guess has been --- used, or (b) move test to graphMatch2 and use different --- test to prevent rechecking for each guess used.]]] - -graphMatch1 :: (Label lb) => Bool -> (lb -> lb -> Bool) - -> [Arc lb] -> [Arc lb] - -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] - -> (Bool,(LabelMap lb)) -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 - ecEqSize ( (_,ls1) , (_,ls2) ) = (length ls1) == (length ls2) - ecSize ( (_,ls1) , _ ) = length ls1 - ecCompareSize ec1 ec2 = compare (ecSize ec1) (ecSize ec2) - (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)) $ - if not $ all ecEqSize mecs then (False,lmap) - else - -- invoke reclassification, and deal with result - if not matchEc then (False,lmap) - else - if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' - else - -- if guess does not result in a match, return supplied label map - if fst match2 then match2 else (False,lmap) - --- Auxiliary graph matching function --- This function is called when deterministic decomposition of node --- mapping equivalence classes has run its course. --- --- It picks a pair of equivalence classes in ecpairs, and arbitrarily matches --- pairs of nodes in those equivalence classes, recursively calling the --- graph matching function until a suitable node mapping is discovered --- (success), or until all such pairs have been tried (failure). --- --- This function represents a point to which arbitrary choices are backtracked. --- The list comprehension 'glp' represents the alternative choices at the --- point of backtracking --- --- The selected pair of nodes are placed in a new equivalence class based on their --- original equivalence class value, but with a new NodeVal generation number. - -graphMatch2 :: (Label lb) => (lb -> lb -> Bool) - -> [Arc lb] -> [Arc lb] - -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] - -> (Bool,(LabelMap lb)) -graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) = - let - (_,v1) = ev1 - (_,v2) = ev2 - -- 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 equiv 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 ?]]] - equiv (False,_) _ _ = False - equiv (True,lmap) l1 l2 = - (mapLabelIndex m1 l1) == (mapLabelIndex m2 l2) - where - m1 = remapLabels gs1 lmap [l1] - m2 = remapLabels gs2 lmap [l2] - -- 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 - ----------------------- --- LabelMap functions ----------------------- - ----------------- --- showLabelMap ----------------- --- --- 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 "++)) (map Prelude.show es )) - where - es = listLookupMap lmap - ------------------ --- mapLabelIndex ------------------ --- --- Map a label to its corresponding label index value in the supplied LabelMap - -mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex -mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms - --------------- --- labelMatch --------------- --- --- Confirm that a given pair of labels are matchable, and are --- mapped to the same value by the supplied label map - -labelMatch :: (Label lb) - => (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool -labelMatch matchable lmap l1 l2 = - (matchable l1 l2) && ((mapLabelIndex lmap l1) == (mapLabelIndex lmap l1)) - ---------------- --- newLabelMap ---------------- --- --- Replace selected values in a label map with new values from the supplied --- list of labels and new label index values. The generation number is --- supplied from the current label map. The generation number in the --- resulting label map is incremented. - -newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb -newLabelMap (LabelMap g f) [] = (LabelMap (g+1) f) -- new generation -newLabelMap lmap (lv:lvs) = setLabelHash (newLabelMap lmap lvs) lv - ----------------- --- setLabelHash ----------------- --- --- setLabelHash replaces a label and its associated value in a label map --- with a new value using the supplied hash value and the current --- LabelMap generation number. If the key is not found, then no change --- is made to the label map. - -setLabelHash :: (Label lb) - => LabelMap lb -> (lb,Int) -> LabelMap lb -setLabelHash (LabelMap g lmap) (lb,lh) = - LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) ) - --------------------- --- newGenerationMap --------------------- --- --- Increment generation of 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) - ------------------- --- assignLabelMap ------------------- --- --- Scan label list, assigning initial label map values, --- adding new values to the label map supplied. --- --- Label map values are assigned on the basis of the --- label alone, without regard for it's connectivity in --- the graph. (cf. reClassify) --- --- All variable node labels are assigned the same initial --- value, as they may be matched with each other. - -assignLabelMap :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb -assignLabelMap [] lmap = lmap -assignLabelMap (n:ns) lmap = assignLabelMap ns (assignLabelMap1 n lmap) - -assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb -assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs' - where - lvs' = (mapAddIfNew lvs $ newEntry (lab,(g,initVal lab))) - --- Calculate initial value for a node - -initVal :: (Label lb) => lb -> Int -initVal n = hashVal 0 n - -hashVal :: (Label lb) => Int -> lb -> Int -hashVal seed lab = - if (labelIsVar lab) then (hash seed "???") else (labelHash seed lab) - ----------------------- --- equivalenceClasses ----------------------- --- --- lmap label map --- ls list of nodes to be reclassified --- --- return list of equivalence classes of the supplied labels under --- the supplied label map. - -equivalenceClasses :: (Label lb) => LabelMap lb -> [lb] -> [EquivalenceClass lb] -equivalenceClasses lmap ls = - pairGroup $ map labelPair ls - where - labelPair l = (mapLabelIndex lmap l,l) - --------------- --- reclassify --------------- --- --- 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. --- --- gs1 is the first of two lists of arcs (triples) to perform a --- basis for reclassifying the labels in the first equivalence --- class in each pair of 'ecpairs'. --- gs2 is the second of two lists of arcs (triples) to perform a --- basis for reclassifying the labels in the second equivalence --- class in each pair of 'ecpairs'. --- lmap is a label map used for classification of the labels in --- the supplied equivalence classes. --- ecpairs 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. --- --- return a quadruple of: --- (a) a revised label map reflecting the reclassification, --- (b) a new list of equivalence class pairs based on the --- new node map, and --- (c) if the reclassification partitions any of the --- supplied equivalence classes then True, else False. --- any of the supplied equivalence classes --- (d) if reclassification results in each equivalence class --- being split same-sized equivalence classes in the two graphs, --- then True, otherwise False. - -reclassify :: (Label lb) => - [Arc lb] -> [Arc lb] - -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] - -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool) -reclassify gs1 gs2 lmap@(LabelMap _ lm) ecpairs = - assert (gen1==gen2) "Label map generation mismatch" $ - (LabelMap gen1 lm',ecpairs',newPart,matchPart) - where - LabelMap gen1 lm1 = - remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs - LabelMap gen2 lm2 = - remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs - lm' = mapReplaceMap lm $ mapMerge lm1 lm2 - -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])] - ecGroups = [ (remapEc ec1,remapEc ec2) | (ec1,ec2) <- ecpairs ] - ecpairs' = concat $ map (uncurry zip) ecGroups - newPart = or $ map pairG1 lenGroups - matchPart = and $ map pairEq lenGroups - lenGroups = map subLength ecGroups - pairEq (p1,p2) = p1 == p2 - pairG1 (p1,p2) = (p1 > 1) || (p2 > 1) - subLength (ls1,ls2) = (length ls1,length ls2) - remapEc ec = pairGroup $ map (newIndex lm') $ pairUngroup ec - newIndex lm (_,lab) = (mapFind nullLabelVal lab lm,lab) - ---------------- --- remapLabels ---------------- --- --- Calculate a new index value for a supplied list of labels based on the --- supplied label map and adjacency calculations in the supplied graph --- --- gs is a list of Arcs used for adjacency calculations when remapping --- lmap is a label map used for obtaining current label index values --- ls is a list of graph labels for which new mappings are to be --- created and returned. --- return a new label map containing recalculated label index values --- for the labels in ls. The label map generation number is --- incremented by 1 from the supplied 'lmap' value. - -remapLabels :: (Label lb) => - [Arc lb] -> LabelMap lb -> [lb] -> LabelMap lb -remapLabels gs lmap@(LabelMap gen _) ls = - LabelMap gen' (LookupMap newEntries) - where - gen' = gen+1 - newEntries = [ newEntry (l, (gen',newIndex l)) | l <- ls ] - newIndex l - | labelIsVar l = mapAdjacent l -- adjacency classifies variable labels - | otherwise = hashVal gen l -- otherwise rehash (to disentangle collisions) - mapAdjacent l = ( sum (sigsOver l) ) `rem` hashModulus - sigsOver l = select (hasLabel l) gs (arcSignatures lmap gs) - ------------------------------ --- Graph auxiliary functions ------------------------------ - ---------------- --- graphLabels ---------------- --- --- Return list of distinct labels used in a graph - -graphLabels :: (Label lb) => [Arc lb] -> [lb] -graphLabels gs = nub $ concat $ map arcLabels gs - -{- OLD CODE: -graphLabels gs = graphLabels1 gs [] - -graphLabels1 (t:gs) ls = graphLabels1 gs $ - foldl (flip addSetElem) ls (arcLabels t) -graphLabels1 [] ls = ls --} - --- addSetElem :: lb -> [lb] -> [lb] - ------------------ --- arcSignatures ------------------ --- --- 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. --- --- lmap is a label map used for obtaining current label index values --- gs is the list of arcs for which signaturews are calculated --- return a list of signature values in correspondence with gs - -arcSignatures :: (Label lb) => LabelMap lb -> [Arc lb] -> [Int] -arcSignatures lmap gs = - map (sigCalc . arcToTriple) gs - where - sigCalc (s,p,o) = - ( (labelVal2 s) + - (labelVal2 p)*3 + - (labelVal2 o)*5 ) `rem` hashModulus - labelVal l = mapLabelIndex lmap l - labelVal2 = (\v -> (fst v) * (snd v) ) . labelVal - ------------- --- graphMap ------------- --- --- Return new graph that is supplied graph with every node/arc --- mapped to a new value according to the supplied function. --- --- Used for testing for graph equivalence under a supplied --- label mapping; e.g. --- --- if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same) - -graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex] -graphMap lmap = map $ fmap (mapLabelIndex lmap) -- graphMapStmt - --------------- --- graphMapEq --------------- --- --- Compare a pair of graphs for equivalence under a given mapping --- function. --- --- This is used to perform the ultimate test that two graphs are --- indeed equivalent: guesswork in graphMatch2 means that it is --- occasionally possible to construct a node mapping that generates --- the required singleton equivalence classes, but does not fully --- reflect the topology of the graphs. - -graphMapEq :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc lb] -> Bool -graphMapEq lmap gs1 gs2 = (graphMap lmap gs1) `equiv` (graphMap lmap gs2) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphMatch.hs,v $ --- $Author: graham $ --- $Revision: 1.19 $ --- $Log: GraphMatch.hs,v $ --- Revision 1.19 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. --- --- Revision 1.18 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.17 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.16 2003/10/24 21:03:25 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.15 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.14 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.13 2003/05/29 01:50:56 graham --- More performance tuning, courtesy of GHC profiler. --- All modules showing reasonable performance now. --- --- Revision 1.12 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.11 2003/05/23 16:29:20 graham --- Partial code cleanup: --- - Arc is an alebraic type --- - Arc is an instance of Functor --- - add gmap function to Graph interface --- - remove some duplicate functions from GraphMatch --- This in preparation for adding graph merge facility with --- blank node renaming. --- --- Revision 1.10 2003/05/14 11:13:15 graham --- Fixed bug in graph matching. --- (A graph-equivalence check is needed to weed out false matches --- caused by the "guessing" stage.) --- --- Revision 1.9 2003/05/14 02:01:59 graham --- GraphMatch recoded and almost working, but --- there are a couple of --- obscure bugs that are proving rather stubborn to squash. --- --- Revision 1.8 2003/05/09 00:29:14 graham --- Started to restructure graph matching code --- --- Revision 1.7 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.6 2003/05/01 23:15:44 graham --- GraphTest passes all tests using refactored LookupMap --- Extensive changes to GraphMatch were required. --- --- Revision 1.5 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.4 2003/04/11 18:12:10 graham --- Renamed GraphHelpers to ListHelpers --- LookupMapTest, GraphTest, RDFGraphTest all run OK --- --- Revision 1.3 2003/04/11 18:04:49 graham --- Rename GraphLookupMap to LookupMap: --- GraphTest runs OK. --- --- Revision 1.2 2003/04/10 16:47:04 graham --- Minor code cleanup --- --- Revision 1.1 2003/04/10 13:35:34 graham --- Separated GraphMatch logic from GraphMem --- diff --git a/Swish/HaskellRDF/GraphMem.hs b/Swish/HaskellRDF/GraphMem.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphMem.hs +++ /dev/null @@ -1,264 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- $Id: GraphMem.hs,v 1.16 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphMem --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a simple memory-based graph instance. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Simple labelled directed graph value ------------------------------------------------------------- - -module Swish.HaskellRDF.GraphMem - ( GraphMem(..) - , setArcs, getArcs, add, delete, extract, labels - , LabelMem(..) - , labelIsVar, labelHash - -- For debug/test: - , matchGraphMem - ) where - -import Swish.HaskellUtils.LookupMap -import Swish.HaskellRDF.GraphClass -import Swish.HaskellRDF.GraphMatch -import Swish.HaskellUtils.MiscHelpers - ( hash ) -import Swish.HaskellUtils.FunctorM - ( FunctorM(..) ) -import Data.List - ( nub, union, (\\), group, sort, sortBy, any ) -import Data.Maybe - ( isJust ) - ------------------------------------------------------ --- Memory-based graph type and graph class functions ------------------------------------------------------ - -data GraphMem lb = GraphMem { arcs :: [Arc lb] } - -instance (Label lb) => LDGraph GraphMem lb where - getArcs = arcs - setArcs as g = g { arcs=as } - -- gmap f g = g { arcs = (map $ fmap f) (arcs g) } - -instance (Label lb) => Eq (GraphMem lb) where - (==) = graphEq - -instance (Label lb) => Show (GraphMem lb) where - show = graphShow - -instance Functor GraphMem where - fmap f g = GraphMem $ map (fmap f) (arcs g) - -instance FunctorM GraphMem where - fmapM f g = - do { arcs <- mapM (fmapM f) (arcs g) - ; return $ GraphMem arcs - } - -graphShow :: (Label lb) => GraphMem lb -> String -graphShow g = "Graph:"++(foldr (++) "" (map ("\n "++) (map show (arcs g)))) - -toGraph :: (Label lb) => [Arc lb] -> GraphMem lb -toGraph as = GraphMem { arcs=(nub as) } - ------------ --- graphEq ------------ --- --- Return Boolean graph equality - -graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool -graphEq g1 g2 = fst ( matchGraphMem g1 g2 ) - ------------------ --- matchGraphMem ------------------ --- --- GraphMem matching function accepting GraphMem value and returning --- node map if successful --- --- g1 is the first of two graphs to be compared --- g2 is the second of two graphs to be compared --- --- returns a label map that maps each label to an equivalence --- class identifier, or Nothing if the graphs cannot be --- matched. - -matchGraphMem :: (Label lb) => GraphMem lb -> GraphMem lb - -> (Bool,LabelMap (ScopedLabel lb)) -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 - ---------------- --- graphBiject ---------------- --- --- 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 Label LabelMem where - labelIsVar (LV _) = True - labelIsVar _ = False - getLocal (LV loc) = loc - getLocal lab = error "getLocal of non-variable label: "++(show lab) - makeLabel loc = LV loc - labelHash seed lb = hash seed (show lb) - -instance Eq LabelMem where - (LF l1) == (LF l2) = l1 == l2 - (LV l1) == (LV l2) = l1 == l2 - _ == _ = False - -instance Show LabelMem where - show (LF l1) = "!"++l1 - show (LV l2) = "?"++l2 - -instance Ord LabelMem where - compare l1 l2 = compare (show l1) (show l2) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphMem.hs,v $ --- $Author: graham $ --- $Revision: 1.16 $ --- $Log: GraphMem.hs,v $ --- Revision 1.16 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. --- --- Revision 1.15 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.14 2003/06/10 17:38:34 graham --- Remove some unneeded calss constraints from data type declarations --- Reworked NSGraph to be an instance of Functor, replacing function --- gmap with fmap. Graph formulae are still not handled well: the data types --- will need re-working so that a "Formula lb" type constructor can be --- introduced having the correct (* -> *) kind to be a Functor. --- --- Revision 1.13 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.12 2003/05/30 15:04:56 graham --- Fix references to defunct GraphHelpers module --- --- Revision 1.11 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.10 2003/05/23 16:29:20 graham --- Partial code cleanup: --- - Arc is an alebraic type --- - Arc is an instance of Functor --- - add gmap function to Graph interface --- - remove some duplicate functions from GraphMatch --- This in preparation for adding graph merge facility with --- blank node renaming. --- --- Revision 1.9 2003/05/14 02:01:59 graham --- GraphMatch recoded and almost working, but --- there are a couple of --- obscure bugs that are proving rather stubborn to squash. --- --- Revision 1.8 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.7 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.6 2003/04/11 18:04:49 graham --- Rename GraphLookupMap to LookupMap: --- GraphTest runs OK. --- --- Revision 1.5 2003/04/10 13:41:22 graham --- More graph code tidying --- Graph test cases still run OK --- --- Revision 1.4 2003/04/10 13:35:34 graham --- Separated GraphMatch logic from GraphMem --- --- Revision 1.3 2003/04/10 08:36:06 graham --- Graph matching passes battery of new tests --- Started work on RDF graph --- --- Revision 1.2 2003/03/31 20:52:23 graham --- Restructure graph matching to deal with same unbound node names in --- different graphs. It shows signs that it might be working now. --- More testing is needed. --- --- Revision 1.1 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- diff --git a/Swish/HaskellRDF/GraphPartition.hs b/Swish/HaskellRDF/GraphPartition.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphPartition.hs +++ /dev/null @@ -1,560 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: GraphPartition.hs,v 1.3 2004/02/11 14:19:36 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphPartition --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains functions for partitioning a graph into subgraphs --- that rooted from different subject nodes. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.GraphPartition - ( PartitionedGraph(..), getArcs, getPartitions - , GraphPartition(..), node, toArcs - , partitionGraph, comparePartitions - , partitionShowP - ) -where - -import Swish.HaskellRDF.GraphClass - ( Label(..) - , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple - -- , hasLabel, arcLabels - ) - -import Data.List - ( partition ) - -import Control.Monad.State - ( MonadState(..), State(..), evalState ) - -import Data.Maybe - ( isJust, fromJust, catMaybes, listToMaybe ) - - ------------------------------------------------------------- --- Data type for a partitioned graph ------------------------------------------------------------- - --- |Representation of a graph as a collection of (possibly nested) --- partitions. Each node in the graph appears at least once as the --- root value of a GraphPartition value: --- --- * Nodes that are the subject of at least one statement appear as --- the first value of exactly one PartSub constructor, and may --- also appear in any number of PartObj constructors. --- --- * Nodes appearing only as objects of statements appear only in --- PartObj constructors. - -data PartitionedGraph lb = PartitionedGraph [GraphPartition lb] - deriving (Eq,Show) - -getArcs :: PartitionedGraph lb -> [Arc lb] -getArcs (PartitionedGraph ps) = concatMap toArcs ps - -getPartitions :: PartitionedGraph lb -> [GraphPartition lb] -getPartitions (PartitionedGraph ps) = ps - -data GraphPartition lb - = PartObj lb - | PartSub lb [(lb,GraphPartition lb)] - -node :: GraphPartition lb -> lb -node (PartObj ob) = ob -node (PartSub sb _) = sb - -toArcs :: GraphPartition lb -> [Arc lb] -toArcs (PartObj _) = [] -toArcs (PartSub sb prs) = concat $ map toArcs1 prs - where - toArcs1 (pr,ob) = (Arc sb pr (node ob)):toArcs ob - -instance (Label lb) => Eq (GraphPartition lb) where - (==) = partitionEq - -instance (Label lb) => Show (GraphPartition lb) where - show = partitionShow - --- Equality is based on total structural equivalence. --- This is not the same as graph equality. -partitionEq :: (Label lb) => (GraphPartition lb) -> (GraphPartition lb) -> Bool -partitionEq (PartObj o1) (PartObj o2) = o1 == o2 -partitionEq (PartSub s1 p1) (PartSub s2 p2) = (s1 == s2) && (p1==p2) -partitionEq _ _ = False - -partitionShow :: (Label lb) => (GraphPartition lb) -> String -partitionShow (PartObj ob) = show ob -partitionShow (PartSub sb (pr:prs)) = - "("++ show sb ++ " " ++ showpr pr ++ concatMap ((" ; "++).showpr) prs ++ ")" - where - showpr (pr,ob) = show pr ++ " " ++ show ob - -partitionShowP :: (Label lb) => String -> (GraphPartition lb) -> String -partitionShowP pref (PartObj ob) = show ob -partitionShowP pref (PartSub sb (pr:prs)) = - pref++"("++ show sb ++ " " ++ showpr pr ++ concatMap (((pref++" ; ")++).showpr) prs ++ ")" - where - showpr (pr,ob) = show pr ++ " " ++ partitionShowP (pref++" ") ob - ------------------------------------------------------------- --- 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: --- (a) isolating differences between graphs --- (b) pretty-printing graphs --- --- For (a), the goal is to separate subgraphs that are known --- to be equivalent from subgraphs that are known to be different, --- such that (i) different sub-graphs are minimized, (ii) different --- sub-graphs are placed into 1:1 correspondence (possibly with null --- subgraphs), and (iii) only deterministic matching decisions are made. --- --- For (b), 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: --- 1. all non-blank subject nodes are the root of a top-level partition --- 2. blank subject nodes that are not the object of exactly one statement --- are the root of a top-level partition. --- 3. 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. --- 4. what remain are circular chains of blank nodes not referenced --- elsewhere: for each such chain, pick a root node arbitrarily. --- -partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb -partitionGraph arcs = - makePartitions fixs topv1 intv1 - where - (fixs,vars) = partition isNonVar $ collect arcSubj arcs - vars1 = collectMore arcObj arcs vars - (intv,topv) = partition objOnce vars1 - intv1 = map stripObj intv - topv1 = map stripObj topv - isNonVar = not . labelIsVar . fst - objOnce = isSingle . snd . snd - isSingle [_] = True - isSingle _ = False - stripObj (k,(s,_)) = (k,s) - --- Local state type for partitioning function -type MakePartitionState lb = ([(lb,[Arc lb])],[(lb,[Arc lb])],[(lb,[Arc lb])]) - -makePartitions :: (Eq lb) => - [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> PartitionedGraph lb -makePartitions fixs topv intv = - PartitionedGraph $ evalState (makePartitions1 []) (fixs,topv,intv) - --- Use a state monad to keep track of arcs that have been incorporated into --- the resulting list of graph partitions. The collections of arcs used to --- generate the list of partitions are supplied as theinitial state of the --- monad (see call of evalState above). --- -makePartitions1 :: (Eq lb) => - [(lb,[Arc lb])] -> State (MakePartitionState lb) [GraphPartition lb] -makePartitions1 [] = - do { s <- pickNextSubject - ; if null s then return [] else makePartitions1 s - } -makePartitions1 (sub:subs) = - do { ph <- makePartitions2 sub - ; pt <- makePartitions1 subs - ; return $ ph++pt - } - -makePartitions2 :: (Eq lb) => - (lb,[Arc lb]) -> State (MakePartitionState lb) [GraphPartition lb] -makePartitions2 subs = - do { (part,moresubs) <- makeStatements subs - ; moreparts <- if (not $ null moresubs) then - makePartitions1 moresubs - else - return [] - ; return $ part:moreparts - } - -makeStatements :: (Eq lb) => - (lb,[Arc lb]) - -> State (MakePartitionState lb) (GraphPartition lb,[(lb,[Arc lb])]) -makeStatements (sub,stmts) = - do { propmore <- sequence (map makeStatement stmts) - ; let (props,moresubs) = unzip propmore - ; return (PartSub sub props,concat moresubs) - } - -makeStatement :: (Eq lb) => - Arc lb - -> State (MakePartitionState lb) ((lb,GraphPartition lb),[(lb,[Arc lb])]) -makeStatement (Arc sub prop obj) = - do { intobj <- pickIntSubject obj - ; (gpobj,moresubs) <- if null intobj - then - do { ms <- pickVarSubject obj - ; return (PartObj obj,ms) - } - else - makeStatements (head intobj) - ; return ((prop,gpobj),moresubs) - } - -pickNextSubject :: State (MakePartitionState lb) [(lb,[Arc lb])] -pickNextSubject = - do { (s1,s2,s3) <- get - ; let (s,st) = case (s1,s2,s3) of - (s1h:s1t,s2,s3) -> ([s1h],(s1t,s2,s3)) - ([],s2h:s2t,s3) -> ([s2h],([],s2t,s3)) - ([],[],s3h:s3t) -> ([s3h],([],[],s3t)) - ([],[],[]) -> ([] ,([],[],[] )) - ; put st - ; return s - } - -pickIntSubject :: (Eq lb) => - lb -> State (MakePartitionState lb) [(lb,[Arc lb])] -pickIntSubject sub = - do { (s1,s2,s3) <- get - ; let varsub = removeBy (\x->(x==).fst) sub s3 - ; if (isJust varsub) then - do { let (vs,s3new) = fromJust varsub - ; put (s1,s2,s3new) - ; return [vs] - } - else - return [] - } - -pickVarSubject :: (Eq lb) => - lb -> State (MakePartitionState lb) [(lb,[Arc lb])] -pickVarSubject sub = - do { (s1,s2,s3) <- get - ; let varsub = removeBy (\x->(x==).fst) sub s2 - ; if (isJust varsub) then - do { let (vs,s2new) = fromJust varsub - ; put (s1,s2new,s3) - ; return [vs] - } - else - return [] - } - ------------------------------------------------------------- --- Other useful functions ------------------------------------------------------------- --- --- Create a list of pairs of corresponding Partitions that --- are unequal - -comparePartitions :: (Label lb) => - PartitionedGraph lb -> PartitionedGraph lb - -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions (PartitionedGraph gp1) (PartitionedGraph gp2) = - comparePartitions1 (reverse gp1) (reverse gp2) - -comparePartitions1 :: (Label lb) => - [GraphPartition lb] -> [GraphPartition lb] - -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions1 pg1 pg2 = - ds ++ [ (Just r1p,Nothing) | r1p<-r1 ] - ++ [ (Nothing,Just r2p) | r2p<-r2 ] - where - (ds,r1,r2) = listDifferences comparePartitions2 pg1 pg2 - --- Compare two graph partitions, with three possible outcomes: --- Nothing -> no match --- Just [] -> total match --- Just [...] -> partial match, with mismatched sub-partitions listed. --- --- A partial match occurs when the leading nodes are non-variable and --- equal, but something else in the partition does not match. --- --- A complete match can be achieved with variable nodes that have --- different labels --- -comparePartitions2 :: (Label lb) => - GraphPartition lb -> GraphPartition lb - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions2 (PartObj l1) (PartObj l2) = - if matchNodes l1 l2 then Just [] else Nothing -comparePartitions2 pg1@(PartSub l1 p1s) pg2@(PartSub l2 p2s) = - if match then comp1 else Nothing - where - comp1 = case comparePartitions3 l1 l2 p1s p2s of - Nothing -> if matchVar then Nothing - else Just [(Just pg1,Just pg2)] - Just [] -> Just [] - Just ps -> {- if matchVar then Nothing else -} Just ps - matchVar = labelIsVar l1 && labelIsVar l2 - match = matchVar || (l1 == l2) -comparePartitions2 pg1 pg2 = - if not (labelIsVar l1) && (l1==l2) - then Just [(Just pg1,Just pg2)] - else Nothing - where - l1 = node pg1 - l2 = node pg2 - -comparePartitions3 :: (Label lb) => - lb -> lb -> [(lb,GraphPartition lb)] -> [(lb,GraphPartition lb)] - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions3 l1 l2 s1s s2s = Just $ - ds ++ [ (Just (PartSub l1 [r1p]),Nothing) | r1p<-r1 ] - ++ [ (Nothing,Just (PartSub l2 [r2p])) | r2p<-r2 ] - where - (ds,r1,r2) = listDifferences (comparePartitions4 l1 l2) s1s s2s - -comparePartitions4 :: (Label lb) => - lb -> lb -> (lb,GraphPartition lb) -> (lb,GraphPartition lb) - -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] -comparePartitions4 s1 s2 po1@(p1,o1) po2@(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 - -- nomatch = (Just (PartSub s1 [po1]),Just (PartSub s2 [po2])) - -matchNodes :: (Label lb) => lb -> lb -> Bool -matchNodes l1 l2 - | labelIsVar l1 = labelIsVar l2 - | otherwise = l1 == l2 - - ------------------------------------------------------------- --- Helpers ------------------------------------------------------------- - --- |Collect a list of items by some comparison of a selected component --- or other derived value. --- --- cmp a comparison function that determines if a pair of values --- should be grouped together --- sel a function that selects a value from any item --- --- Example: collect fst [(1,'a'),(2,'b'),(1,'c')] = --- [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])] --- -collect :: (Eq b) => (a->b) -> [a] -> [(b,[a])] -collect = collectBy (==) - -collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b,[a])] -collectBy cmp sel = map reverseCollection . collectBy1 cmp sel [] - -collectBy1 :: (b->b->Bool) -> (a->b) -> [(b,[a])] -> [a] -> [(b,[a])] -collectBy1 cmp sel sofar [] = sofar -collectBy1 cmp sel sofar (a:as) = - collectBy1 cmp sel (collectBy2 cmp sel a sofar) as - -collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b,[a])] -> [(b,[a])] -collectBy2 cmp sel a [] = [(sel a,[a])] -collectBy2 cmp sel a (col@(k,as):cols) - | cmp ka k = (k,a:as):cols - | otherwise = col:collectBy2 cmp sel a cols - where - ka = sel a - -reverseCollection :: (b,[a]) -> (b,[a]) -reverseCollection (k,as) = (k,reverse as) - --- Example/test: -testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')] -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 cmp sel [] 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 cmp sel a [] = [] -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 = testCollectMore1 - == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)])) - , (2,([(2,'b'),(2,'d')],[(211,2)])) - , (3,([(3,'d')],[(311,3)])) - ] - --- |Remove supplied element from a list using the supplied test --- function, and return Just the element remoived and the --- remaining list, or Nothing if no element was matched for removal. --- -remove :: (Eq a) => a -> [a] -> Maybe (a,[a]) -remove = removeBy (==) - -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) - -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,[]) - --- |Reverse first argument, prepending the result to the second argument --- -reverseTo :: [a] -> [a] -> [a] -reverseTo [] back = back -reverseTo (a:front) back = reverseTo front (a:back) - --- |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 cmp [] 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 $ catMaybes $ map maybeResult comps - comps = [ (cmp a1 a2,a2t) | (a2,a2t) <- removeEach a2s ] - maybeResult (Nothing,_) = Nothing - maybeResult (Just ds,a2t) = Just (ds,a2t) - morediffs ds a1h a1t a2t = (ds++ds1,a1h++a1r,a2r) - where - (ds1,a1r,a2r) = listDifferences cmp a1t a2t - choose [] = Nothing - choose ds@(d:_) = choose1 d ds - choose1 _ (d@([],dr):_) = 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphPartition.hs,v $ --- $Author: graham $ --- $Revision: 1.3 $ --- $Log: GraphPartition.hs,v $ --- Revision 1.3 2004/02/11 14:19:36 graham --- Add graph-difference option to Swish --- --- Revision 1.2 2004/02/10 20:24:48 graham --- Graph difference code now works. --- --- 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. diff --git a/Swish/HaskellRDF/GraphPartitionTest.hs b/Swish/HaskellRDF/GraphPartitionTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphPartitionTest.hs +++ /dev/null @@ -1,527 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: GraphPartitionTest.hs,v 1.2 2004/02/10 20:24:48 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphPartitionTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for graph partitioning logic. --- --------------------------------------------------------------------------------- - ---module Swish.HaskellRDF.GraphPartitionTest where --- module Main(main) where -- WNH - - -import Swish.HaskellRDF.GraphPartition - ( PartitionedGraph(..), getArcs - , GraphPartition(..), node, toArcs - , partitionGraph, comparePartitions - ) - -import Swish.HaskellRDF.GraphClass - ( Label(..) - , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple - -- , hasLabel, arcLabels - ) - -import Swish.HaskellRDF.GraphMem - -- ( GraphMem(..) - -- , setArcs, getArcs, add, delete, extract, labels - ( LabelMem(..) - , labelIsVar, labelHash - ) - -import Swish.HaskellUtils.TestHelpers - ( test, testEq, - -- WNH FIX testNe, - testLe, testGe, testElem - , testJust, testNothing - , testEqv, - -- WNH FIXtestNotEqv, - testEqv2, testHasEqv, testMaybeEqv - ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , Assertion - , assertBool, assertEqual, assertString, assertFailure - , runTestTT, runTestText, putTextToHandle - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Control.Monad - ( unless ) - -import Data.List - ( sort, union, intersect ) - -import Data.Maybe - ( isJust, fromJust, fromMaybe ) - ------------------------------------------------------------- --- Basic GraphPartition tests ------------------------------------------------------------- - -gp1 = PartitionedGraph [ p11 ] -gp2 = PartitionedGraph [ p11, p12 ] -gp3 = PartitionedGraph [ p11, p13 ] -gp4 = PartitionedGraph [ p11, p14 ] -gp5 = PartitionedGraph [ p11, p12, p15 ] - -p11 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] -p12 = PartSub (LF "s2") [ (LF "p21",PartObj (LF "o21")) - , (LF "p22",PartObj (LF "o22")) - ] -p13 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p32",p12) - , (LF "p33",PartObj (LF "s3")) - ] -p14 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "s3")) - , (LF "p32",p12) - ] -p15 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p32",PartObj (LF "s2")) - , (LF "p33",PartObj (LF "s3")) - ] - -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 = testEq "testBasic01" gp1 gp1 -testBasic02 = testEq "testBasic02" gp2 gp2 -testBasic03 = testEq "testBasic03" gp3 gp3 -testBasic04 = testEq "testBasic04" gp4 gp4 -testBasic05 = testEq "testBasic05" gp5 gp5 -{- WNH FIX -testBasic06 = testNe "testBasic06" gp2 gp3 -testBasic07 = testNe "testBasic07" gp3 gp4 --} - -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 = 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 = 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) --- WNH FIX testBasic36 = testNotEqv "testBasic36" (getArcs gp2) (getArcs gp3) -testBasic37 = testEqv "testBasic37" (getArcs gp3) (getArcs gp4) -testBasic38 = testEqv "testBasic38" (getArcs gp3) (getArcs gp5) - -testBasicSuite = TestList - [ testBasic01 - , testBasic02 - , testBasic03 - , testBasic04 - , testBasic05 - -- WNH FIX, testBasic06 - -- WNH FIX, testBasic07 - , testBasic11 - , testBasic12 - , testBasic13 - , testBasic14 - , testBasic15 - , testBasic21 - , testBasic22 - , testBasic23 - , testBasic24 - , testBasic25 - , testBasic31 - , testBasic32 - , testBasic33 - , testBasic34 - , testBasic35 - -- WNH FIX, testBasic36 - , testBasic37 - , testBasic38 - ] - ------------------------------------------------------------- --- Creating GraphPartition tests ------------------------------------------------------------- - -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 = 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 = PartSub (LF "s1") [ (LF "p",PartObj (LF "o11")) ] -ps2f = PartSub (LF "s2") [ (LF "p1",PartObj (LF "o21")) - , (LF "p2",PartObj (LF "o22")) - ] -ps2r = PartSub (LF "s2") [ (LF "p2",PartObj (LF "o22")) - , (LF "p1",PartObj (LF "o21")) - ] -pb3f = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - ] -pb3r = PartSub (LV "b3") [ (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] - -pb3af = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",pb4af) - ] -pb3ar = PartSub (LV "b3") [ (LF "p",pb4ar) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] -pb4af = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - ] -pb4ar = PartSub (LV "b4") [ (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - ] -pb5a1 = PartSub (LV "b5a") [ (LF "p",pb5b1) ] -pb5b1 = PartSub (LV "b5b") [ (LF "p",pb5c1) ] -pb5c1 = PartSub (LV "b5c") [ (LF "p",PartObj (LV "b5a")) ] - -pb3bf = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",pb4bf) - ] -pb3br = PartSub (LV "b3") [ (LF "p",pb4br) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LF "o31")) - ] -pb4bf = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LV "b5b")) - ] -pb4br = PartSub (LV "b4") [ (LF "p",PartObj (LV "b5b")) - , (LF "p",PartObj (LV "b3")) - , (LF "p",PartObj (LF "s2")) - ] -pb5a2 = PartSub (LV "b5a") [ (LF "p",PartObj (LV "b5b")) ] -pb5b2 = PartSub (LV "b5b") [ (LF "p",pb5c2) ] -pb5c2 = PartSub (LV "b5c") [ (LF "p",pb5a2) ] - -pb5a3 = PartSub (LV "b5a") [ (LF "p",pb5b3) ] -pb5b3 = PartSub (LV "b5b") [ (LF "p",PartObj (LV "b5c")) ] -pb5c3 = PartSub (LV "b5c") [ (LF "p",pb5a3) ] - -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 = 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 = 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 = 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 = 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 $ PartSub (LV "b3") [(LF "p",pb4af)])] - (comparePartitions pp3f pp4f) -testPartition58 = testEqv "testPartition58" - [(Nothing,Just pb5a1)] - (comparePartitions pp4f pp5f) -testPartition59 = testEqv "testPartition59" - [(Nothing,Just $ PartSub (LV "b4") [(LF "p",PartObj (LV "b5b"))])] - (comparePartitions pp5f pp6f) - -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 = PartitionedGraph [ c11, c12a ] -pgc1b = PartitionedGraph [ c11, c12b ] - -c11 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] -c12a = PartSub (LF "s2") [ (LF "p21",c13a) - , (LF "p22",PartObj (LF "o22")) - ] -c12b = PartSub (LF "s2") [ (LF "p22",PartObj (LF "o22")) - , (LF "p21",c13b) - ] -c13a = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "o33a")) - ] -c13b = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) - , (LF "p33",PartObj (LF "o33b")) - ] -testCompare01 = testEqv "testCompare01" - [(Just (PartObj (LF "o33a")),Just (PartObj (LF "o33b")))] - (comparePartitions pgc1a pgc1b) - - -testCompareSuite = TestList - [ testCompare01 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testBasicSuite - , testPartitionSuite - , testCompareSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphPartitionTest.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: GraphPartitionTest.hs,v $ --- Revision 1.2 2004/02/10 20:24:48 graham --- Graph difference code now works. --- --- 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. diff --git a/Swish/HaskellRDF/GraphTest.hs b/Swish/HaskellRDF/GraphTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/GraphTest.hs +++ /dev/null @@ -1,1730 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: GraphTest.hs,v 1.24 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : GraphTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + multi-parameter classes --- --- This module defines test cases for module Graph. --- --------------------------------------------------------------------------------- - - --- WNH module Swish.HaskellRDF.GraphTest where - -import System.IO - ( Handle, IOMode(WriteMode), - openFile, hClose, hPutStr, hPutStrLn ) -import Test.HUnit - ( Test(TestCase,TestList,TestLabel), - assertEqual, runTestTT, runTestText, putTextToHandle ) -import Data.List( elemIndex ) -import Data.Maybe( fromJust ) - -import Swish.HaskellUtils.ListHelpers -import Swish.HaskellUtils.MiscHelpers -import Swish.HaskellRDF.GraphClass (Arc(..),Label(..),arcFromTriple,arcToTriple) -import Swish.HaskellRDF.GraphMem -import Swish.HaskellRDF.GraphMatch - ( graphMatch, - -- The rest exported for testing only - LabelMap(..), GenLabelMap(..), LabelEntry(..), GenLabelEntry(..), - ScopedLabel(..), makeScopedLabel, makeScopedArc, - LabelIndex, EquivalenceClass, nullLabelVal, emptyMap, - labelIsVar, labelHash, - mapLabelIndex, {-mapLabelList,-} setLabelHash, newLabelMap, - graphLabels, assignLabelMap, newGenerationMap, - graphMatch1, graphMatch2, equivalenceClasses, reclassify - ) -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..), makeLookupMap - , mapSortByKey, mapSortByVal - ) - -default ( Int ) - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -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 lists of triples ------------------------------------------------------------- - -setArcsT a = setArcs $ map arcFromTriple a -getArcsT g = map arcToTriple $ getArcs g - -toStatement s p o = Arc s p o - ------------------------------------------------------------- --- Test class helper ------------------------------------------------------------- - -testeq :: (Show a, Eq a) => String -> a -> a -> Test -testeq lab req got = - TestCase ( assertEqual ("test"++lab) req got ) - -testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test -testeqv lab req got = - TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) - ------------------------------------------------------------- --- Label map and entry creation helpers ------------------------------------------------------------- - -tstLabelMap :: (Label lb) => Int -> [(lb,LabelIndex)] -> LabelMap lb -tstLabelMap gen lvs = LabelMap gen (makeLookupMap $ makeEntries lvs) - -makeEntries :: (Label lb) => [(lb,LabelIndex)] -> [LabelEntry lb] -makeEntries lvs = map newEntry lvs - -labelMapSortByVal :: (Label lb) => LabelMap lb -> LabelMap lb -labelMapSortByVal (LabelMap gen lmap) = LabelMap gen (mapSortByVal lmap) - ------------------------------------------------------------- --- Graph helper function tests ------------------------------------------------------------- - --- select - -testSelect :: String -> [Char] -> [Char] -> Test -testSelect lab l1 l2 = testeq ("Select"++lab ) l1 l2 - -testSelect01 = testSelect "01" - (select (1==) [0,1,2,0,1,2] ['a','b','c','a','b','c']) - ['b','b'] -testSelect02 = testSelect "02" - (select (1==) [1,1,1,1,1,1] ['a','b','c','a','b','c']) - ['a','b','c','a','b','c'] -testSelect03 = testSelect "03" - (select (1==) [0,0,0,0,0,0] ['a','b','c','a','b','c']) - [] -testSelect04 = testSelect "04" - (select (1==) [] [] ) - [] - -testSelectSuite = TestList - [ - testSelect01, testSelect02, testSelect03, testSelect04 - ] - --- mapset - -mf :: Int -> Char -mf n = "_abcde" !! n - -testMapset :: String -> [Int] -> [Char] -> Test -testMapset lab l1 l2 = testeq ("Mapset"++lab ) l2 (mapset mf l1) - -testMapset01 = testMapset "01" [0,1,2,3,4,5] ['_','a','b','c','d','e'] -testMapset02 = testMapset "02" [1,1,3,3,5,5] ['a','c','e'] -testMapset03 = testMapset "03" [5,4,3,2,1,0] ['e','d','c','b','a','_'] -testMapset04 = testMapset "04" [] [] -testMapset05 = testMapset "05" [1,2,3,4,5,0] ['a','b','c','d','e','_'] - -testMapsetSuite = TestList - [ - testMapset01, testMapset02, testMapset03, testMapset04, - testMapset05 - ] - --- subset - -testSubset :: String -> Bool -> [Int] -> [Int] -> Test -testSubset lab res l1 l2 = testeq ("Mapset"++lab ) res (l1 `subset` l2) - -testSubset01 = testSubset "01" True [1,2,3] [0,1,2,3,4,5] -testSubset02 = testSubset "02" True [5,3,1] [0,1,2,3,4,5] -testSubset03 = testSubset "03" True [5,4,3,2,1,0] [0,1,2,3,4,5] -testSubset04 = testSubset "04" True [] [] -testSubset05 = testSubset "05" False [0,1,2,3,4,5] [1,2,3] -testSubset06 = testSubset "06" False [0,1,2,3,4,5] [5,3,1] -testSubset07 = testSubset "07" True [] [1,2,3] -testSubset08 = testSubset "08" False [1,2,3] [] - -testSubsetSuite = TestList - [ - testSubset01, testSubset02, testSubset03, testSubset04, - testSubset05, testSubset06, testSubset07, testSubset08 - ] - --- hash - -testHash :: String -> Bool -> Int -> Int -> Test -testHash lab eq h1 h2 = testeq ("Hash"++lab ) eq (h1 == h2) -testHashEq lab h1 h2 = testeq ("Hash"++lab ) h1 h2 - -testHash01 = testHash "01" True (hash 0 base1) (hash 0 base1) -testHash02 = testHash "02" True (hash 2 "") (hash 2 "") -testHash03 = testHash "03" False (hash 3 base1) (hash 3 base2) -testHash04 = testHash "04" False (hash 4 base1) (hash 5 base1) -testHash05 = testHash "05" False (hash 2 "") (hash 3 "") -testHash06 = testHashEq "06" 1424775 (hash 3 base1) -testHash07 = testHashEq "07" 11801303 (hash 3 base2) - -testHashSuite = TestList - [ - testHash01, testHash02, testHash03, testHash04, - testHash05, testHash06, testHash07 - ] - ------------------------------------------------------------- --- Simple graph label tests ------------------------------------------------------------- - -testLab01 = testeq "Lab01" False (labelIsVar lab1f) -testLab02 = testeq "Lab02" True (labelIsVar lab1v) -testLab03 = testeq "Lab03" False (labelIsVar lab2f) -testLab04 = testeq "Lab04" True (labelIsVar lab2v) - -testLab05 = testeq "Lab05" 3436883 (labelHash 1 lab1f) -testLab06 = testeq "Lab06" 10955600 (labelHash 1 lab1v) -testLab07 = testeq "Lab07" 3436884 (labelHash 1 lab2f) -testLab08 = testeq "Lab08" 10955601 (labelHash 1 lab2v) - -testLab09 = testeq "Lab09" "!lab1" (show lab1f) -testLab10 = testeq "Lab10" "?lab1" (show lab1v) -testLab11 = testeq "Lab11" "!lab2" (show lab2f) -testLab12 = testeq "Lab12" "?lab2" (show lab2v) - -testLab13 = testeq "Lab13" "lab1" (getLocal lab1v) -testLab14 = testeq "Lab14" "lab2" (getLocal lab2v) -testLab15 = testeq "Lab15" lab1v (makeLabel "lab1") -testLab16 = testeq "Lab16" lab2v (makeLabel "lab2") - -testLabSuite = TestList - [ - testLab01, testLab02, testLab03, testLab04, - testLab05, testLab06, testLab07, testLab08, - testLab09, testLab10, testLab11, testLab12, - testLab13, testLab14, testLab15, testLab16 - ] - ------------------------------------------------------------- --- Simple graph tests ------------------------------------------------------------- - -lab1f = LF "lab1" -lab1v = LV "lab1" -lab2f = LF "lab2" -lab2v = LV "lab2" - -gr1 = GraphMem { arcs=[]::[Arc LabelMem] } -ga1 = - [ - (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 (Arc _ _ (LV "lab2")) = True -gs4 (Arc _ _ _ ) = False -ga4 = - [ - (lab2v,lab2v,lab2v), - (lab1f,lab1f,lab2v), - (lab1v,lab1v,lab2v), - (lab1f,lab1v,lab2v), - (lab1v,lab2f,lab2v) - ] - -gr2 = GraphMem { arcs=[]::[Arc LabelMem] } -ga2 = - [ - (lab1f,lab1f,lab1f), - (lab1v,lab1v,lab1v), - (lab2f,lab2f,lab2f), - (lab2v,lab2v,lab2v) - ] - -gr3 = GraphMem { arcs=[]::[Arc LabelMem] } -ga3 = - [ - (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 = [lab1f,lab1v,lab2f,lab2v] - - -gr1a = setArcsT ga1 gr1 -testGraph01 = testeq "Graph01" ga1 (getArcsT gr1a) - -gr2a = setArcsT ga2 gr2 -testGraph02 = testeq "Graph01" ga2 (getArcsT gr2a) - -gr3a = setArcsT ga3 gr3 -testGraph03 = testeq "Graph03" ga3 (getArcsT gr3a) - -gr4a = add gr2a gr3a -testGraph04 = testeqv "Graph04" ga1 (getArcsT gr4a) - -gr4b = add gr3a gr2a -testGraph05 = testeqv "Graph05" ga1 (getArcsT gr4b) - -gr4c = delete gr2a gr4a -testGraph06 = testeqv "Graph06" ga3 (getArcsT gr4c) - -gr4d = delete gr3a gr4a -testGraph07 = testeqv "Graph07" ga2 (getArcsT gr4d) - -gr4e = extract gs4 gr4a -testGraph08 = testeqv "Graph08" ga4 (getArcsT gr4e) -gr4ee = map gs4 (getArcs gr4a) - -gl4f = labels gr4a -testGraph09 = testeqv "Graph09" gl4 gl4f - -gr4g = add gr2a gr4a -testGraph10 = testeq "Graph10" ga1 (getArcsT gr4g) - -testGraphSuite = TestList - [ - testGraph01, testGraph02, testGraph03, testGraph04, - testGraph05, testGraph06, testGraph07, testGraph08, - testGraph09, testGraph10 - ] - ------------------------------------------------------------- --- ------------------------------------------------------------- - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -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 = LV "b1" -b2 = LV "b2" -b3 = LV "b3" -b4 = LV "b4" - -p1 = LF "p1" -p2 = LF "p2" -p3 = LF "p3" -p4 = LF "p4" - -o1 = LF "o1" -o2 = LF "o2" -o3 = LF "o3" -o4 = LF "" -o5 = LV "o5" -o6 = LV "s5" - -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 = 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 = - [ ("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 = - [ - ("s4","o4"), - ("s5","o6"), - ("s6","s7"), - ("l4","l5"), - ("l4","l6"), - ("l5","l6"), - ("l7","l8"), - ("l7","l9"), - ("l8","l9") - ] - -testLabelEqSuite = TestList - [ testLabelEq (testLab l1 l2) (testEq l1 l2) n1 n2 - | (l1,n1) <- nodelist , (l2,n2) <- nodelist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` nodeeqlist || - (l2,l1) `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 = - [ - "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 = TestList - [ testLabelOrd (testLab l1 l2) (testOrd l1 l2) n1 n2 - | (l1,n1) <- nodelist , (l2,n2) <- nodelist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testOrd l1 l2 - | testEq l1 l2 = EQ - | otherwise = compare (fromJust $ elemIndex l1 nodeorder) - (fromJust $ elemIndex l2 nodeorder) - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` nodeeqlist || - (l2,l1) `elem` nodeeqlist - - ------------------------------------------------------------- --- Statement construction and equality tests ------------------------------------------------------------- - -type Statement = Arc LabelMem - -testStmtEq :: String -> Bool -> Statement -> Statement -> Test -testStmtEq lab eq t1 t2 = - TestCase ( assertEqual ("testStmtEq:"++lab) eq (t1==t2) ) - -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 = - [ (lab s p o,trp s p o) | s <- slist, p <- plist, o <- olist ] - where - lab (s,_) (p,_) (o,_) = s++"."++p++"."++o - trp (_,s) (_,p) (_,o) = Arc s p o - -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 = TestList - [ testStmtEq (testLab l1 l2) (testEq l1 l2) t1 t2 - | (l1,t1) <- tlist , (l2,t2) <- tlist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` stmteqlist || - (l2,l1) `elem` stmteqlist - ------------------------------------------------------------- --- Graph element handling support routines ------------------------------------------------------------- - -lmap = tstLabelMap 5 [(s1,(1,1)),(s2,(2,2)),(s3,(3,3)),(s4,(4,4)), - (o1,(1,1)),(o2,(2,2)),(o3,(3,3))] -llst = ["s1","s2","s3","s4","o1","o2","o3"] - --- showLabelMap :: (Label lb) => LabelMap lb -> String -testShowLabelMap = testeq "showLabelMap" showMap (show lmap) - where - showMap = "LabelMap gen=5, map=\n"++ - " !s1:(1,1)\n"++ - " !s2:(2,2)\n"++ - " !s3:(3,3)\n"++ - " !:(4,4)\n"++ - " !o1:(1,1)\n"++ - " !o2:(2,2)\n"++ - " !o3:(3,3)" - --- mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex -testMapLabelIndex01 = testeq "testMapLabelIndex01" (1,1) (mapLabelIndex lmap s1 ) -testMapLabelIndex02 = testeq "testMapLabelIndex02" (2,2) (mapLabelIndex lmap s2 ) -testMapLabelIndex03 = testeq "testMapLabelIndex03" (3,3) (mapLabelIndex lmap s3 ) -testMapLabelIndex04 = testeq "testMapLabelIndex04" (4,4) (mapLabelIndex lmap s4 ) -testMapLabelIndex05 = testeq "testMapLabelIndex05" (1,1) (mapLabelIndex lmap o1 ) -testMapLabelIndex06 = testeq "testMapLabelIndex06" (4,4) (mapLabelIndex lmap o4 ) -testMapLabelIndex07 = testeq "testMapLabelIndex07" nullLabelVal (mapLabelIndex lmap o5 ) -testMapLabelIndex08 = testeq "testMapLabelIndex08" nullLabelVal (mapLabelIndex lmap o6 ) - --- setLabelHash :: (Label lb) => LabelMap lb -> (lb,Int) -> LabelMap lb -lmap1 = setLabelHash lmap (s2,22) - -testMapLabelHash00 = testeq "mapLabelHash00" showMap (show lmap1) - where - showMap = "LabelMap gen=5, map=\n"++ - " !s1:(1,1)\n"++ - " !s2:(5,22)\n"++ - " !s3:(3,3)\n"++ - " !:(4,4)\n"++ - " !o1:(1,1)\n"++ - " !o2:(2,2)\n"++ - " !o3:(3,3)" - -testMapLabelHash01 = testeq "MapLabelHash01" (1,1) (mapLabelIndex lmap1 s1 ) -testMapLabelHash02 = testeq "MapLabelHash02" (5,22) (mapLabelIndex lmap1 s2 ) -testMapLabelHash03 = testeq "MapLabelHash03" (3,3) (mapLabelIndex lmap1 s3 ) -testMapLabelHash04 = testeq "MapLabelHash04" (4,4) (mapLabelIndex lmap1 s4 ) -testMapLabelHash05 = testeq "MapLabelHash05" (1,1) (mapLabelIndex lmap1 o1 ) -testMapLabelHash06 = testeq "MapLabelHash06" (4,4) (mapLabelIndex lmap1 o4 ) -testMapLabelHash07 = testeq "MapLabelHash07" nullLabelVal (mapLabelIndex lmap1 o5 ) -testMapLabelHash08 = testeq "MapLabelHash08" nullLabelVal (mapLabelIndex lmap1 o6 ) - -lmap2a = setLabelHash lmap1 (o1,66) -lmap2b = setLabelHash lmap2a (o5,67) -testMapLabelHash11 = testeq "MapLabelHash11" (1,1) (mapLabelIndex lmap2b s1 ) -testMapLabelHash12 = testeq "MapLabelHash12" (5,22) (mapLabelIndex lmap2b s2 ) -testMapLabelHash13 = testeq "MapLabelHash13" (3,3) (mapLabelIndex lmap2b s3 ) -testMapLabelHash14 = testeq "MapLabelHash14" (4,4) (mapLabelIndex lmap2b s4 ) -testMapLabelHash15 = testeq "MapLabelHash15" (5,66) (mapLabelIndex lmap2b o1 ) -testMapLabelHash16 = testeq "MapLabelHash16" (2,2) (mapLabelIndex lmap2b o2 ) -testMapLabelHash17 = testeq "MapLabelHash17" (4,4) (mapLabelIndex lmap2b o4 ) -testMapLabelHash18 = testeq "MapLabelHash18" nullLabelVal (mapLabelIndex lmap1 o5 ) - --- newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb -lmap3 = newLabelMap lmap [(s1,61),(s3,63),(o2,66)] -testLabelMap01 = testeq "LabelMap01" (6,61) (mapLabelIndex lmap3 s1 ) -testLabelMap02 = testeq "LabelMap02" (2,2) (mapLabelIndex lmap3 s2 ) -testLabelMap03 = testeq "LabelMap03" (6,63) (mapLabelIndex lmap3 s3 ) -testLabelMap04 = testeq "LabelMap04" (4,4) (mapLabelIndex lmap3 s4 ) -testLabelMap05 = testeq "LabelMap05" (1,1) (mapLabelIndex lmap3 o1 ) -testLabelMap06 = testeq "LabelMap06" (6,66) (mapLabelIndex lmap3 o2 ) - -testLabelMapSuite = TestList - [ testShowLabelMap - , testMapLabelIndex01 - , testMapLabelIndex02 - , testMapLabelIndex03 - , testMapLabelIndex04 - , testMapLabelIndex05 - , testMapLabelIndex06 - , testMapLabelIndex07 - , testMapLabelIndex08 - , testMapLabelHash00 - , testMapLabelHash01 - , testMapLabelHash02 - , testMapLabelHash03 - , testMapLabelHash04 - , testMapLabelHash05 - , testMapLabelHash06 - , testMapLabelHash07 - , testMapLabelHash08 - , testMapLabelHash11 - , testMapLabelHash12 - , testMapLabelHash13 - , testMapLabelHash14 - , testMapLabelHash15 - , testMapLabelHash16 - , testMapLabelHash17 - , testMapLabelHash18 - , testLabelMap01 - , testLabelMap02 - , testLabelMap03 - , testLabelMap04 - , testLabelMap05 - ] - ------------------------------------------------------------- --- Graph matching support ------------------------------------------------------------- - -t01 = toStatement s1 p1 o1 -t02 = toStatement s2 p1 o2 -t03 = toStatement s3 p1 o3 -t04 = toStatement s1 p1 l1 -t05 = toStatement s2 p1 l4 -t06 = toStatement s3 p1 l10 - -t10 = toStatement s1 p1 b1 -t11 = toStatement b1 p2 b2 -t12 = toStatement b2 p3 o1 - -t20 = toStatement s1 p1 b3 -t21 = toStatement b3 p2 b4 -t22 = toStatement b4 p3 o1 - -as1 = [t01] - -as2 = [t01,t02,t03,t04,t05,t06] - -as4 = [t01,t02,t03,t04,t05,t06,t10,t11,t12] - -as5 = [t01,t02,t03,t04,t05,t06,t20,t21,t22] - -as6 = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] - - --- graphLabels :: (Label lb) => [Arc lb] -> [lb] -ls4 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2] -testGraphLabels04 = testeqv "GraphLabels04" ls4 (graphLabels as4) -testGraphLabels14 = testeq "GraphLabels14" str (show (graphLabels as4)) - where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3]" - -- str = "[!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" - -ls5 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b3,b4] -testGraphLabels05 = testeqv "GraphLabels05" ls5 (graphLabels as5) -testGraphLabels15 = testeq "GraphLabels15" str (show (graphLabels as5)) - where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b3,!p2,?b4,!p3]" - -- str = "[!p3,?b4,!p2,?b3,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" - -ls6 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2,b3,b4] -testGraphLabels06 = testeqv "GraphLabels05" ls6 (graphLabels as6) -testGraphLabels16 = testeq "GraphLabels16" str (show (graphLabels as6)) - where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3"++ - ",!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3,?b3,?b4]" - -- str = "[?b4,?b3,!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1"++ - -- ",!o3,!s3,!o2,!s2,!o1,!p1,!s1]" - --- assignLabels :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb - -lmap5 = tstLabelMap 2 [(s1,(1,142577)),(s2,(1,142578)),(s3,(1,142579)), - (p1,(1,142385)),(p2,(1,142386)),(p3,(1,142387)), - (o1,(1,142321)),(o2,(1,142322)),(o3,(1,142323)), - (l1,(1,142129)),(l4,(1,1709580)),(l10,(1,3766582)), - (b3,(1,262143)),(b4,(1,262143))] -testAssignLabelMap05 = testeq "AssignLabels05" lmap5 - (newGenerationMap $ assignLabelMap ls5 emptyMap) - -lmap6 = tstLabelMap 2 [(s1,(1,142577)),(s2,(1,142578)),(s3,(1,142579)), - (p1,(1,142385)),(p2,(1,142386)),(p3,(1,142387)), - (o1,(1,142321)),(o2,(1,142322)),(o3,(1,142323)), - (l1,(1,142129)),(l4,(1,1709580)),(l10,(1,3766582)), - (b1,(2,262143)),(b2,(2,262143)),(b3,(1,262143)),(b4,(1,262143))] -testAssignLabelMap06 = testeq "AssignLabels06" lmap6 (assignLabelMap ls6 lmap5) - - -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 = TestList - [ testGraphLabels04 - , testGraphLabels14 - , testGraphLabels05 - , testGraphLabels15 - , testGraphLabels06 - , testGraphLabels16 - , testAssignLabelMap05 - , testAssignLabelMap06 - ] - ------------------------------------------------------------- --- Test steps in graph equality test ------------------------------------------------------------- - -matchable l1 l2 = True - -s1_1 = makeScopedLabel 1 s1 -s2_1 = makeScopedLabel 1 s2 -s3_1 = makeScopedLabel 1 s3 -p1_1 = makeScopedLabel 1 p1 -p2_1 = makeScopedLabel 1 p2 -p3_1 = makeScopedLabel 1 p3 -o1_1 = makeScopedLabel 1 o1 -o2_1 = makeScopedLabel 1 o2 -o3_1 = makeScopedLabel 1 o3 -l1_1 = makeScopedLabel 1 l1 -l4_1 = makeScopedLabel 1 l4 -l10_1 = makeScopedLabel 1 l10 -b1_1 = makeScopedLabel 1 b1 -b2_1 = makeScopedLabel 1 b2 -b3_1 = makeScopedLabel 1 b3 -b4_1 = makeScopedLabel 1 b4 - -s1_2 = makeScopedLabel 2 s1 -s2_2 = makeScopedLabel 2 s2 -s3_2 = makeScopedLabel 2 s3 -p1_2 = makeScopedLabel 2 p1 -p2_2 = makeScopedLabel 2 p2 -p3_2 = makeScopedLabel 2 p3 -o1_2 = makeScopedLabel 2 o1 -o2_2 = makeScopedLabel 2 o2 -o3_2 = makeScopedLabel 2 o3 -l1_2 = makeScopedLabel 2 l1 -l4_2 = makeScopedLabel 2 l4 -l10_2 = makeScopedLabel 2 l10 -b1_2 = makeScopedLabel 2 b1 -b2_2 = makeScopedLabel 2 b2 -b3_2 = makeScopedLabel 2 b3 -b4_2 = makeScopedLabel 2 b4 - -t01_1 = makeScopedArc 1 t01 - -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 = 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 = 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 = map (makeScopedArc 1) as6 -as62 = map (makeScopedArc 2) as6 - -eq1lmap = newGenerationMap $ - assignLabelMap (graphLabels as62) $ - assignLabelMap (graphLabels as61) emptyMap -eq1ltst = 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,(1,262143)),(b2_1,(1,262143)),(b3_1,(1,262143)),(b4_1,(1,262143)), - (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,(1,262143)),(b2_2,(1,262143)),(b3_2,(1,262143)),(b4_2,(1,262143)) - ] -testEqAssignMap01 = testeq "EqAssignMap01" eq1ltst eq1lmap - -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' = 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'' = newLabelMap eq1lmap' - [ - (b1_1,2576315),(b2_1,3400925),(b3_1,1571691), - (b1_2,2576315),(b2_2,3400925),(b3_2,1571691) - ] -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 = testeq "EqNewLabelMap07" eq1ltst'' eq1lmap'' - --- Repeat same tests for as4... - -as41 = map (makeScopedArc 1) as4 -as42 = map (makeScopedArc 2) as4 - -eq2lmap = newGenerationMap $ - assignLabelMap (graphLabels as42) $ - assignLabelMap (graphLabels as41) emptyMap -eq2ltst = 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,(1,262143)),(b2_1,(1,262143)), - (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,(1,262143)),(b2_2,(1,262143))] -testEqAssignMap21 = testeq "EqAssignMap21" eq2ltst eq2lmap - -eq2hs1 = [t10_1,t11_1,t12_1] -eq2hs2 = [t10_2,t11_2,t12_2] - -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'' = newLabelMap eq2lmap' - [ - (b2_1,3400925), - (b2_2,3400925) - ] -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 = testeq "EqNewLabelMap27" eq2ltst'' eq2lmap'' - --- Compare as1 with as2, in steps - -as11 = map (makeScopedArc 1) as1 -as22 = map (makeScopedArc 2) as2 - -eq3hs1 = [t01_1] -eq3hs2 = [t01_2,t02_2,t03_2,t04_2,t05_2,t06_2] - -testEqGraphMap31_1 = testeq "testEqGraphMap31_1" eq3hs1 as11 -testEqGraphMap31_2 = testeq "testEqGraphMap31_2" eq3hs2 as22 - -eq3lmap = newGenerationMap $ - assignLabelMap (graphLabels as11) $ - assignLabelMap (graphLabels as22) emptyMap -eq3ltst = tstLabelMap 2 - [ (s1_1,(1,142577)) - , (p1_1,(1,142385)) - , (o1_1,(1,142321)) - , (s1_2,(1,142577)), (s2_2,(1,142578)), (s3_2,(1,142579)) - , (p1_2,(1,142385)) - , (o1_2,(1,142321)), (o2_2,(1,142322)), (o3_2,(1,142323)) - , (l1_2,(1,142129)), (l4_2,(1,1709580)), (l10_2,(1,3766582)) - ] -testEqAssignMap32 = testeq "EqAssignMap32" eq3ltst eq3lmap - -ec31 = equivalenceClasses eq3lmap (graphLabels as11) -ec31test = - [ ((1,142321),[o1_1]) - , ((1,142385),[p1_1]) - , ((1,142577),[s1_1]) - ] - -ec32 = equivalenceClasses eq3lmap (graphLabels as22) -ec32test = - [ ((1,142129),[l1_2]) - , ((1,142321),[o1_2]) - , ((1,142322),[o2_2]) - , ((1,142323),[o3_2]) - , ((1,142385),[p1_2]) - , ((1,142577),[s1_2]) - , ((1,142578),[s2_2]) - , ((1,142579),[s3_2]) - , ((1,1709580),[l4_2]) - , ((1,3766582),[l10_2]) - ] - -testEquivClass33_1 = testeq "EquivClass33_1" ec31test ec31 -testEquivClass33_2 = testeq "EquivClass33_2" ec32test ec32 - --- This value is nonsense for this test, --- but a parameter is needed for graphMatch1 (below) -ec3pairs = zip (pairSort ec31) (pairSort ec32) -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]) ) - ] - -{- This is a pointless test in this case -testEquivClass33_3 = testeq "EquivClass33_3" ec3test ec3pairs --} - -eq3lmap1 = graphMatch1 False matchable eq3hs1 eq3hs2 eq3lmap ec3pairs -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 -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 = 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 - -- , testEqReclassify35_1, testEqReclassify35_2 - ] - ------------------------------------------------------------- --- Graph equality tests ------------------------------------------------------------- - -testGraphEq :: ( Label lb ) => String -> Bool -> GraphMem lb -> GraphMem lb -> Test -testGraphEq lab eq g1 g2 = - TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - -g1 = GraphMem { arcs = [t01] } - -g2 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06] } - -g3 = GraphMem { arcs = [t06,t05,t04,t03,t02,t01] } - -g4 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12] } - -g5 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t20,t21,t22] } - -g6 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] } - -g7 = GraphMem { arcs = [t01,t02] } - -g8 = GraphMem { arcs = [t02,t01] } - -glist = - [ ("g1",g1), ("g2",g2), ("g3",g3), ("g4",g4), ("g5",g5), ("g6",g6) ] - -grapheqlist = - [ ("g2","g3") - , ("g4","g5") - ] - -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 = TestLabel "testGraphEqSuite" $ TestList - [ testGraphEq (testLab l1 l2) (testEq l1 l2) g1 g2 - | (l1,g1) <- glist , (l2,g2) <- glist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` grapheqlist || - (l2,l1) `elem` grapheqlist - --- Selected tests for debugging -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 = 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 = 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 = toStatement v101 p101 v102 -t10203 = toStatement v102 p102 v103 -t10304 = toStatement v103 p103 v104 -t10405 = toStatement v104 p104 v105 -t10501 = toStatement v105 p105 v101 -t10106 = toStatement v101 p106 v106 -t10207 = toStatement v102 p107 v107 -t10308 = toStatement v103 p108 v108 -t10409 = toStatement v104 p109 v109 -t10510 = toStatement v105 p110 v110 -t10607 = toStatement v106 p111 v107 -t10708 = toStatement v107 p112 v108 -t10809 = toStatement v108 p113 v109 -t10910 = toStatement v109 p114 v110 -t11006 = toStatement v110 p115 v106 - --- Graph pattern 2: --- pentangle-in-pentangle, corresponding vertices linked downward - -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 = 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 = toStatement v201 p201 v202 -t20203 = toStatement v202 p202 v203 -t20304 = toStatement v203 p203 v204 -t20405 = toStatement v204 p204 v205 -t20501 = toStatement v205 p205 v201 -t20601 = toStatement v206 p206 v201 -t20702 = toStatement v207 p207 v202 -t20803 = toStatement v208 p208 v203 -t20904 = toStatement v209 p209 v204 -t21005 = toStatement v210 p210 v205 -t20607 = toStatement v206 p211 v207 -t20708 = toStatement v207 p212 v208 -t20809 = toStatement v208 p213 v209 -t20910 = toStatement v209 p214 v210 -t21006 = toStatement 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 = 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 = 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 = toStatement v301 p301 v302 -t30203 = toStatement v302 p302 v303 -t30304 = toStatement v303 p303 v304 -t30405 = toStatement v304 p304 v305 -t30501 = toStatement v305 p305 v301 -t30106 = toStatement v301 p306 v306 -t30207 = toStatement v302 p307 v307 -t30308 = toStatement v303 p308 v308 -t30409 = toStatement v304 p309 v309 -t30510 = toStatement v305 p310 v310 -t30608 = toStatement v306 p311 v308 -t30709 = toStatement v307 p312 v309 -t30810 = toStatement v308 p313 v310 -t30906 = toStatement v309 p314 v306 -t31007 = toStatement 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 = 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 = 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 = toStatement v401 p401 v402 -t40203 = toStatement v402 p402 v403 -t40304 = toStatement v403 p403 v404 -t40405 = toStatement v404 p404 v405 -t40501 = toStatement v405 p405 v401 -t40106 = toStatement v401 p406 v406 -t40207 = toStatement v402 p407 v407 -t40308 = toStatement v403 p408 v408 -t40409 = toStatement v404 p409 v409 -t40510 = toStatement v405 p410 v410 -t41009 = toStatement v410 p411 v409 -t40908 = toStatement v409 p412 v408 -t40807 = toStatement v408 p413 v407 -t40706 = toStatement v407 p414 v406 -t40610 = toStatement v406 p415 v410 - --- Graph pattern 5: --- Same as pattern 1, except same fixed property in all cases. - -p5 = LF "p5" - -t50102 = toStatement v101 p5 v102 -t50203 = toStatement v102 p5 v103 -t50304 = toStatement v103 p5 v104 -t50405 = toStatement v104 p5 v105 -t50501 = toStatement v105 p5 v101 -t50106 = toStatement v101 p5 v106 -t50207 = toStatement v102 p5 v107 -t50308 = toStatement v103 p5 v108 -t50409 = toStatement v104 p5 v109 -t50510 = toStatement v105 p5 v110 -t50607 = toStatement v106 p5 v107 -t50708 = toStatement v107 p5 v108 -t50809 = toStatement v108 p5 v109 -t50910 = toStatement v109 p5 v110 -t51006 = toStatement v110 p5 v106 - --- Graph pattern 6: --- Same as pattern 5, with different variables - -t60102 = toStatement v201 p5 v202 -t60203 = toStatement v202 p5 v203 -t60304 = toStatement v203 p5 v204 -t60405 = toStatement v204 p5 v205 -t60501 = toStatement v205 p5 v201 -t60106 = toStatement v201 p5 v206 -t60207 = toStatement v202 p5 v207 -t60308 = toStatement v203 p5 v208 -t60409 = toStatement v204 p5 v209 -t60510 = toStatement v205 p5 v210 -t60607 = toStatement v206 p5 v207 -t60708 = toStatement v207 p5 v208 -t60809 = toStatement v208 p5 v209 -t60910 = toStatement v209 p5 v210 -t61006 = toStatement v210 p5 v206 - --- - -arcsToGraph as = GraphMem { arcs = as } - --- Very simple case - -g100 = arcsToGraph - [ t10102, t10203, t10304, t10405, t10501, - t10607, t10708, t10809, t10910, t11006 - ] - -g200 = arcsToGraph - [ t20102, t20203, t20304, t20405, t20501, - t20607, t20708, t20809, t20910, t21006 - ] - --- 10/3 node graph comparisons - -g101 = arcsToGraph - [ t10102, t10203, t10304, t10405, t10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g201 = arcsToGraph - [ t20102, t20203, t20304, t20405, t20501, - t20601, t20702, t20803, t20904, t21005, - t20607, t20708, t20809, t20910, t21006 ] - -g301 = arcsToGraph - [ t30102, t30203, t30304, t30405, t30501, - t30106, t30207, t30308, t30409, t30510, - t30608, t30709, t30810, t30906, t31007 ] - -g401 = arcsToGraph - [ t40102, t40203, t40304, t40405, t40501, - t40106, t40207, t40308, t40409, t40510, - t40610, t40706, t40807, t40908, t41009 ] - -g501 = arcsToGraph - [ t50102, t50203, t50304, t50405, t50501, - t50106, t50207, t50308, t50409, t50510, - t50607, t50708, t50809, t50910, t51006 ] - -g601 = arcsToGraph - [ t60102, t60203, t60304, t60405, t60501, - t60106, t60207, t60308, t60409, t60510, - t60607, t60708, t60809, t60910, t61006 ] - --- Remove one arc from each - -g102 = arcsToGraph - [ t10102, t10203, t10304, t10405, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g202 = arcsToGraph - [ t20102, t20203, t20304, t20405, t20501, - t20601, t20702, t20803, t20904, t21005, - t20708, t20809, t20910, t21006 ] - -g302 = arcsToGraph - [ t20102, t20203, t20304, t20405, t20501, - t20601, t20702, t20803, t20904, - t20607, t20708, t20809, t20910, t21006 ] - --- Remove two adjacent arcs from each - -g103 = arcsToGraph - [ t10102, t10203, t10304, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g203 = arcsToGraph - [ t20102, t20203, t20304, t20405, t20501, - t20601, t20702, t20803, t20904, t21005, - t20607, t20708, t21006 ] - -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 = arcsToGraph - [ t10102, t10203, t10304, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -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 = toStatement v109 p109 v101 - -g105 = arcsToGraph - [ t10102, t10203, t10304, t10405, - t10901, t10510, - t10607, t10708, t10809, t11006 ] - -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 = toStatement v202 p201 v201 - -g106 = arcsToGraph - [ t10102, t10203, t10304, t10405, t10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g206 = arcsToGraph - [ t20607, t20708, t20809, t20910, t21006, - t20601, t20702, t20803, t20904, t21005, - t20102, t20203, t20304, t20405, t20501 ] - -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 = LF "f01" -f02 = LF "f02" - --- Fix one arc from each - -f10102 = toStatement v101 f01 v102 -f10501 = toStatement v105 f01 v101 -f21006 = toStatement v210 f01 v206 -f20510 = toStatement v205 f01 v210 - -g107 = arcsToGraph - [ f10102, t10203, t10304, t10405, t10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g207 = arcsToGraph - [ t10102, t10203, t10304, t10405, f10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g307 = arcsToGraph - [ t20607, t20708, t20809, t20910, f21006, - t20601, t20702, t20803, t20904, t21005, - t20102, t20203, t20304, t20405, t20501 ] - -g407 = arcsToGraph - [ t20607, t20708, t20809, t20910, t21006, - t20601, t20702, t20803, t20904, t21005, - t20102, t20203, t20304, t20405, t20501 ] - --- Fix two adjacent arcs from each - -f10203 = toStatement v102 f01 v103 -f10405 = toStatement v104 f01 v105 -f20910 = toStatement v209 f01 v210 -f20601 = toStatement v206 f01 v201 - -g108 = arcsToGraph - [ f10102, f10203, t10304, t10405, t10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g208 = arcsToGraph - [ t10102, t10203, t10304, f10405, f10501, - t10106, t10207, t10308, t10409, t10510, - t10607, t10708, t10809, t10910, t11006 ] - -g308 = arcsToGraph - [ t20607, t20708, t20809, f20910, f21006, - t20601, t20702, t20803, t20904, t21005, - t20102, t20203, t20304, t20405, t20501 ] - -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 = toStatement v102 f02 v103 -g10102 = toStatement v101 f02 v102 -g10405 = toStatement v104 f02 v105 - -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 = testGraphEq "g100-g200" True g100 g200 - -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 = testGraphEq "g102-g202" True g102 g202 -mgeq0213 = testGraphEq "g102-g302" False g102 g302 - -mgeq0312 = testGraphEq "g103-g203" True g103 g203 -mgeq0313 = testGraphEq "g103-g303" False g103 g303 - -mgeq04 = testGraphEq "g104-g204" False g104 g204 -mgeq05 = testGraphEq "g105-g205" False g105 g205 - -mgeq0612 = testGraphEq "g106-g206" True g106 g206 -mgeq0613 = testGraphEq "g106-g306" False g106 g306 - -mgeq0712 = testGraphEq "g107-g207" True g107 g207 -mgeq0713 = testGraphEq "g107-g307" True g107 g307 -mgeq0714 = testGraphEq "g107-g407" False g107 g407 - -mgeq0812 = testGraphEq "g108-g208" True g108 g208 -mgeq0813 = testGraphEq "g108-g308" True g108 g308 -mgeq0814 = testGraphEq "g108-g408" False g108 g408 - -mgeq0912 = testGraphEq "g109-g209" True g109 g209 -mgeq0913 = testGraphEq "g109-g309" False g109 g309 - -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 = TestList - [ testSelectSuite - , testMapsetSuite - , testSubsetSuite - , testHashSuite - , testLabSuite - , testGraphSuite - , testLabelEqSuite - , testLabelOrdSuite - , testStmtEqSuite - , testLabelMapSuite - , testGraphMatchSupportSuite - , testGraphMatchStepSuite - , testGraphEqSuitePart - , testGraphEqSuite - , testGraphEqSuiteMore - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - -geq = testGraphEqSuite -geq1 = testGraphEqSuiteMore -ttmore = tt testGraphEqSuiteMore -- this test may take a long time -tfmore = tf testGraphEqSuiteMore -ttstep = tt testGraphMatchStepSuite -tfstep = tf testGraphMatchStepSuite - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/GraphTest.hs,v $ --- $Author: graham $ --- $Revision: 1.24 $ --- $Log: GraphTest.hs,v $ --- Revision 1.24 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. --- --- Revision 1.23 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.22 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.21 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.20 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.19 2003/05/29 01:50:56 graham --- More performance tuning, courtesy of GHC profiler. --- All modules showing reasonable performance now. --- --- Revision 1.18 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.17 2003/05/23 16:29:20 graham --- Partial code cleanup: --- - Arc is an alebraic type --- - Arc is an instance of Functor --- - add gmap function to Graph interface --- - remove some duplicate functions from GraphMatch --- This in preparation for adding graph merge facility with --- blank node renaming. --- --- Revision 1.16 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.15 2003/05/14 11:13:15 graham --- Fixed bug in graph matching. --- (A graph-equivalence check is needed to weed out false matches --- caused by the "guessing" stage.) --- --- Revision 1.14 2003/05/14 02:01:59 graham --- GraphMatch recoded and almost working, but --- there are a couple of --- obscure bugs that are proving rather stubborn to squash. --- --- Revision 1.13 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.12 2003/05/07 19:26:32 graham --- Sync --- --- Revision 1.11 2003/05/01 23:15:44 graham --- GraphTest passes all tests using refactored LookupMap --- Extensive changes to GraphMatch were required. --- --- Revision 1.10 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.9 2003/04/11 18:12:10 graham --- Renamed GraphHelpers to ListHelpers --- LookupMapTest, GraphTest, RDFGraphTest all run OK --- --- Revision 1.8 2003/04/11 18:04:49 graham --- Rename GraphLookupMap to LookupMap: --- GraphTest runs OK. --- --- Revision 1.7 2003/04/10 13:41:22 graham --- More graph code tidying --- Graph test cases still run OK --- --- Revision 1.6 2003/04/10 13:35:34 graham --- Separated GraphMatch logic from GraphMem --- --- Revision 1.5 2003/04/10 08:36:06 graham --- Graph matching passes battery of new tests --- Started work on RDF graph --- --- Revision 1.4 2003/03/31 22:18:08 graham --- Simple graph equality tests all pass --- --- Revision 1.3 2003/03/31 20:52:23 graham --- Restructure graph matching to deal with same unbound node names in --- different graphs. It shows signs that it might be working now. --- More testing is needed. --- --- Revision 1.2 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- --- Revision 1.1 2003/03/12 23:00:43 graham --- Graph model coded and working, except for graph isomorphism test. --- diff --git a/Swish/HaskellRDF/MapXsdInteger.hs b/Swish/HaskellRDF/MapXsdInteger.hs deleted file mode 100644 --- a/Swish/HaskellRDF/MapXsdInteger.hs +++ /dev/null @@ -1,96 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: MapXsdInteger.hs,v 1.1 2003/11/14 15:59:51 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : MapXsdInteger --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + ???? --- --- This module defines the datatytpe mapping and relation values --- used for RDF dataype xsd:integer --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.MapXsdInteger - ( mapXsdInteger - ) -where - -import Swish.HaskellRDF.Datatype - ( DatatypeMap(..) - ) - - -import Swish.HaskellRDF.Dfa.Dfa - ( Re(..) - , matchRe - ) - ------------------------------------------------------------- --- Implementation of DatatypeMap for xsd:integer ------------------------------------------------------------- - --- |mapXsdInteger contains functions that perform lexical-to-value --- and value-to-canonical-lexical mappings for xsd:integer values --- -mapXsdInteger :: DatatypeMap Integer -mapXsdInteger = DatatypeMap - { -- mapL2V :: String -> Maybe Integer - mapL2V = \s -> case [ x - | matchRe reInteger s - , (x,t) <- reads $ skipPlus s - , ("","") <- lex t - ] of - [] -> Nothing - is -> Just $ head is - -- mapV2L :: Integer -> Maybe String - , mapV2L = Just . show - } - -skipPlus :: String -> String -skipPlus ('+':s) = s -skipPlus s = s - -reInteger = ReCat [ReOpt (alt "+-"), digits1] - where - digits0 = ReStar digit - digits1 = RePlus digit - digit = alt "0123456789" - alt cs = ReOr $ map (\c -> ReTerm [c]) cs - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/MapXsdInteger.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: MapXsdInteger.hs,v $ --- Revision 1.1 2003/11/14 15:59:51 graham --- Separate MapXsdInteger from RDFDatatypeXsdInteger. --- diff --git a/Swish/HaskellRDF/N3Formatter.hs b/Swish/HaskellRDF/N3Formatter.hs deleted file mode 100644 --- a/Swish/HaskellRDF/N3Formatter.hs +++ /dev/null @@ -1,695 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: N3Formatter.hs,v 1.23 2004/01/22 19:52:41 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3Formatter --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module implements a Notation 3 formatter (see [1], [2]), --- for an RDFGraph value. --- --- --- REFERENCES: --- --- [1] http://www.w3.org/DesignIssues/Notation3.html --- Tim Berners-Lee's design issues series notes and description --- --- [2] http://www.w3.org/2000/10/swap/Primer.html --- Notation 3 Primer by Sean Palmer --- --- --- [[[TODO:]]] --- (a) Initial prefix list to include nested formulae; --- then don't need to update prefix list for these. --- (b) blank nodes used just once, can be expanded inline using --- [...] syntax. --- (c) generate multi-line literals when appropriate --- (d) more flexible terminator generation for formatted formulae --- (for inline blank nodes.) --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.N3Formatter - ( formatGraphAsStringNl - , formatGraphAsString - , formatGraphAsShowS - , formatGraphIndent - , formatGraphDiag - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , NamespaceMap, RevNamespaceMap - , emptyNamespaceMap - , FormulaMap, emptyFormulaMap - , getArcs, labels - , setNamespaces, getNamespaces - , getFormulae - , emptyRDFGraph - ) - -import Swish.HaskellRDF.GraphClass - ( Arc(..) - , arc - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..) - , LookupMap, emptyLookupMap, reverseLookupMap - , listLookupMap - , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge - ) - -import Swish.HaskellUtils.QName - ( QName(..) - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..), getScopeURI ) - -import Swish.HaskellUtils.ProcessURI - ( isAbsoluteURIRef ) - -import Swish.HaskellRDF.Sort.QuickSort - ( stableQuickSort ) - -import Data.Char - ( isDigit ) - -import Data.List - ( groupBy ) - -import Data.Maybe - ( Maybe(..), isJust, fromJust ) - ----------------------------------------------------------------------- --- Ouptut string concatenation ----------------------------------------------------------------------- --- --- Function puts uses the shows mechanism to avoid the cost of --- quadratic string concatenation times. (Use function composition to --- concatenate strings thus reprersented.) - -puts :: String -> ShowS -puts = showString - ----------------------------------------------------------------------- --- Graph formatting state monad ----------------------------------------------------------------------- --- --- The graph to be formatted is carried as part of the formatting --- state, so that decisions about what needs to be formatted can --- themselves be based upon and reflected in the state (e.g. if a --- decision is made to include a blank node inline, it can be removed --- from the graph state that remains to be formatted). - -type SubjTree lb = [(lb,PredTree lb)] -type PredTree lb = [(lb,[lb])] - -data Fgs = Fgs - { indent :: String - , lineBreak :: Bool - , graph :: RDFGraph - , subjs :: SubjTree RDFLabel - , props :: PredTree RDFLabel -- for last subject selected - , objs :: [RDFLabel] -- for last property selected - , formAvail :: FormulaMap RDFLabel - , formQueue :: [(RDFLabel,RDFGraph)] - , nodeGenSt :: NodeGenState - , traceBuf :: [String] - } - -emptyFgs :: NodeGenState -> Fgs -emptyFgs ngs = Fgs - { indent = "\n" - , lineBreak = False - , graph = emptyRDFGraph - , subjs = [] - , props = [] - , objs = [] - , formAvail = emptyFormulaMap - , formQueue = [] - , nodeGenSt = ngs - , traceBuf = [] - } - --- Node name generation state information that carries through --- and is updated by nested formulae - -type NodeGenLookupMap = LookupMap (RDFLabel,Int) - -data NodeGenState = Ngs - { prefixes :: NamespaceMap - , nodeMap :: NodeGenLookupMap - , nodeGen :: Int - } - -emptyNgs :: NodeGenState -emptyNgs = Ngs - { prefixes = emptyLookupMap - , nodeMap = emptyLookupMap - , nodeGen = 0 - } - --- monad definition adapted from Simon Thompson's book, p410 --- --- Fgsm a is a "state transformer" on a state of type "Fgs", --- which additionally returns a value of type 'a'. -data Fgsm a = Fgsm ( Fgs -> (Fgs,a) ) - -instance Monad Fgsm where - return res = Fgsm (\fgs -> (fgs,res)) - (Fgsm st) >>= f = Fgsm (\fgs -> - let (newfgs,res) = st fgs - (Fgsm st') = f res - in - st' newfgs - ) - -getFgs :: Fgsm Fgs -getFgs = Fgsm (\fgs -> (fgs,fgs) ) - -doTrace :: String -> Fgsm () -doTrace msg = Fgsm (\fgs -> (fgs {traceBuf=msg:(traceBuf fgs)},()) ) - -getIndent :: Fgsm String -getIndent = Fgsm (\fgs -> (fgs,indent fgs) ) - -setIndent :: String -> Fgsm () -setIndent ind = Fgsm (\fgs -> (fgs {indent=ind},()) ) - -getLineBreak :: Fgsm Bool -getLineBreak = Fgsm (\fgs -> (fgs,lineBreak fgs) ) - -setLineBreak :: Bool -> Fgsm () -setLineBreak brk = Fgsm (\fgs -> (fgs {lineBreak=brk},()) ) - -getNgs :: Fgsm NodeGenState -getNgs = Fgsm (\fgs -> (fgs,nodeGenSt fgs) ) - -setNgs :: NodeGenState -> Fgsm () -setNgs ngs = Fgsm (\fgs -> (fgs { nodeGenSt = ngs },()) ) - -getPrefixes :: Fgsm NamespaceMap -getPrefixes = Fgsm (\fgs -> (fgs,prefixes (nodeGenSt fgs)) ) - -queueFormula :: RDFLabel -> Fgsm () -queueFormula fn = Fgsm (\fgs -> - let fa = formAvail fgs - newState fv = - fgs { formAvail=mapDelete fa fn - , formQueue=(fn,fv):(formQueue fgs) - } - in - case (mapFindMaybe fn fa) of - Nothing -> (fgs,()) - Just fv -> (newState fv,()) - ) - -moreFormulae :: Fgsm Bool -moreFormulae = Fgsm (\fgs -> (fgs,not $ null (formQueue fgs)) ) - -nextFormula :: Fgsm (RDFLabel,RDFGraph) -nextFormula = Fgsm (\fgs -> - let (nf:fq) = (formQueue fgs) in (fgs {formQueue=fq},nf) - ) - ----------------------------------------------------------------------- --- Define a top-level formatter function: --- accepts a graph and returns a string ----------------------------------------------------------------------- - -formatGraphAsStringNl :: RDFGraph -> String -formatGraphAsStringNl gr = formatGraphAsShowS gr "\n" - -formatGraphAsString :: RDFGraph -> String -formatGraphAsString gr = formatGraphAsShowS gr "" - -formatGraphAsShowS :: RDFGraph -> ShowS -formatGraphAsShowS gr = formatGraphIndent "\n" True gr -{- old code: - where - (out,_,_,_) = formatGraphDiag gr --} - -formatGraphIndent :: String -> Bool -> RDFGraph -> ShowS -formatGraphIndent ind dopref gr = out - where - (_,out) = formatGraphDiag1 ind dopref emptyLookupMap gr - --- Format graph and return additional information -formatGraphDiag :: - RDFGraph -> (ShowS,NodeGenLookupMap,Int,[String]) -formatGraphDiag gr = (out,nodeMap ngs,nodeGen ngs,traceBuf fgs) - where - (fgs,out) = formatGraphDiag1 "\n" True emptyLookupMap gr - ngs = nodeGenSt fgs - --- Internal function starts with supplied prefix table and indent string, --- and returns final state and formatted string. --- This is provided for diagnostic access to the final state -formatGraphDiag1 :: String -> Bool -> NamespaceMap -> RDFGraph -> (Fgs,ShowS) -formatGraphDiag1 ind dopref pref gr = res where - Fgsm fg = formatGraph ind " ." False dopref gr -- construct monad - ngs = emptyNgs -- construct initial state - { prefixes=pref - , nodeGen=findMaxBnode gr - } - (_,res) = fg (emptyFgs ngs) -- apply monad to state, pick result - ----------------------------------------------------------------------- --- Formatting as a monad-based computation ----------------------------------------------------------------------- - --- ind is indentation string --- end is ending string to be placed after final statement --- dobreak is True if a line break is to be inserted at the start --- dopref is True if prefix strings are to be generated --- -formatGraph :: String -> String -> Bool -> Bool -> RDFGraph -> Fgsm (Fgs,ShowS) -formatGraph ind end dobreak dopref gr = - do { setIndent ind - ; setLineBreak dobreak - ; setGraph gr - ; fp <- if dopref then - formatPrefixes (getNamespaces gr) - else - return $ puts "" - ; more <- moreSubjects - ; res <- if more then do - { fr <- formatSubjects - ; return $ fp . fr . (puts end) - } - else return $ fp - ; fgs <- getFgs - ; return (fgs,res) - } - -formatPrefixes :: NamespaceMap -> Fgsm ShowS -formatPrefixes pmap = - do { let mls = map (pref . keyVal) (listLookupMap pmap) - ; ls <- sequence mls - ; return $ puts $ concat ls - } - where - pref (p,u) = nextLine $ "@prefix "++p++": <"++u++"> ." - --- The above function creates a list of 'Fgsm String' monads, then --- uses 'sequence' to turn that to a single 'Fgsm [String]' and finally --- concatenates them to a single string and uses 'puts' to return the --- result as a 'Fgsm ShowS'. Phew! - -formatSubjects :: Fgsm ShowS -formatSubjects = - do { sb <- nextSubject - ; sbstr <- formatLabel sb - ; prstr <- formatProperties sb sbstr - ; fmstr <- formatFormulae "" - ; more <- moreSubjects - ; if more then do - { fr <- formatSubjects - ; return $ (puts $ prstr ++ fmstr ++ " .") . fr - } - else return $ puts $ prstr ++ fmstr - } - -formatProperties :: RDFLabel -> String -> Fgsm String -formatProperties sb sbstr = - do { pr <- nextProperty sb - ; prstr <- formatLabel pr - ; obstr <- formatObjects sb pr (sbstr++" "++prstr) - ; more <- moreProperties - ; let sbindent = replicate (length sbstr) ' ' - ; if more then do - { fr <- formatProperties sb sbindent - ; nl <- nextLine $ obstr ++ " ;" - ; return $ nl ++ fr - } - else nextLine $ obstr - } - -formatObjects :: RDFLabel -> RDFLabel -> String -> Fgsm String -formatObjects sb pr prstr = - do { ob <- nextObject sb pr - ; obstr <- formatLabel ob - ; more <- moreObjects - ; if more then do - { let prindent = replicate (length prstr) ' ' - ; fr <- formatObjects sb pr prindent - ; nl <- nextLine $ prstr ++ " " ++ obstr ++ "," - ; return $ nl ++ fr - } - else return $ prstr ++ " " ++ obstr - } - -formatFormulae :: String -> Fgsm String -formatFormulae fp = - do { more <- moreFormulae - ; if more then do - { fnlgr <- nextFormula - ; fnstr <- formatFormula fnlgr - ; formatFormulae $ fp ++ " ." ++ fnstr - } - else return $ fp - } - --- [[[TODO: use above pattern for subject/property/object loops?]]] - -formatFormula :: (RDFLabel,RDFGraph) -> Fgsm String -formatFormula (fn,gr) = - do { fnstr <- formatLabel fn - ; f1str <- nextLine $ fnstr ++ " :-" - ; f2str <- nextLine " {" - ; ngs0 <- getNgs - ; ind <- getIndent - ; let Fgsm grm = formatGraph (ind++" ") "" True False - (setNamespaces emptyNamespaceMap gr) - ; let (fgs',(_,f3str)) = grm (emptyFgs ngs0) - ; setNgs (nodeGenSt fgs') - ; f4str <- nextLine " }" - ; return $ f1str ++ f2str ++ (f3str f4str) - } - ----------------------------------------------------------------------- --- Formatting helpers ----------------------------------------------------------------------- - -setGraph :: RDFGraph -> Fgsm () -setGraph gr = - Fgsm (\fgs -> - let ngs0 = (nodeGenSt fgs) - pre' = mapMerge (prefixes ngs0) (getNamespaces gr) - ngs' = ngs0 { prefixes=pre' } - fgs' = fgs { graph = gr - , subjs = arcTree $ getArcs gr - , props = [] - , objs = [] - , formAvail = getFormulae gr - , nodeGenSt = ngs' - } - in (fgs',()) ) - -moreSubjects :: Fgsm Bool -moreSubjects = Fgsm (\fgs -> (fgs,not $ null (subjs fgs))) - -nextSubject :: Fgsm RDFLabel -nextSubject = - Fgsm (\fgs -> - let sb:sbs = subjs fgs - fgs' = fgs { subjs = sbs - , props = snd sb - , objs = [] - } - in (fgs',fst sb) ) - - -moreProperties :: Fgsm Bool -moreProperties = Fgsm (\fgs -> (fgs,not $ null (props fgs))) - -nextProperty :: RDFLabel -> Fgsm RDFLabel -nextProperty sb = - Fgsm (\fgs -> - let pr:prs = props fgs - fgs' = fgs { props = prs - , objs = snd pr - } - in (fgs',fst pr) ) - - -moreObjects :: Fgsm Bool -moreObjects = Fgsm (\fgs -> (fgs,not $ null (objs fgs))) - -nextObject :: RDFLabel -> RDFLabel -> Fgsm RDFLabel -nextObject sb pr = - Fgsm (\fgs -> - let ob:obs = objs fgs - fgs' = fgs { objs = obs } - in (fgs',ob) ) - -nextLine :: String -> Fgsm String -nextLine str = - do { ind <- getIndent - ; brk <- getLineBreak - ; if brk then - return $ ind++str - else - -- After first line, always insert line break - do { setLineBreak True - ; return str - } - } - --- Format a label --- Most labels are simply displayed as provided, but there are a --- number of wrinkles to take care of here: --- (a) blank nodes automatically allocated on input, with node --- identifiers of the form of a digit string nnn. These are --- not syntactically valid, and are reassigned node identifiers --- of the form _nnn, where nnn is chosen so that is does not --- clash with any other identifier in the graph. --- (b) URI nodes: if possible, replace URI with qname, --- else display as --- (c) formula nodes (containing graphs). --- --- [[[TODO:]]] --- (d) blank nodes used just once, can be expanded inline using --- [...] syntax. --- (e) generate multi-line literals when appropriate - -formatLabel :: RDFLabel -> Fgsm String -formatLabel lab@(Blank nodeid@(lnc:_)) = - do { name <- formatNodeId lab - ; queueFormula lab - ; return name - } -formatLabel lab@(Res sn) = - do { pr <- getPrefixes - ; let nsuri = getScopeURI sn - ; let local = snLocal sn - ; let premap = reverseLookupMap pr :: RevNamespaceMap - ; let prefix = mapFindMaybe nsuri premap - ; let name = if (isJust prefix) - then fromJust prefix++":"++local - else "<"++nsuri++local++">" - ; queueFormula lab - ; return name - } -{- -formatLabel lab@(Lit str typ) = - do { return $ show lab - } -formatLabel lab@(Var vid) = - do { return $ show lab - } --} -formatLabel lab = - do { return $ show lab - } - -formatNodeId :: RDFLabel -> Fgsm String -formatNodeId lab@(Blank nodeid@(lnc:_)) = - if isDigit lnc then mapBlankNode lab else return $ show lab - -mapBlankNode :: RDFLabel -> Fgsm String -mapBlankNode lab = - do { ngs <- getNgs - ; let nmap = nodeMap ngs - ; let nnxt = (nodeGen ngs) - ; (nval,nnxt',nmap') <- case mapFind 0 lab nmap of - 0 -> do { let nn = nnxt + 1 - ; let nm = mapAdd nmap (lab,nn) - ; setNgs $ ngs { nodeGen=nn, nodeMap=nm } - ; return (nn,nn,nm) - } - n -> return $ (n,nnxt,nmap) - {- ; doTrace $ "Map node id: "++(show lab) - ++", nval "++(show nval) - ++", next "++(show nnxt') - ++", nmap "++(show nmap') -} - ; return $ show $ Blank ('_':show nval) - } - ----------------------------------------------------------------------- --- Graph-related helper functions ----------------------------------------------------------------------- - --- Rearrange a list of arcs into a tree of pairs which group together --- all statements for a single subject, sind similarly for multiple --- objects of a common predicate. -arcTree :: (Ord lb) => [Arc lb] -> SubjTree lb -arcTree as = commonFstEq (commonFstEq id) $ map spopair $ stableQuickSort as - where - spopair (Arc s p o) = (s,(p,o)) - -{- -arcTree as = map spopair $ sort as - where - spopair (Arc s p o) = (s,[(p,[o])]) --} - --- Rearrange a list of pairs so that multiple occurrences of the first --- are commoned up, and the supplied function is applied to each sublist --- with common first elements to obtain the corresponding second value -commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] -commonFstEq f ps = - [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] - where - fstEq (f1,_) (f2,_) = f1 == f2 - -{- --- Diagnostic code for checking arcTree logic: -testArcTree = (arcTree testArcTree1) == testArcTree2 -testArcTree1 = - [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" - ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" - ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" - ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" - ] -testArcTree2 = - [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) - ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) - ] --} - - -findMaxBnode :: RDFGraph -> Int -findMaxBnode gr = - maximum $ - map getAutoBnodeIndex $ - labels gr - -getAutoBnodeIndex :: RDFLabel -> Int -getAutoBnodeIndex (Blank ('_':lns)) = res where - -- cf. prelude definition of read s ... - res = case [x | (x,t) <- reads lns, ("","") <- lex t] of - [x] -> x - _ -> 0 -getAutoBnodeIndex _ = 0 - - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/N3Formatter.hs,v $ --- $Author: graham $ --- $Revision: 1.23 $ --- $Log: N3Formatter.hs,v $ --- Revision 1.23 2004/01/22 19:52:41 graham --- Rename module URI to avoid awkward clash with Haskell libraries --- --- Revision 1.22 2004/01/09 12:57:08 graham --- Remove space between perfix and ':' in @prefix declaractions, --- for compatibility with new Notation 3 syntax (and Jena). --- --- Revision 1.21 2004/01/09 12:49:39 graham --- Remove superfluous PutS class. --- --- Revision 1.20 2004/01/09 12:44:52 graham --- Fix up N3Formatter to suppress final statement-terminating '.' in a formula, --- for compatibility with the current Notation3 syntax. --- --- Revision 1.19 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.18 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.17 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.16 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.15 2003/10/24 21:03:25 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.14 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.13 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.12 2003/06/25 21:16:52 graham --- Reworked N3 formatting logic to support proof display. --- Basic proof display is working. --- --- Revision 1.11 2003/06/12 00:47:55 graham --- Allowed variable node (?v) and bare anonymous nodes in N3 parser. --- --- Revision 1.10 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.9 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.8 2003/05/23 00:02:42 graham --- Fixed blank node id generation bug in N3Formatter --- --- Revision 1.7 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.6 2003/05/14 22:39:23 graham --- Initial formatter tests all run OK. --- The formatter could still use so,me improvement, --- but it --- passes the minimal round-tripping tests. --- --- Revision 1.5 2003/05/14 19:38:32 graham --- Simple formatter tests all working with reworked graph and lookup structures. --- More complex formatter tests still to be coded. --- --- Revision 1.4 2003/04/29 22:09:43 graham --- Updated TODO notes --- --- Revision 1.3 2003/04/29 22:07:10 graham --- Some refactoring of N3 formatter. --- N3 formatter now handles trivial cases. --- More complex formatter test cases still to be developed. --- --- Revision 1.2 2003/04/25 11:40:06 graham --- Formatter compiles OK --- --- Revision 1.1 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- diff --git a/Swish/HaskellRDF/N3FormatterTest.hs b/Swish/HaskellRDF/N3FormatterTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/N3FormatterTest.hs +++ /dev/null @@ -1,1470 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: N3FormatterTest.hs,v 1.21 2004/01/09 12:57:08 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3FormatterTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module defines test cases for module Parse parsing functions. --- --------------------------------------------------------------------------------- - --- WNH module Swish.HaskellRDF.N3FormatterTest where - -import Swish.HaskellRDF.N3Formatter - ( formatGraphAsStringNl - , formatGraphAsString - , formatGraphDiag ) - -import Swish.HaskellRDF.N3Parser - ( ParseResult(..) - , parseN3fromString - , parseTextFromString, parseAltFromString - , parseNameFromString, parsePrefixFromString - , parseAbsURIrefFromString, parseLexURIrefFromString - , parseURIref2FromString ) - -import Swish.HaskellRDF.RDFGraph - ( RDFTriple, RDFGraph, RDFLabel(..), NSGraph(..) - , setArcs, getArcs, add, delete, extract, labels - , NamespaceMap, emptyNamespaceMap - , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap - , setNamespaces - , emptyRDFGraph, toRDFGraph - -- Export selected RDFLabel values - , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil - , res_rdfs_member - , res_rdfd_GeneralRestriction - , res_rdfd_onProperties, res_rdfd_constraint, res_rdfd_maxCardinality - , res_owl_sameAs - , res_operator_plus, res_operator_minus - , res_operator_slash, res_operator_star - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , makeNamespaceQName - , getQName, getScopedNameURI - , ScopedName(..) - , makeScopedName, makeQNameScopedName - , nullScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceRDFC - , namespaceRDFO - , namespaceXSD - , namespaceXsdType - , namespaceOWL - , namespaceMATH - , namespaceLOG - , namespaceDAML - , rdf_type - , rdf_first, rdf_rest, rdf_nil - , rdfs_member - , rdfd_GeneralRestriction - , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality - , owl_sameAs - , operator_plus, operator_minus, operator_slash, operator_star - ) - -import Swish.HaskellUtils.QName - ( QName(..) - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) - , emptyLookupMap, makeLookupMap, listLookupMap ) - -import Swish.HaskellRDF.GraphClass - ( Arc, arcSubj, arcPred, arcObj, arc ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(..) ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertEqual, runTestTT, runTestText, putTextToHandle ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - ------------------------------------------------------------- --- Common test wrappers ------------------------------------------------------------- - -testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test -testLabelEq lab eq n1 n2 = - TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) - -testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test -testGraphEq lab eq g1 g2 = - TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node#" -base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" -base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" -base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" - -qb1s1 = ScopedName base1 "s1" -qb2s2 = ScopedName base2 "s2" -qb3s3 = ScopedName base3 "s3" - -s1 = Res qb1s1 :: RDFLabel -s2 = Res qb2s2 :: RDFLabel -s3 = Res qb3s3 :: RDFLabel - -b1 = Blank "b1" :: RDFLabel -b2 = Blank "b2" :: RDFLabel -b3 = Blank "b3" :: RDFLabel -b4 = Blank "b4" :: RDFLabel -b5 = Blank "b5" :: RDFLabel -b6 = Blank "b6" :: RDFLabel -b7 = Blank "b7" :: RDFLabel -b8 = Blank "b8" :: RDFLabel - -c1 = Blank "c1" :: RDFLabel -c2 = Blank "c2" :: RDFLabel -c3 = Blank "c3" :: RDFLabel -c4 = Blank "c4" :: RDFLabel -c5 = Blank "c5" :: RDFLabel -c6 = Blank "c6" :: RDFLabel - -qb1p1 = ScopedName base1 "p1" -qb2p2 = ScopedName base2 "p2" -qb3p3 = ScopedName base3 "p3" -qb2p21 = ScopedName base2 "p21" -qb2p22 = ScopedName base2 "p22" -qb2p23 = ScopedName base2 "p23" -qb2p24 = ScopedName base2 "p24" -qb2p25 = ScopedName base2 "p25" -qb2p26 = ScopedName base2 "p26" - -p1 = Res qb1p1 :: RDFLabel -p2 = Res qb2p2 :: RDFLabel -p3 = Res qb3p3 :: RDFLabel -p21 = Res qb2p21 :: RDFLabel -p22 = Res qb2p22 :: RDFLabel -p23 = Res qb2p23 :: RDFLabel -p24 = Res qb2p24 :: RDFLabel -p25 = Res qb2p25 :: RDFLabel -p26 = Res qb2p26 :: RDFLabel - -qb1o1 = ScopedName base1 "o1" -qb2o2 = ScopedName base2 "o2" -qb3o3 = ScopedName base3 "o3" - -o1 = Res qb1o1 :: RDFLabel -o2 = Res qb2o2 :: RDFLabel -o3 = Res qb3o3 :: RDFLabel - -l1txt = "l1" -l2txt = "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" -l3txt = "l3--\r\"'\\--\x0020\&--\x00A0\&--" -l11txt = "lx11" -l12txt = "lx12" -l13txt = "lx13" -l14txt = "lx14" - -l1 = Lit l1txt Nothing :: RDFLabel -l2 = Lit l2txt Nothing :: RDFLabel -l3 = Lit l3txt Nothing :: RDFLabel -l11 = Lit l11txt Nothing :: RDFLabel -l12 = Lit l12txt Nothing :: RDFLabel -l13 = Lit l13txt Nothing :: RDFLabel -l14 = Lit l14txt Nothing :: RDFLabel - -qb1f1 = ScopedName base1 "f1" -qb2f2 = ScopedName base2 "f2" - -f1 = Res qb1f1 :: RDFLabel -f2 = Res qb2f2 :: RDFLabel - -v1 = Var "var1" :: RDFLabel -v2 = Var "var2" :: RDFLabel -v3 = Var "var3" :: RDFLabel -v4 = Var "var4" :: RDFLabel - ------------------------------------------------------------- --- Construct graphs for testing ------------------------------------------------------------- - -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 = makeLookupMap - [ base1 - , base2 - , base3 - , base4 - ] - -g1np = NSGraph - { namespaces = emptyNamespaceMap - , formulae = emptyFormulaMap - , statements = [t01] - } - -g1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01] - } - -g1b1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [b01] - } - where - b01 = arc b1 p1 o1 - -g1b3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [b01] - } - where - b01 = arc b1 b2 b3 - -g1a1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [a01] - } - where - a1 = Blank "1" :: RDFLabel - a01 = arc a1 p1 o1 - -g1l1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [l01] - } - where - l01 = arc s1 p1 l1 - -g1l2 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [l02] - } - where - l02 = arc s1 p1 l2 - - -g1f1 = NSGraph - { namespaces = nslist - , formulae = formo1g1 - , statements = [f01] - } - where - f01 = arc s1 p1 o1 - formo1g1 = LookupMap [Formula o1 g1] - - -g1f2 = NSGraph - { namespaces = nslist - , formulae = formb2g1 - , statements = [f02] - } - where - f02 = arc s1 p1 b2 - formb2g1 = LookupMap [Formula b2 g1] - -g1f3 = NSGraph - { namespaces = nslist - , formulae = formb3g1f2 - , statements = [f02] - } - where - f02 = arc s1 p1 b3 - formb3g1f2 = LookupMap [Formula b3 g1f2] - ----- - -g2 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03] - } - -g3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t04] - } - -g4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t05] - } - -g5 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05] - } - -g6 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t06] - } - -g7 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t07] - } - -pref_rdf = nsURI namespaceRDF -pref_op = nsURI namespaceRDFO -pref_owl = nsURI namespaceOWL - -t801 = arc s1 res_rdf_type o1 -t802 = arc s2 res_owl_sameAs o2 -t803 = arc s3 res_operator_plus o3 -t804 = arc s3 res_operator_minus o3 -t805 = arc s3 res_operator_star o3 -t806 = arc s3 res_operator_slash o3 -t807 = arc o1 p1 s1 -t808 = arc s2 p1 o2 -t809 = arc s1 p2 o1 -t810 = arc o2 p2 s2 - -g8 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t801,t802,t803,t804,t805,t806,t807,t808,t809,t810] - } - -g81 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t801,t802] - } - -g82 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t803,t804,t805,t806] - } - -g83 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t807,t808,t809,t810] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t911,t912,t913,t914, - t921,t922,t923,t924, - t925,t926,t927,t928] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1011,t1012,t1013,t1014, - t1021,t1022,t1023,t1024, - t1025,t1026,t1027,t1028 ] - } - -t1111 = arc s1 p1 v1 -t1112 = arc v2 p1 o1 -t1113 = arc v3 p1 v4 - -g11 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1111,t1112,t1113] - } - -tx101 = arc b1 res_owl_sameAs s1 -tx102 = arc s2 res_owl_sameAs 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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx101,tx102, - tx111,tx112,tx113,tx114, - tx121,tx122,tx123,tx124, - tx125,tx126,tx127,tx128] - } - -tx201 = arc b1 res_owl_sameAs s1 -tx202 = arc s2 res_owl_sameAs 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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx201,tx202, - tx211,tx212,tx213,tx214, - tx221,tx222,tx223,tx224, - tx225,tx226,tx227] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx311,tx312,tx313,tx314, - tx321,tx322,tx323,tx324, - tx325,tx326,tx327] - } - -tx401 = arc s1 res_owl_sameAs b1 -tx402 = arc b1 res_rdf_first o1 -tx403 = arc b1 res_rdf_rest b2 -tx404 = arc b2 res_rdf_first o2 -tx405 = arc b2 res_rdf_rest b3 -tx406 = arc b3 res_rdf_first o3 -tx407 = arc b3 res_rdf_rest b4 -tx408 = arc b4 res_rdf_first l1 -tx409 = arc b4 res_rdf_rest res_rdf_nil - -x4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx401,tx402,tx403,tx404, - tx405,tx406,tx407,tx408, - tx409] - } - -tx501 = arc b1 res_owl_sameAs s1 -tx502 = arc b1 res_rdf_first o1 -tx503 = arc b1 res_rdf_rest b2 -tx504 = arc b2 res_rdf_first o2 -tx505 = arc b2 res_rdf_rest b3 -tx506 = arc b3 res_rdf_first o3 -tx507 = arc b3 res_rdf_rest b4 -tx508 = arc b4 res_rdf_first l1 -tx509 = arc b4 res_rdf_rest res_rdf_nil - -x5 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx501,tx502,tx503,tx504, - tx505,tx506,tx507,tx508, - tx509] - } - -tx601 = arc s1 res_rdf_first o1 -tx602 = arc s1 res_rdf_rest b2 -tx603 = arc b2 res_rdf_first o2 -tx604 = arc b2 res_rdf_rest b3 -tx605 = arc b3 res_rdf_first o3 -tx606 = arc b3 res_rdf_rest b4 -tx607 = arc b4 res_rdf_first l1 -tx608 = arc b4 res_rdf_rest res_rdf_nil - -x6 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx601,tx602,tx603,tx604, - tx605,tx606,tx607,tx608] - } - -formb1g2 = LookupMap [Formula b1 g2] -tx701 = arc b1 p2 f2 -x7 = NSGraph - { namespaces = nslist - , formulae = formb1g2 - , statements = [tx701] - } - -formf1g2 = LookupMap [Formula f1 g2] -tx801 = arc f1 p2 f2 -x8 = NSGraph - { namespaces = nslist - , formulae = formf1g2 - , statements = [tx801] - } - -formf1g1 = LookupMap [Formula f1 g1] -tx901 = arc f1 p2 f2 - -x9 = NSGraph - { namespaces = nslist - , formulae = formf1g1 - , statements = [tx801] - } - --- Test allocation of bnodes carries over a nested formula -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 = NSGraph - { namespaces = emptyNamespaceMap - , formulae = emptyFormulaMap - , statements = [tx1211,tx1212] - } -x12f = LookupMap [Formula b2 x12fg] -x12 = NSGraph - { namespaces = nslist - , formulae = x12f - , statements = [tx1201,tx1202,tx1203,tx1204,tx1205] - } - --- List of simple anon nodes -tx1301 = arc s1 res_rdf_first b1 -tx1302 = arc s1 res_rdf_rest c1 -tx1303 = arc c1 res_rdf_first b2 -tx1304 = arc c1 res_rdf_rest c2 -tx1305 = arc c2 res_rdf_first b3 -tx1306 = arc c2 res_rdf_rest res_rdf_nil -tx1307 = arc b1 p1 o1 -tx1308 = arc b2 p1 o2 -tx1309 = arc b3 p1 o3 - -x13 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1301,tx1302,tx1303,tx1304,tx1305,tx1306, - tx1307,tx1308,tx1309] - } - --- List of simple anon nodes using autogenerated bnodes -b_1 = Blank "1" :: RDFLabel -b_2 = Blank "2" :: RDFLabel -b_3 = Blank "3" :: RDFLabel -c_1 = Blank "4" :: RDFLabel -c_2 = Blank "5" :: RDFLabel - -tx1301a = arc s1 res_rdf_first b_1 -tx1302a = arc s1 res_rdf_rest c_1 -tx1303a = arc c_1 res_rdf_first b_2 -tx1304a = arc c_1 res_rdf_rest c_2 -tx1305a = arc c_2 res_rdf_first b_3 -tx1306a = arc c_2 res_rdf_rest res_rdf_nil -tx1307a = arc b_1 p1 o1 -tx1308a = arc b_2 p1 o2 -tx1309a = arc b_3 p1 o3 - -x13a = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1301a,tx1302a,tx1303a,tx1304a,tx1305a,tx1306a, - tx1307a,tx1308a,tx1309a] - } - --- List of more complex anon nodes -tx1401 = arc s1 res_rdf_first b1 -tx1402 = arc s1 res_rdf_rest c1 -tx1403 = arc c1 res_rdf_first b2 -tx1404 = arc c1 res_rdf_rest c2 -tx1405 = arc c2 res_rdf_first b3 -tx1406 = arc c2 res_rdf_rest res_rdf_nil -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1401,tx1402,tx1403,tx1404,tx1405,tx1406, - tx1407,tx1408,tx1409,tx1410,tx1411,tx1412] - } - --- List with nested list -tx1501 = arc s1 res_rdf_first b1 -tx1502 = arc s1 res_rdf_rest c1 -tx1503 = arc c1 res_rdf_first b2 -tx1504 = arc c1 res_rdf_rest c2 -tx1505 = arc c2 res_rdf_first b3 -tx1506 = arc c2 res_rdf_rest res_rdf_nil -tx1507 = arc b1 p1 o1 -tx1508 = arc b2 p2 c3 -tx1509 = arc b3 p1 o3 - -tx1521 = arc c3 res_rdf_first b4 -tx1522 = arc c3 res_rdf_rest c4 -tx1523 = arc c4 res_rdf_first b5 -tx1524 = arc c4 res_rdf_rest c5 -tx1525 = arc c5 res_rdf_first b6 -tx1526 = arc c5 res_rdf_rest res_rdf_nil -tx1527 = arc b4 p1 o1 -tx1528 = arc b5 p1 o2 -tx1529 = arc b6 p1 o3 - -x15 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [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 = arc s1 res_rdf_first b1 -tx1602 = arc s1 res_rdf_rest c1 -tx1603 = arc c1 res_rdf_first b2 -tx1604 = arc c1 res_rdf_rest c2 -tx1605 = arc c2 res_rdf_first b3 -tx1606 = arc c2 res_rdf_rest res_rdf_nil -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 = arc c3 res_rdf_first b4 -tx1622 = arc c3 res_rdf_rest c4 -tx1623 = arc c4 res_rdf_first b5 -tx1624 = arc c4 res_rdf_rest c5 -tx1625 = arc c5 res_rdf_first b6 -tx1626 = arc c5 res_rdf_rest res_rdf_nil -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1601,tx1602,tx1603,tx1604,tx1605,tx1606, - tx1607,tx1608,tx1609,tx1610,tx1611, - tx1621,tx1622,tx1623,tx1624,tx1625,tx1626, - tx1627,tx1628,tx1629,tx1630,tx1631,tx1632] - } - --- Troublesome example -tx1701 = arc s1 res_rdf_type o1 -tx1702 = arc s1 res_rdf_first b1 -tx1703 = arc s1 res_rdf_rest c1 -tx1704 = arc c1 res_rdf_first b2 -tx1705 = arc c1 res_rdf_rest res_rdf_nil - -tx1706 = arc b1 p21 o2 -tx1707 = arc b1 p22 c2 - -tx1708 = arc b2 p24 o3 -tx1709 = arc b2 p25 l13 - -tx1710 = arc c2 res_rdf_first b3 -tx1711 = arc c2 res_rdf_rest c3 -tx1712 = arc c3 res_rdf_first l12 -tx1713 = arc c3 res_rdf_rest res_rdf_nil - -tx1714 = arc b3 p23 l11 - -x17 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1701,tx1702,tx1703,tx1704,tx1705,tx1706, - tx1707,tx1708,tx1709, - tx1710,tx1711,tx1712,tx1713,tx1714] - } - ------------------------------------------------------------- --- 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 -> String -> Test -formatTest lab gr out = - TestList - [ TestCase ( assertEqual ("formatTest:"++lab) out res ) - ] - where - res = formatGraphAsStringNl gr - -diagTest :: String -> RDFGraph -> String -> Test -diagTest lab gr out = - TestList - [ TestCase ( assertEqual ("diag:text:"++lab) out (res "") ) - , TestCase ( assertEqual ("diag:map:"++lab) emptyLookupMap nmap ) - , TestCase ( assertEqual ("diag:gen:"++lab) 0 ngen ) - , TestCase ( assertEqual ("diag:trc:"++lab) [] trc ) - ] - where - (res,nmap,ngen,trc) = formatGraphDiag gr - -commonPrefixes = - "@prefix base1: <" ++ nsURI base1 ++ "> .\n" ++ - "@prefix base2: <" ++ nsURI base2 ++ "> .\n" ++ - "@prefix base3: <" ++ nsURI base3 ++ "> .\n" ++ - "@prefix base4: <" ++ nsURI base4 ++ "> .\n" - --- Single statement using form -simpleN3Graph_g1_01 = - " " ++ - " " ++ - " .\n" - --- Single statement using prefix:name form -simpleN3Graph_g1_02 = - commonPrefixes ++ - "base1:s1 base1:p1 base1:o1 .\n" - --- Single blank node -simpleN3Graph_g1_03 = - commonPrefixes ++ - "_:b1 base1:p1 base1:o1 .\n" - --- Single auto-allocated blank node -simpleN3Graph_g1_04 = - commonPrefixes ++ - "_:_1 base1:p1 base1:o1 .\n" - --- Single literal object -simpleN3Graph_g1_05 = - commonPrefixes ++ - "base1:s1 base1:p1 \"l1\" .\n" - --- Single multiline literal object -simpleN3Graph_g1_06 = - commonPrefixes ++ - "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 = - commonPrefixes ++ - "base1:s1 base1:p1 _:b2 .\n"++ - "_:b2 :-\n"++ - " {\n"++ - " base1:s1 base1:p1 base1:o1\n"++ - " } .\n" - --- Three blank nodes (or is that blind mice?) -simpleN3Graph_g1_09 = - commonPrefixes ++ - "_:b1 _:b2 _:b3 .\n" - --- Simple nested foprmula case -simpleN3Graph_g1_10 = - commonPrefixes ++ - "base1:s1 base1:p1 _:b3 .\n" ++ - "_:b3 :-\n" ++ - " {\n" ++ - " base1:s1 base1:p1 _:b2 .\n" ++ - " _:b2 :-\n" ++ - " {\n" ++ - " base1:s1 base1:p1 base1:o1\n" ++ - " }\n" ++ - " } .\n" - --- Simple troublesome case -simpleN3Graph_x13a = - commonPrefixes ++ - "base1:s1 _:_1 ;\n"++ - " _:_2 .\n"++ - "_:_1 base1:p1 base1:o1 .\n"++ - "_:_3 base1:p1 base2:o2 .\n"++ - "_:_4 base1:p1 base3:o3 .\n"++ - "_:_2 _:_3 ;\n"++ - " _:_5 .\n"++ - "_:_5 _:_4 ;\n"++ - " .\n" - -trivialTest01 = formatTest "trivialTest01" g1np simpleN3Graph_g1_01 -trivialTest02 = formatTest "trivialTest02" g1 simpleN3Graph_g1_02 -trivialTest03 = formatTest "trivialTest03" g1b1 simpleN3Graph_g1_03 -trivialTest04 = formatTest "trivialTest04" g1a1 simpleN3Graph_g1_04 -trivialTest05 = formatTest "trivialTest05" g1l1 simpleN3Graph_g1_05 -trivialTest06 = formatTest "trivialTest06" g1l2 simpleN3Graph_g1_06 -trivialTest07 = formatTest "trivialTest07" g1f1 simpleN3Graph_g1_07 -trivialTest08 = formatTest "trivialTest08" g1f2 simpleN3Graph_g1_08 -trivialTest09 = formatTest "trivialTest09" g1b3 simpleN3Graph_g1_09 -trivialTest10 = formatTest "trivialTest10" g1f3 simpleN3Graph_g1_10 -trivialTest13 = formatTest "trivialTest13" x13a simpleN3Graph_x13a - -diag13 = diagTest "trivialTest13" x13a simpleN3Graph_x13a - -trivialTestSuite = TestList - [ trivialTest01 - , trivialTest02 - , trivialTest03 - , trivialTest04 - , trivialTest05 - , trivialTest06 - , trivialTest07 - , trivialTest08 - , trivialTest09 - , trivialTest10 - , trivialTest13 - ] - ------------------------------------------------------------- --- Parser tests to cross-check round-trip testing ------------------------------------------------------------- - -parseTest :: String -> String -> 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 parseN3fromString inp of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - -noError = "" -errorText = "*" - -parseTest01 = parseTest "01" simpleN3Graph_g1_01 g1np noError -parseTest02 = parseTest "02" simpleN3Graph_g1_02 g1 noError -parseTest03 = parseTest "03" simpleN3Graph_g1_03 g1b1 noError -parseTest04 = parseTest "04" simpleN3Graph_g1_04 g1a1 noError -parseTest05 = parseTest "05" simpleN3Graph_g1_05 g1l1 noError -parseTest06 = parseTest "06" simpleN3Graph_g1_06 g1l2 noError -parseTest07 = parseTest "07" simpleN3Graph_g1_07 g1f1 noError -parseTest08 = parseTest "08" simpleN3Graph_g1_08 g1f2 noError - -parseTestSuite = TestList - [ parseTest01 - , parseTest02 - , parseTest03 - , parseTest04 - , parseTest05 - , parseTest06 - , parseTest07 - , parseTest08 - ] - ------------------------------------------------------------- --- 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 = formatGraphAsString gr - (pe,pg) = case parseN3fromString out of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - --- 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 -> String -> Test -fullRoundTripTest lab grstr = - TestList - [ TestCase ( assertEqual ("FullRoundTrip:gr:"++lab) gr pg ) - , TestCase ( assertEqual ("FullRoundTrip:er:"++lab) "" pe ) - -- , TestCase ( assertEqual ("FullRoundTrip:"++lab) "" out ) - ] - where - (ge,gr) = case parseN3fromString grstr of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - out = formatGraphAsString gr - (pe,pg) = case parseN3fromString out of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - -roundTripTest01 = roundTripTest "01" g1np -roundTripTest02 = roundTripTest "02" g1 -roundTripTest03 = roundTripTest "03" g1b1 -roundTripTest04 = roundTripTest "04" g1a1 -roundTripTest05 = roundTripTest "05" g1l1 -roundTripTest06 = roundTripTest "06" g1l2 -roundTripTest07 = roundTripTest "07" g1f1 -roundTripTest08 = roundTripTest "08" g1f2 -roundTripTest11 = fullRoundTripTest "11" simpleN3Graph_g1_01 -roundTripTest12 = fullRoundTripTest "12" simpleN3Graph_g1_02 -roundTripTest13 = fullRoundTripTest "13" simpleN3Graph_g1_03 -roundTripTest14 = fullRoundTripTest "14" simpleN3Graph_g1_04 -roundTripTest15 = fullRoundTripTest "15" simpleN3Graph_g1_05 -roundTripTest16 = fullRoundTripTest "16" simpleN3Graph_g1_06 -roundTripTest17 = fullRoundTripTest "17" simpleN3Graph_g1_07 -roundTripTest18 = fullRoundTripTest "18" simpleN3Graph_g1_08 - -roundTripTestSuite = TestList - [ roundTripTest01 - , roundTripTest02 - , roundTripTest03 - , roundTripTest04 - , roundTripTest05 - , roundTripTest06 - , roundTripTest07 - , roundTripTest08 - , roundTripTest11 - , roundTripTest12 - , roundTripTest13 - , roundTripTest14 - , roundTripTest15 - , roundTripTest16 - , roundTripTest17 - , roundTripTest18 - ] - ------------------------------------------------------------- --- 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) - -simpleTest01 = simpleTest "01" g2 -simpleTest02 = simpleTest "02" g3 -simpleTest03 = simpleTest "03" g4 -simpleTest04 = simpleTest "04" g5 -simpleTest05 = simpleTest "05" g6 -simpleTest06 = simpleTest "06" g7 -simpleTest07 = simpleTest "07" g8 -simpleTest08 = simpleTest "08" g81 -simpleTest09 = simpleTest "09" g82 -simpleTest10 = simpleTest "10" g83 -simpleTest11 = simpleTest "11" g9 -simpleTest12 = simpleTest "12" g10 -simpleTest13 = simpleTest "13" g11 - -simpleTestSuite = TestList - [ simpleTest01 - , simpleTest02 - , simpleTest03 - , simpleTest04 - , simpleTest05 - , simpleTest06 - , simpleTest07 - , simpleTest08 - , simpleTest09 - , simpleTest10 - , simpleTest11 - , simpleTest12 - , simpleTest13 - ] - ------------------------------------------------------------- --- Exotic parser tests ------------------------------------------------------------- --- --- These tests cover various forms of anonymous nodes --- [...], lists and formulae. together with uses of ':-' --- - --- 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 = formatGraphAsString gr - (pe,pg) = case parseN3fromString out of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - --- Simple anon nodes, with semicolons and commas -exoticN3Graph_x1 = - 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 = - commonPrefixes ++ - " [ 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 ] = base1:s1 . \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" - --- 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 = - commonPrefixes ++ - " base1:s1 = (base1:o1 base2:o2 base3:o3 \"l1\") .\n" - -exoticN3Graph_x5 = - commonPrefixes ++ - " (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, with and without :- - -exoticN3Graph_x7 = - 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 . " - -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 = - 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" - --- 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" - --- 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 -exoticParseTest01 = parseTest "exoticParseTest01" exoticN3Graph_x1 x1 noError -exoticParseTest02 = parseTest "exoticParseTest02" exoticN3Graph_x2 x2 noError -exoticParseTest03 = parseTest "exoticParseTest03" exoticN3Graph_x3 x3 noError -exoticParseTest04 = parseTest "exoticParseTest04" exoticN3Graph_x4 x4 noError -exoticParseTest05 = parseTest "exoticParseTest05" exoticN3Graph_x5 x5 noError -exoticParseTest06 = parseTest "exoticParseTest06" exoticN3Graph_x6 x6 noError -exoticParseTest07 = parseTest "exoticParseTest07" exoticN3Graph_x7 x7 noError -exoticParseTest08 = parseTest "exoticParseTest08" exoticN3Graph_x8 x8 noError -exoticParseTest09 = parseTest "exoticParseTest09" exoticN3Graph_x9 x9 noError -exoticParseTest12 = parseTest "exoticParseTest12" exoticN3Graph_x12 x12 noError -exoticParseTest13 = parseTest "exoticParseTest13" exoticN3Graph_x13 x13 noError -exoticParseTest13a = parseTest "exoticParseTest13a" exoticN3Graph_x13 x13a noError -exoticParseTest14 = parseTest "exoticParseTest14" exoticN3Graph_x14 x14 noError -exoticParseTest15 = parseTest "exoticParseTest15" exoticN3Graph_x15 x15 noError -exoticParseTest16 = parseTest "exoticParseTest16" exoticN3Graph_x16 x16 noError -exoticParseTest17 = parseTest "exoticParseTest17" exoticN3Graph_x17 x17 noError - -exoticTest01 = exoticTest "01" x1 -exoticTest02 = exoticTest "02" x2 -exoticTest03 = exoticTest "03" x3 -exoticTest04 = exoticTest "04" x4 -exoticTest05 = exoticTest "05" x5 -exoticTest06 = exoticTest "06" x6 -exoticTest07 = exoticTest "07" x7 -exoticTest08 = exoticTest "08" x8 -exoticTest09 = exoticTest "09" x9 -exoticTest10 = testGraphEq "exoticTest10" False x7 x8 -exoticTest11 = testGraphEq "exoticTest11" False x8 x9 -exoticTest12 = exoticTest "12" x12 -exoticTest13 = exoticTest "13" x13 -exoticTest13a = exoticTest "13a" x13a -exoticTest14 = exoticTest "14" x14 -exoticTest15 = exoticTest "15" x15 -exoticTest16 = exoticTest "16" x16 -exoticTest17 = exoticTest "17" x17 - -exoticRoundTripTest01 = fullRoundTripTest "Exotic01" exoticN3Graph_x1 -exoticRoundTripTest02 = fullRoundTripTest "Exotic02" exoticN3Graph_x2 -exoticRoundTripTest03 = fullRoundTripTest "Exotic03" exoticN3Graph_x3 -exoticRoundTripTest04 = fullRoundTripTest "Exotic04" exoticN3Graph_x4 -exoticRoundTripTest05 = fullRoundTripTest "Exotic05" exoticN3Graph_x5 -exoticRoundTripTest06 = fullRoundTripTest "Exotic06" exoticN3Graph_x6 -exoticRoundTripTest07 = fullRoundTripTest "Exotic07" exoticN3Graph_x7 -exoticRoundTripTest08 = fullRoundTripTest "Exotic08" exoticN3Graph_x8 -exoticRoundTripTest09 = fullRoundTripTest "Exotic09" exoticN3Graph_x9 -exoticRoundTripTest12 = fullRoundTripTest "Exotic12" exoticN3Graph_x12 -exoticRoundTripTest13 = fullRoundTripTest "Exotic13" exoticN3Graph_x13 -exoticRoundTripTest14 = fullRoundTripTest "Exotic14" exoticN3Graph_x14 -exoticRoundTripTest15 = fullRoundTripTest "Exotic15" exoticN3Graph_x15 -exoticRoundTripTest16 = fullRoundTripTest "Exotic16" exoticN3Graph_x16 -exoticRoundTripTest17 = fullRoundTripTest "Exotic17" exoticN3Graph_x17 -exoticRoundTripTest18 = fullRoundTripTest "Exotic18" exoticN3Graph_x18 - -exoticTestSuite = TestList - [ exoticParseTest01 - , exoticParseTest02 - , exoticParseTest03 - , exoticParseTest04 - , exoticParseTest05 - , exoticParseTest06 - , exoticParseTest07 - , exoticParseTest08 - , exoticParseTest09 - , exoticParseTest12 - , exoticParseTest13 - , exoticParseTest13a - , exoticParseTest14 - , exoticParseTest15 - , exoticParseTest16 - , exoticParseTest17 - , exoticTest01 - , exoticTest02 - , exoticTest03 - , exoticTest04 - , exoticTest05 - , exoticTest06 - , exoticTest07 - , exoticTest08 - , exoticTest09 - , exoticTest10 - , exoticTest11 - , exoticTest12 - , exoticTest13 - , exoticTest13a - , exoticTest14 - , exoticTest15 - , exoticTest16 - , exoticTest17 - , exoticRoundTripTest01 - , exoticRoundTripTest02 - , exoticRoundTripTest03 - , exoticRoundTripTest04 - , exoticRoundTripTest05 - , exoticRoundTripTest06 - , exoticRoundTripTest07 - , exoticRoundTripTest08 - , exoticRoundTripTest09 - , exoticRoundTripTest12 - , exoticRoundTripTest13 - , exoticRoundTripTest14 - , exoticRoundTripTest15 - , exoticRoundTripTest16 - , exoticRoundTripTest17 - , exoticRoundTripTest18 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ trivialTestSuite - , parseTestSuite - , roundTripTestSuite - , simpleTestSuite - , exoticTestSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/N3FormatterTest.hs,v $ --- $Author: graham $ --- $Revision: 1.21 $ --- $Log: N3FormatterTest.hs,v $ --- Revision 1.21 2004/01/09 12:57:08 graham --- Remove space between perfix and ':' in @prefix declaractions, --- for compatibility with new Notation 3 syntax (and Jena). --- --- Revision 1.20 2004/01/09 12:44:52 graham --- Fix up N3Formatter to suppress final statement-terminating '.' in a formula, --- for compatibility with the current Notation3 syntax. --- --- Revision 1.19 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.18 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.17 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.16 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.15 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.14 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.13 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.12 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.11 2003/07/01 14:18:57 graham --- Allow blank node in predicate position. --- Add parser and formatter test case for this. --- --- Revision 1.10 2003/06/25 21:16:52 graham --- Reworked N3 formatting logic to support proof display. --- Basic proof display is working. --- --- Revision 1.9 2003/06/12 00:47:55 graham --- Allowed variable node (?v) and bare anonymous nodes in N3 parser. --- --- Revision 1.8 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.7 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.6 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.5 2003/05/23 00:02:42 graham --- Fixed blank node id generation bug in N3Formatter --- --- Revision 1.4 2003/05/14 22:39:23 graham --- Initial formatter tests all run OK. --- The formatter could still use so,me improvement, --- but it --- passes the minimal round-tripping tests. --- --- Revision 1.3 2003/05/14 19:38:32 graham --- Simple formatter tests all working with reworked graph and lookup structures. --- More complex formatter tests still to be coded. --- --- Revision 1.2 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.1 2003/04/30 12:14:08 graham --- Add formetter test to CVS --- Noted problem with RDFGraph structure: preparing to rework --- --- diff --git a/Swish/HaskellRDF/N3Parser.hs b/Swish/HaskellRDF/N3Parser.hs deleted file mode 100644 --- a/Swish/HaskellRDF/N3Parser.hs +++ /dev/null @@ -1,1104 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: N3Parser.hs,v 1.36 2004/01/22 19:52:41 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3Parser --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module implements a Notation 3 parser (see [1], [2]), returning a --- new RDFGraph consisting of triples and namespace information parsed from --- the supplied N3 input string, or an error indication. --- --- Uses the Parsec monadic parser library. --- --- --- REFERENCES: --- --- [1] http://www.w3.org/DesignIssues/Notation3.html --- Tim Berners-Lee's design issues series notes and description --- --- [2] http://www.w3.org/2000/10/swap/Primer.html --- Notation 3 Primer by Sean Palmer --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.N3Parser - ( ParseResult - , parseN3fromString - , parseAnyfromString - , parseTextFromString, parseAltFromString - , parseNameFromString, parsePrefixFromString - , parseAbsURIrefFromString, parseLexURIrefFromString, parseURIref2FromString - -- Exports for parsers that embed Notation3 in a bigger syntax - , N3Parser, N3State(..) - , whiteSpace, symbol, lexeme, eof, identStart, identLetter - , defaultPrefix, namedPrefix - , document, subgraph, uriRef2, varid, lexUriRef - , newBlankNode - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , NamespaceMap - , LookupFormula(..) - , addArc - , setFormula - , setNamespaces - , emptyRDFGraph - ) - -import Swish.HaskellRDF.GraphClass - ( arc ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) - , mapFind, mapReplace, mapReplaceOrAdd ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix - , getScopedNameURI - , makeScopedName, makeUriScopedName - , nullScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceRDFO - , namespaceOWL - , langName - , rdf_type - , rdf_first, rdf_rest, rdf_nil - , owl_sameAs - , operator_plus, operator_minus, operator_slash, operator_star - , default_base - ) - -import Swish.HaskellUtils.ProcessURI - ( isAbsoluteURIRef, isValidURIRef, absoluteUriPart ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(Error,Result) ) - -import Swish.HaskellRDF.ParsecLanguage - ( emptyDef ) - -import Text.ParserCombinators.Parsec - -import qualified Text.ParserCombinators.Parsec.Token as P - -import Data.Char - ( chr, digitToInt ) - - ----------------------------------------------------------------------- --- Set up token parsers ----------------------------------------------------------------------- - -pythonStyle = - emptyDef - { P.commentStart = "" - , P.commentEnd = "" - , P.commentLine = "#" - , P.nestedComments = True - , P.identStart = letter <|> char '_' -- oneOf "_" - , P.identLetter = alphaNum <|> char '_' - , P.reservedNames = [] - , P.reservedOpNames= [] - , P.caseSensitive = True - } - -lexer :: P.TokenParser N3State -lexer = P.makeTokenParser pythonStyle - -whiteSpace = P.whiteSpace lexer -symbol = P.symbol lexer -lexeme = P.lexeme lexer - -identStart = P.identStart pythonStyle -identLetter = P.identLetter pythonStyle - ----------------------------------------------------------------------- --- Define parser state and helper functions ----------------------------------------------------------------------- - --- N3 parser state -data N3State = N3State - { graphState :: RDFGraph -- Graph under construction - , thisNode :: RDFLabel -- current context node (aka 'this') - , prefixUris :: NamespaceMap -- namespace prefix mapping table - , syntaxUris :: SpecialMap -- special name mapping table - , nodeGen :: Int -- blank node id generator - } - --- Type for special name lookup table -type SpecialMap = LookupMap (String,ScopedName) - --- Functions to update N3State vector (use with Parsec updateState) -setPrefix :: String -> String -> N3State -> N3State -setPrefix pre uri st = st { prefixUris=p' } - where - p' = mapReplaceOrAdd (Namespace pre uri) (prefixUris st) - --- Set name for special syntax element -setSName :: String -> ScopedName -> N3State -> N3State -setSName nam snam st = st { syntaxUris=s' } - where - s' = mapReplaceOrAdd (nam,snam) (syntaxUris st) -setSUri :: String -> String -> N3State -> N3State -setSUri nam suri = setSName nam (makeScopedName "" suri "") - --- Get name for special syntax element, default null -getSName :: N3State -> String -> ScopedName -getSName st nam = mapFind nullScopedName nam (syntaxUris st) - -getSUri :: N3State -> String -> String -getSUri st nam = getScopedNameURI $ getSName st nam - --- Lookup prefix in table and return URI or 'prefix:' -mapPrefix :: NamespaceMap -> String -> String -mapPrefix ps pre = mapFind (pre++":") pre ps - --- Functions to access state: --- Map prefix to namespace -getPrefixNs :: N3State -> String -> Namespace -getPrefixNs st pre = Namespace pre (mapPrefix (prefixUris st) pre) - --- Map ScopedName using prefix table --- (Ignore URI in supplied ScopedName) -getPrefixScopedName :: N3State -> ScopedName -> ScopedName -getPrefixScopedName st snam = ScopedName (getPrefixNs st pre) loc - where - pre = getScopePrefix snam - loc = snLocal snam - --- Return function to update graph in N3 parser state, --- using the supplied function of a graph --- (use returned function with Parsec updateState) -updateGraph :: ( RDFGraph -> RDFGraph ) -> ( N3State -> N3State ) -updateGraph f s = s { graphState = f (graphState s) } - --- Define default table of namespaces -prefixTable = [ namespaceRDF - , namespaceRDFS - , namespaceRDFD -- datatypes - , namespaceRDFO -- operators - , namespaceOWL - ] - --- Define default special-URI table -specialTable :: [(String,ScopedName)] -specialTable = [ ( "a", rdf_type ), - ( "equals", owl_sameAs ), - ( "listfirst", rdf_first ), - ( "listrest", rdf_rest ), - ( "listnull", rdf_nil ), - ( "plus", operator_plus ), - ( "minus", operator_minus ), - ( "slash", operator_slash ), - ( "star", operator_star ), - ( "base", default_base ) ] - ----------------------------------------------------------------------- --- Define top-level parser function: --- accepts a string and returns a graph or error ----------------------------------------------------------------------- - -type N3Parser a = GenParser Char N3State a - -type ParseResult = ErrorM RDFGraph -- PResult RDFGraph | PError String - -parseN3fromString :: String -> ParseResult -parseN3fromString input = - case parseAnyfromString document Nothing input of - Left err -> Error err - Right gr -> Result gr - --- Function to supply initial context and parse supplied term --- --- parser is parser to apply --- base is base URI of the input, or Nothing to use default base value --- input is the input to be parsed --- -parseAnyfromString :: N3Parser a -> Maybe String -> String -> (Either String a) -parseAnyfromString parser base input = - let - pmap = LookupMap prefixTable - smap = LookupMap specialTable - bmap = case base of - Nothing -> smap - Just bs -> mapReplace smap ("base",makeUriScopedName bs) - pstate = N3State - { graphState = emptyRDFGraph - , thisNode = NoNode - , prefixUris = pmap - , syntaxUris = bmap - , nodeGen = 0 - } - result = runParser parser pstate "" input - in - case result of - Left err -> Left (show err) - Right res -> Right res - -newBlankNode :: N3Parser RDFLabel -newBlankNode = - do { s <- getState - ; let n = (nodeGen s) + 1 - ; setState ( s { nodeGen = n } ) - ; return (Blank (show n)) - } - --- Test functions for selected element parsing - -parseTextFromString :: String -> String -> (Either String String) -parseTextFromString s = - parseAnyfromString (string s) Nothing - -parseAltFromString :: String -> String -> String -> (Either String String) -parseAltFromString s1 s2 = - parseAnyfromString ( (string s1) <|> (string s2) ) Nothing - -parseNameFromString :: String -> (Either String String) -parseNameFromString = - parseAnyfromString name Nothing - -parsePrefixFromString :: String -> (Either String Namespace) -parsePrefixFromString = - parseAnyfromString prefix Nothing - -parseAbsURIrefFromString :: String -> (Either String String) -parseAbsURIrefFromString = - parseAnyfromString absUriRef Nothing - -parseLexURIrefFromString :: String -> (Either String String) -parseLexURIrefFromString = - parseAnyfromString lexUriRef Nothing - -parseURIref2FromString :: String -> (Either String ScopedName) -parseURIref2FromString = - parseAnyfromString uriRef2 Nothing - ----------------------------------------------------------------------- --- Syntax productions ----------------------------------------------------------------------- - --- document = directive* statement-list - -document :: N3Parser RDFGraph -document = - do { whiteSpace - ; many directive - ; statements - ; eof - ; s <- getState - ; return $ setNamespaces (prefixUris s) (graphState s) - } - - --- directive = "@prefix" prefix ":" uriRef2 "." // Namespace declaration --- | "@prefix" ":" uriRef2 "." // Default namespace --- | "@equivalence" uriRef2 "." // Alternative to daml:equivalent --- | "@listfirst" uriRef2 "." // Alternative to n3:first --- | "@listrest" uriRef2 "." // Alternative to n3:rest --- | "@listnull" uriRef2 "." // Alternative to n3:null --- | "@plus" uriRef2 "." // Alternative to operator:plus --- | "@minus" uriRef2 "." // Alternative to operator:minus --- | "@slash" uriRef2 "." // Alternative to operator:slash --- | "@star" uriRef2 "." // Alternative to operator:star --- | "@base" uriRef2 "." // Base URI for relative URIs. - -directive :: N3Parser () -directive = - do { try $ symbol "@prefix" - ; ( defaultPrefix <|> namedPrefix ) - } - <|> - do { string "@" -- not lexeme - ; syntaxUri - } - - "directive" - -defaultPrefix :: N3Parser () -defaultPrefix = - do { symbol ":" - ; u <- uriRef2 - ; symbol "." - ; updateState $ setPrefix "" (getScopedNameURI u) - } - -namedPrefix :: N3Parser () -namedPrefix = - do { n <- name - ; symbol ":" - ; u <- uriRef2 - ; symbol "." - ; updateState $ setPrefix n (getScopedNameURI u) - } - -syntaxUri :: N3Parser () -syntaxUri = - do { s <- uriName - ; u <- uriRef2 - ; symbol "." - ; updateState $ setSUri s (getScopedNameURI u) - } - -uriName :: N3Parser String -uriName = - (try $ symbol "equivalence") - <|> (try $ symbol "listfirst") - <|> (try $ symbol "listrest") - <|> (try $ symbol "listnull") - <|> (try $ symbol "plus") - <|> (try $ symbol "minus") - <|> (try $ symbol "slash") - <|> (try $ symbol "star") - <|> (try $ symbol "base") - "special URI directive" - - --- statements = [ statement ( "." statement )* ] --- --- statement = subject property-list --- --- properties = [ property ( ";" property )* ] --- --- New statements are added to the user state graph - -statements :: N3Parser () -statements = - do { sepEndBy1 statement (symbol ".") - ; return () - } - -statement :: N3Parser () -statement = - do { subj <- subject - ; optional $ properties subj - } - -properties :: RDFLabel -> N3Parser () -properties subj = - do { sepBy1 (property subj) (symbol ";") - ; return () - } - - --- property = verb object-list --- | ":-" anon-node // Creates anon-node aongside the current node --- verb = ">-" prop "->" // has 'prop' of --- | "<-" prop "<-" // is 'prop' of --- | operator // has operator:'operator' of (???) --- | prop // has 'prop' of -- shorthand --- | "has" prop "of" // has 'prop' of --- | "is" prop "of" // is 'prop' of --- | "a" // has rdf:type of --- | "=" // has daml:equivalent of --- --- subj is the subject node for these properties. --- --- New statements are added to the graph in the parser's user state. - -property :: RDFLabel -> N3Parser () -property subj = - do { (prop,swap) <- verb - ; objects subj prop swap - } - <|> - do { symbol ":-" - ; anonNode subj - ; return () - } - -verb :: N3Parser (RDFLabel,Bool) -verb = do { p <- prop ; return (p,False) } - <|> do { p <- operator ; return (p,False) } - <|> do { symbol ">-" ; p <- prop ; symbol "->" ; return (p,False) } - <|> do { symbol "<-" ; p <- prop ; symbol "<-" ; return (p,True) } - <|> do { symbol "has" ; p <- prop ; symbol "of" ; return (p,False) } - <|> do { symbol "is" ; p <- prop ; symbol "of" ; return (p,True) } - <|> do { symbol "a" - ; lab <- operatorLabel rdf_type - ; return (lab,False) - } - <|> do { symbol "=" - ; lab <- operatorLabel owl_sameAs - ; return (lab,False) - } - "property" - - --- objects = object --- | object "," object-list --- --- subj is the subject node for the new statements, --- prop is the property node for the new statements. --- swap is true if the subject/object values in the resulting statement --- are to be swapped (for "is of", etc.) --- --- New statements are added to the graph in the parser's user state - -objects :: RDFLabel -> RDFLabel -> Bool -> N3Parser () -objects subj prop swap = - do { sepBy1 (object subj prop swap) (symbol ",") - ; return () - } - --- anonNode = "[" property-list "]" // Something with given properties --- | "{" statement-list "}" // List of statements as resource --- | "(" node-list ")" // Construct list with --- // rdf:first, rdf:rest, rdf:nil --- --- subj is the subject node with which the new anonymous node is equated, --- --- The anonymous node value is returned by this parser (which is often the same --- as the supplied subject node, but not always). --- --- New statements are added to the graph in the parser's user state --- (in the case of a formula, a new graph and parser are created, and --- the graph arcs are added to this new graph). - -anonNode :: RDFLabel -> N3Parser RDFLabel -anonNode subj = - do { symbol "[" ; properties subj ; symbol "]" ; return subj } - <|> do { symbol "{" ; form <- formula subj ; symbol "}" ; return form } - <|> do { symbol "(" ; list <- nodeList subj ; symbol ")" ; return list } - "anon node (\"[\", \"(\" or \"{\")" - --- This method allows a statement list to be parsed as a subgraph --- whose value is associated with the supplied node of the current --- graph. - -formula :: RDFLabel -> N3Parser RDFLabel -formula subj = - do { subgr <- subgraph subj - ; updateState $ updateGraph - $ setFormula (Formula subj subgr) - ; return subj - } - -subgraph :: RDFLabel -> N3Parser RDFGraph -subgraph this = - do { pstate <- getState - ; let fstate = pstate { graphState = emptyRDFGraph, thisNode = this } - ; setState fstate -- switch new state into parser - ; statements -- parse statements of formula - ; fstate' <- getState - ; let nstate = pstate { nodeGen = (nodeGen fstate') } - ; setState nstate -- swap back state, with updated nodeGen - ; return (graphState fstate') - } - --- prop = uri-ref2 --- | varid --- --- Returns URI value as a Node - -prop :: N3Parser RDFLabel -prop = nodeid <|> varid <|> uriNode - - --- operator = "+" // >- operator:plus -> --- | "-" // >- operator:minus -> --- | "/" // >- operator:slash -> --- | "*" // >- operator:star-> --- --- If matched, the operator is returned as a node value. - -operator :: N3Parser RDFLabel -operator = - do { symbol "+" ; operatorLabel operator_plus } - <|> do { symbol "-" ; operatorLabel operator_minus } - <|> do { symbol "*" ; operatorLabel operator_star } - <|> do { symbol "/" ; operatorLabel operator_slash } - "" - -operatorLabel :: ScopedName -> N3Parser RDFLabel -operatorLabel snam = - do { s <- getState - ; return $ Res (getPrefixScopedName s snam) - } - --- subject = node - -subject :: N3Parser RDFLabel -subject = node - - --- object = litNode --- --- This production adds a new triple to the graph state, --- using the supplied subject and propert values. --- If swap is True, the subject and object positions are --- swapped. - -object :: RDFLabel -> RDFLabel -> Bool -> N3Parser () -object subj prop swap = - do { o <- litNode - ; if swap then (addStatement o prop subj) - else (addStatement subj prop o) - } - --- Add statement to graph in N3 parser state - -addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> N3Parser () -addStatement s p o = updateState (updateGraph (addArc (arc s p o) )) - - --- nodeList = litNode* --- --- subj is the node from which the list is linked. --- --- Returns the supplied head of list or Nil node allocated. --- --- Link first element of link to list head, scan rest of list, --- and return the list head; otherwise return a node rdf_null. --- --- This slightly convoluted pattern is to deal with two different --- occurrences of a list node: --- :- ( l1, l2, ... ) --- Here, (the supplied subj) is the listhead. --- prop ( l1, l2, ... ) --- Here, the a new blank is supplied as subj to be the listhead. --- In either case, if the list is non-empty, the supplied subj --- is returned. But if the list is empty, a rdf_null node is returned. --- In the second case, the invoking production must use the returned --- value. - -nodeList :: RDFLabel -> N3Parser RDFLabel -nodeList subj = - do { val <- litNode - ; first <- operatorLabel rdf_first - ; addStatement subj first val - ; nodeList1 subj - ; return subj - } - <|> do { nil <- operatorLabel rdf_nil - ; return nil - } - "Node or ')'" - -nodeList1 :: RDFLabel -> N3Parser () -nodeList1 prev = - do { val <- litNode - ; lnk <- newBlankNode - ; first <- operatorLabel rdf_first - ; rest <- operatorLabel rdf_rest - ; addStatement lnk first val - ; addStatement prev rest lnk - ; nodeList1 lnk - } - <|> do { nil <- operatorLabel rdf_nil - ; rest <- operatorLabel rdf_rest - ; addStatement prev rest nil - } - "Node or ')'" - - --- lit-node = node --- | str-node [ "@" lang ] [ "^^" uriRef2 ] --- str-node = '"' constant-value '"' --- | '"""' constant value '"""' // Including single or double occurences of --- // quotes and/or newlines --- --- Returns a new node value. - -litNode :: N3Parser RDFLabel -litNode = - node - <|> do { s <- strNode - ; t <- litTypeOrLang - ; return $ Lit s t - } - "URI, blank node or literal" - -strNode :: N3Parser String -strNode = - tripleQuoteString - <|> singleQuoteString - - -litTypeOrLang :: N3Parser (Maybe ScopedName) -litTypeOrLang = - langTag - <|> typeUri - <|> return Nothing - "'@tag' (language tag) or '^^name' (datatype URI)" - -langTag :: N3Parser (Maybe ScopedName) -langTag = - do { string "@" - ; l <- name -- name1 letter - ; return $ Just (langName l) - } - "'@tag' (language tag)" - -typeUri :: N3Parser (Maybe ScopedName) -typeUri = - do { string "^^" - ; u <- uriRef2 - ; return $ Just u - } - "'^^name' (datatype URI)" - --- node = nodeid --- | varid --- | uri-ref2 --- | anon-node --- --- nodeid = "_:" name --- --- varid = "?" name --- --- Returns a new node value. - -node :: N3Parser RDFLabel -node = nodeid - <|> varid - <|> uriNode - <|> do { n <- newBlankNode - ; anonNode n - } - "URI or blank node" - --- Identified blank node in input --- --- Note that automatically generated blank node identifiers start with --- a digit, where input node identifiers start with a letter, so there --- can be no clash. Care is needed when serializing a graph to ensure --- that future clashes are avoided. - -nodeid :: N3Parser RDFLabel --- nodeid = lexeme nodeid1 -nodeid = - do { string "_:" - ; n <- name - ; return (Blank n) - } - --- variable identifier - -varid :: N3Parser RDFLabel -varid = do { string "?" - ; n <- name - ; return (Var n) - } - --- uriNode = qname --- | "<" URI-reference ">" --- | "this" - -uriNode :: N3Parser RDFLabel -uriNode = - do { sn <- uriRef2 ; - ; return ( Res sn ) - } - <|> - do { string "this" - ; s <- getState - ; return ( thisNode s ) - } - "URI node" - - --- uriRef2 = qname --- | ":" local-name --- | "<" URI-reference ">" --- qname = prefix ":" local-name --- --- prefix = name // Namespace prefix --- --- local-name = name // Local name (namespace qualified) --- --- name = alpha alphanumeric* --- --- alpha = "a"-"z" --- | "A"-"Z" --- | "_" --- --- alphanumeric = alpha --- | "0"-"9" --- --- URI-reference = (conforming to syntax in RFC2396) --- --- uriRef2 returns a ScopedName. - -uriRef2 :: N3Parser ScopedName -uriRef2 = ( lexeme $ try uriRef2a ) - "URI or QName" - -uriRef2a = - do { ns <- prefix - ; string ":" - ; local <- localname - ; return $ ScopedName ns local - } - <|> - do { string ":" - ; ns <- defaultprefix - ; local <- localname - ; return $ ScopedName ns local - } - <|> - do { u <- absUriRef - ; return $ makeUriScopedName u - } - "URI or QName" - -prefix :: N3Parser Namespace -prefix = - do { pref <- prefixname - ; st <- getState - ; return (getPrefixNs st pref) -- map prefix to namespace - } - -defaultprefix :: N3Parser Namespace -defaultprefix = - do { st <- getState - ; return (getPrefixNs st "") - } - -name :: N3Parser String -name = lexeme $ name1 identStart - -prefixname :: N3Parser String -prefixname = name1 identStart - -localname :: N3Parser String -localname = lexeme $ name1 identLetter - --- 'name1' is a name without following whitespace --- initChar is a parser for the first character -name1 :: N3Parser Char -> N3Parser String -name1 initChar = - do { c <- initChar - ; cs <- many identLetter - ; return (c:cs) - } - "identifier" - - ----------------------------------------------------------------------- --- Lexical support ----------------------------------------------------------------------- --- --- The following code adapted from ParsecToken, --- modified to handle different escape conventions and triple-quoted strings --- \c --- \uhhhh --- \Uhhhhhhhh --- --- Regular single-quoted string -- cannot be split over line breaks - -singleQuoteString :: N3Parser String -singleQuoteString = - lexeme - ( between (char '"') (char '"' "end of string (\")") anyStringChars - "literal string" ) - -anyStringChars = - do { str <- many stringChar - ; return (foldr (maybe id (:)) "" str) - } - --- Triple-quoted string -- may include line breaks, '"' or '""'. -tripleQuoteString :: N3Parser String -tripleQuoteString = - lexeme - ( do { str <- between (try $ string "\"\"\"") - (string "\"\"\"" "end of string (\"\"\")") - (many tripleQuoteSubstring) - ; return (foldr (++) "" str) - } - "triple-quoted literal string" ) - --- Match non-quote substring or one or two quote characters -tripleQuoteSubstring :: N3Parser String -tripleQuoteSubstring = - tripleQuoteSubstring1 - <|> try sqTripleQuoteSubstring1 - <|> try dqTripleQuoteSubstring1 - -dqTripleQuoteSubstring1 = - do { string "\"\"" - ; s <- tripleQuoteSubstring1 - ; return $ "\"\""++s - } - -sqTripleQuoteSubstring1 = - do { char '"' - ; s <- tripleQuoteSubstring1 - ; return $ "\""++s - } - --- match at least one non-quote character in a triple-quoted string -tripleQuoteSubstring1 :: N3Parser String -tripleQuoteSubstring1 = - do { str <- many1 tripleQuoteStringChar - ; return $ foldr (maybe id (:)) "" str - } - -tripleQuoteStringChar :: CharParser st (Maybe Char) -tripleQuoteStringChar = - stringChar - <|> do { (string "\n") - ; return $ Just '\n' - } - -stringChar :: CharParser st (Maybe Char) -stringChar = - do { c <- stringLetter - ; return $ Just c - } - <|> stringEscape - "string character" - -stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c >= '\032')) - -stringEscape = - do { char '\\' - ; do { esc <- escapeCode; return (Just esc) } - } - --- escape codes -escapeCode = charEsc <|> charUCS2 <|> charUCS4 "escape code" - --- \c -charEsc = choice (map parseEsc escMap) - where - parseEsc (c,code) = do { char c; return code } - escMap = zip ("nrt\\\"\'") ("\n\r\t\\\"\'") - --- \uhhhh -charUCS2 = - do { char 'u' - ; n <- numberFW 16 hexDigit 4 0 - ; return $ chr n - } - --- \Uhhhhhhhh -charUCS4 = - do { char 'U' - ; n <- numberFW 16 hexDigit 8 0 - ; return $ chr n - } - --- parse fixed-width number: -numberFW :: Int -> CharParser st Char -> Int -> Int -> CharParser st Int -numberFW base baseDigit 0 val = return val -numberFW base baseDigit width val = - do { d <- baseDigit - ; numberFW base baseDigit (width-1) ((val*base) + (digitToInt d)) - } - - ----------------------------------------------------------------------- --- Parse a URI reference from the input --- The result returned has absolute form; relative URIs are resolved --- relative to the current base prefix (set using "@base"). --- --- [[[TODO: rework the URI parser to use the Parsec library]]] - --- lexeme version -lexUriRef :: N3Parser String -lexUriRef = lexeme absUriRef - -absUriRef :: N3Parser String -absUriRef = - do { u <- between (char '<') (char '>' "end of URI '>'") anyUriChars - ; if (isAbsoluteURIRef u) - then (return u) - else - if (isValidURIRef u) - then - do { s <- getState - ; (return $ absoluteUriPart (getSUri s "base") u) - } - else (fail ("Invalid URI: <"++u++">")) - } - -anyUriChars :: N3Parser String -anyUriChars = many uriChar - -uriChar :: N3Parser Char -uriChar = - alphaNum - <|> oneOf "[];?:@&=+$,-_.!~*'()%//#" - "URI character" - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/N3Parser.hs,v $ --- $Author: graham $ --- $Revision: 1.36 $ --- $Log: N3Parser.hs,v $ --- Revision 1.36 2004/01/22 19:52:41 graham --- Rename module URI to avoid awkward clash with Haskell libraries --- --- Revision 1.35 2004/01/09 11:23:54 graham --- Fix up N3Parser so that the final statement-terminating '.' in a formula --- or file is optional. --- --- Revision 1.34 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.33 2003/12/20 12:53:40 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.32 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.31 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.30 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.29 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.28 2003/12/03 17:07:23 graham --- Replace occurrences of QName in N3Parser with ScopedName. --- --- Revision 1.27 2003/12/03 15:57:00 graham --- Use common parser wrapper function for all parsing. --- (This will also be used for Swish script parsing.) --- --- Revision 1.26 2003/12/03 15:42:09 graham --- Eliminate special return type in favour of ErrorM --- --- Revision 1.25 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.24 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.23 2003/10/24 21:02:42 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.22 2003/10/09 16:26:31 graham --- Added parser support for literal language tags and datatypes. --- (Language tags are names, not strictly per RFC3066) --- --- Revision 1.21 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.20 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.19 2003/07/01 14:18:57 graham --- Allow blank node in predicate position. --- Add parser and formatter test case for this. --- --- Revision 1.18 2003/06/19 19:48:03 graham --- Allow variable id in predicate position --- --- Revision 1.17 2003/06/12 00:47:56 graham --- Allowed variable node (?v) and bare anonymous nodes in N3 parser. --- --- Revision 1.16 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.15 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.14 2003/05/22 15:16:39 graham --- Added additional parser test cases for lists --- --- Revision 1.13 2003/05/21 13:55:13 graham --- N3 parser now handles relative URIs and default prefixes. --- (Still need to figure better default base URI handling; i.e. current document) --- --- Revision 1.12 2003/05/21 13:34:13 graham --- Various N3 parser bug fixes. --- Need to fix handling of :name terms. --- --- Revision 1.11 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.10 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.9 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.8 2003/04/17 00:35:38 graham --- Added module N3ParserTest --- N3parser is mostly working --- Formulae remain to test --- --- Revision 1.7 2003/04/15 21:40:54 graham --- N3Parser compiles --- Some small changes to RDFGraph --- Added some QName methods --- --- Revision 1.6 2003/04/11 17:38:34 graham --- Rename GraphLookupMap to LookupMap --- --- Revision 1.5 2003/04/10 20:08:39 graham --- Reorganized RDFGraph naming (RDFGraphTest OK) --- Progressing N3Parser --- --- Revision 1.4 2003/03/12 23:00:43 graham --- Graph model coded and working, except for graph isomorphism test. --- --- Revision 1.3 2003/03/12 13:41:59 graham --- N3 parser initial coding done. --- Graph not yet implemented. --- --- Revision 1.2 2003/03/08 17:28:45 graham --- Added string literal parsing code --- --- Revision 1.1 2003/03/07 22:53:38 graham --- Started on N3 parser in Haskell diff --git a/Swish/HaskellRDF/N3ParserTest.hs b/Swish/HaskellRDF/N3ParserTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/N3ParserTest.hs +++ /dev/null @@ -1,1373 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: N3ParserTest.hs,v 1.25 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : N3ParserTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module contains test cases for module N3Parses. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.N3ParserTest where - -import Swish.HaskellRDF.N3Parser - ( ParseResult(..) - , parseN3fromString - , parseTextFromString, parseAltFromString - , parseNameFromString, parsePrefixFromString - , parseAbsURIrefFromString, parseLexURIrefFromString - , parseURIref2FromString - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFTriple, RDFGraph, RDFLabel(..), NSGraph(..) - -- LookupNamespace(..), Namespace - , NamespaceMap, emptyNamespaceMap - , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap - , setArcs, getArcs, add, delete, extract, labels - , setNamespaces - , emptyRDFGraph, toRDFGraph - -- Export selected RDFLabel values - , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil - , res_rdfs_member - , res_rdfd_GeneralRestriction - , res_rdfd_onProperties, res_rdfd_constraint, res_rdfd_maxCardinality - , res_owl_sameAs - , res_operator_plus, res_operator_minus - , res_operator_slash, res_operator_star - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , makeNamespaceQName - , nullNamespace - , getQName, getScopedNameURI - , ScopedName(..) - , makeScopedName, makeQNameScopedName - , nullScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceRDFC - , namespaceRDFO - , namespaceXSD - , namespaceXsdType - , namespaceOWL - , namespaceMATH - , namespaceLOG - , namespaceDAML - , namespaceLang, langName - , rdf_type - , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral - , rdfs_member - , rdfd_GeneralRestriction - , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality - , owl_sameAs - , operator_plus, operator_minus, operator_slash, operator_star - ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) - , mapFind, mapFindMaybe ) - -import Swish.HaskellRDF.GraphClass - ( Arc, arcSubj, arcPred, arcObj, arc ) - -import Swish.HaskellUtils.QName - ( QName(..) ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(..) ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertEqual, runTestTT, runTestText, putTextToHandle ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - ------------------------------------------------------------- --- Common values ------------------------------------------------------------- - -pref_rdf = nsURI namespaceRDF -pref_op = nsURI namespaceRDFO -pref_owl = nsURI namespaceOWL - ------------------------------------------------------------- --- Generic item parsing test wrapper ------------------------------------------------------------- - -type ParseFromString a = String -> (Either String a) - -parseItemTest :: (Eq a, Show a) => ParseFromString a -> a - -> String -> String -> 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 = "*" - ------------------------------------------------------------- --- Common test wrappers ------------------------------------------------------------- - -testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test -testLabelEq lab eq n1 n2 = - TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) - -testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test -testGraphEq lab eq g1 g2 = - TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - -parseTest :: String -> String -> 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 parseN3fromString inp of - Result g -> ("",g) - Error s -> (s,emptyRDFGraph) - ------------------------------------------------------------- --- Test simple character parsing ------------------------------------------------------------- - -parseCharTest :: String -> String - -> String -> String -> String -> Test -parseCharTest c = parseItemTest (parseTextFromString c) "" - -parseAltTest :: String -> String - -> String -> String -> String -> String -> Test -parseAltTest c1 c2 = parseItemTest (parseAltFromString c1 c2) "" - -charInp01 = ":" -char01 = ":" - -charInp02 = "<>" -char02 = "<>" - -charInp03 = "<=" - -parseCharTest01 = parseCharTest char01 - "parseCharTest01" charInp01 char01 noError -parseCharTest02 = parseCharTest char02 - "parseCharTest02" charInp02 char02 noError -parseCharTest03 = parseAltTest char01 char02 - "parseCharTest03" charInp01 char01 noError -parseCharTest04 = parseAltTest char01 char02 - "parseCharTest04" charInp02 char02 noError -parseCharTest05 = parseAltTest char01 char02 - "parseCharTest04" charInp03 "" errorText - -charTestSuite = TestList - [ parseCharTest01 - , parseCharTest02 - , parseCharTest03 - , parseCharTest04 - , parseCharTest05 - ] - ------------------------------------------------------------- --- Test simple name parsing ------------------------------------------------------------- - -parseNameTest :: String -> String -> String -> String -> Test -parseNameTest = parseItemTest parseNameFromString "" - -nameInp01 = "name" -name01 = "name" - -nameInp02 = "rdf" -name02 = "rdf" - -parseNameTest01 = parseNameTest "parseNameTest01" nameInp01 name01 "" -parseNameTest02 = parseNameTest "parseNameTest02" nameInp02 name02 "" - -nameTestSuite = TestList - [ parseNameTest01 - , parseNameTest02 - ] - ------------------------------------------------------------- --- Test simple prefix parsing ------------------------------------------------------------- - -parsePrefixTest :: String -> String -> Namespace -> String -> Test -parsePrefixTest = parseItemTest parsePrefixFromString nullNamespace - -prefixInp01 = "pref" -prefix01 = Namespace "pref" "pref:" - -prefixInp02 = "rdf" -prefix02 = Namespace "rdf" pref_rdf - -parsePrefixTest01 = parsePrefixTest "parsePrefixTest01" prefixInp01 prefix01 "" -parsePrefixTest02 = parsePrefixTest "parsePrefixTest02" prefixInp02 prefix02 "" - -prefixTestSuite = TestList - [ parsePrefixTest01 - , parsePrefixTest02 - ] - ------------------------------------------------------------- --- Test absolute URIref parsing ------------------------------------------------------------- - -parseAbsUriRefTest :: String -> String -> String -> String -> Test -parseAbsUriRefTest = parseItemTest parseAbsURIrefFromString "" - -parseLexUriRefTest :: String -> String -> String -> String -> Test -parseLexUriRefTest = parseItemTest parseLexURIrefFromString "" - -absUriRefInp01 = "" -absUriRefInp01s = " " -absUriRef01 = "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" - -absUriRefInp02 = "" -absUriRefInp02s = " " -absUriRef02 = "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" - -parseAbsUriRefTest01 = parseAbsUriRefTest "parseAbsUriRefTest01" absUriRefInp01 absUriRef01 "" -parseAbsUriRefTest02 = parseAbsUriRefTest "parseAbsUriRefTest02" absUriRefInp02 absUriRef02 "" -parseAbsUriRefTest03 = parseLexUriRefTest "parseAbsUriRefTest03" absUriRefInp01s absUriRef01 "" -parseAbsUriRefTest04 = parseLexUriRefTest "parseAbsUriRefTest04" absUriRefInp02s absUriRef02 "" - -absUriRefTestSuite = TestList - [ parseAbsUriRefTest01 - , parseAbsUriRefTest02 - , parseAbsUriRefTest03 - , parseAbsUriRefTest04 - ] - - ------------------------------------------------------------- --- Test simple URIref parsing ------------------------------------------------------------- - -parseUriRef2Test :: String -> String -> ScopedName -> String -> Test -parseUriRef2Test = parseItemTest parseURIref2FromString nullScopedName - -uriRef01 = "rdf:type " -sname01 = ScopedName namespaceRDF "type" - -uriRef02 = " " -sname02 = - makeScopedName "" "http://id.ninebynine.org/wip/2003/test/graph1/node#" "s1" - -parseUriRef2Test01 = parseUriRef2Test "parseUriRef2Test01" uriRef01 sname01 "" -parseUriRef2Test02 = parseUriRef2Test "parseUriRef2Test02" uriRef02 sname02 "" - -uriRef2TestSuite = TestList - [ parseUriRef2Test01 - , parseUriRef2Test02 - ] - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node/" -base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node#" -base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" -base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" - -qb1s1 = ScopedName base1 "s1" -qb2s2 = ScopedName base2 "s2" -qb3s3 = ScopedName base3 "s3" - -s1 = Res qb1s1 :: RDFLabel -s2 = Res qb2s2 :: RDFLabel -s3 = Res qb3s3 :: RDFLabel - -b1 = Blank "b1" :: RDFLabel -b2 = Blank "b2" :: RDFLabel -b3 = Blank "b3" :: RDFLabel -b4 = Blank "b4" :: RDFLabel -b5 = Blank "b5" :: RDFLabel -b6 = Blank "b6" :: RDFLabel -b7 = Blank "b7" :: RDFLabel -b8 = Blank "b8" :: RDFLabel - -c1 = Blank "c1" :: RDFLabel -c2 = Blank "c2" :: RDFLabel -c3 = Blank "c3" :: RDFLabel -c4 = Blank "c4" :: RDFLabel -c5 = Blank "c5" :: RDFLabel -c6 = Blank "c6" :: RDFLabel - -qb1p1 = ScopedName base1 "p1" -qb2p2 = ScopedName base2 "p2" -qb3p3 = ScopedName base3 "p3" - -p1 = Res qb1p1 :: RDFLabel -p2 = Res qb2p2 :: RDFLabel -p3 = Res qb3p3 :: RDFLabel - -qb1o1 = ScopedName base1 "o1" -qb2o2 = ScopedName base2 "o2" -qb3o3 = ScopedName base3 "o3" - -o1 = Res qb1o1 :: RDFLabel -o2 = Res qb2o2 :: RDFLabel -o3 = Res qb3o3 :: RDFLabel - -l1 = Lit "l1" Nothing :: RDFLabel -l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" Nothing :: RDFLabel -l3 = Lit "l3--\r\"'\\--\x0020\&--\x00A0\&--" Nothing :: RDFLabel - -lfr = Lit "chat" (Just $ langName "fr") :: RDFLabel -lxml = Lit "
" (Just rdf_XMLLiteral ) :: RDFLabel -lfrxml = Lit "chat" (Just rdf_XMLLiteral ) :: RDFLabel -- was: lang "fr" - -qb1f1 = ScopedName base1 "f1" -qb2f2 = ScopedName base2 "f2" - -f1 = Res qb1f1 :: RDFLabel -f2 = Res qb2f2 :: RDFLabel - -v1 = Var "var1" :: RDFLabel -v2 = Var "var2" :: RDFLabel -v3 = Var "var3" :: RDFLabel -v4 = Var "var4" :: RDFLabel - ------------------------------------------------------------- --- Construct graphs for testing ------------------------------------------------------------- - -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 :: (String,Namespace) -> Namespace -makeNewPrefixNamespace (pre,ns) = Namespace pre (nsURI ns) - -nslist = LookupMap $ map makeNewPrefixNamespace - [ ("base1",base1) - , ("base2",base2) - , ("base3",base3) - , ("base4",base4) - ] - -g1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01] - } - -g1b = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01b] - } - -g2 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03] - } - -g3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t04] - } - -g4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t05] - } - -g5 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05] - } - -g6 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t06] - } - -g7 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t07] - } - -t801 = arc s1 res_rdf_type o1 -t802 = arc s2 res_owl_sameAs o2 -t803 = arc s3 res_operator_plus o3 -t804 = arc s3 res_operator_minus o3 -t805 = arc s3 res_operator_star o3 -t806 = arc s3 res_operator_slash o3 -t807 = arc o1 p1 s1 -t808 = arc s2 p1 o2 -t809 = arc s1 p2 o1 -t810 = arc o2 p2 s2 - -g8 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t801,t802,t803,t804,t805,t806,t807,t808,t809,t810] - } - -g81 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t801,t802] - } - -g82 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t803,t804,t805,t806] - } - -g83 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t807,t808,t809,t810] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t911,t912,t913,t914, - t921,t922,t923,t924, - t925,t926,t927,t928] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1011,t1012,t1013,t1014, - t1021,t1022,t1023,t1024, - t1025,t1026,t1027,t1028] - } - -t1111 = arc s1 p1 v1 -t1112 = arc v2 p1 o1 -t1113 = arc v3 p1 v4 - -g11 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1111,t1112,t1113] - } - -t1211 = arc b1 p1 o1 -t1221 = arc b2 res_rdf_first v1 -t1222 = arc b2 res_rdf_rest b3 -t1223 = arc b3 res_rdf_first v2 -t1224 = arc b3 res_rdf_rest res_rdf_nil - -g12 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1211,t1221,t1222,t1223,t1224] - } - -t1711 = arc s1 p1 lfr -t1722 = arc s2 p2 lxml -t1733 = arc s3 p3 lfrxml - -g17 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t1711,t1722,t1733] - } - -tx101 = arc b1 res_owl_sameAs s1 -tx102 = arc s2 res_owl_sameAs 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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx101,tx102, - tx111,tx112,tx113,tx114, - tx121,tx122,tx123,tx124, - tx125,tx126,tx127,tx128] - } - -tx201 = arc b1 res_owl_sameAs s1 -tx202 = arc s2 res_owl_sameAs 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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx201,tx202, - tx211,tx212,tx213,tx214, - tx221,tx222,tx223,tx224, - tx225,tx226,tx227,tx228] - } - -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx311,tx312,tx313,tx314, - tx321,tx322,tx323,tx324, - tx325,tx326,tx327,tx328] - } - -tx401 = arc s1 res_owl_sameAs b1 -tx402 = arc b1 res_rdf_first o1 -tx403 = arc b1 res_rdf_rest b2 -tx404 = arc b2 res_rdf_first o2 -tx405 = arc b2 res_rdf_rest b3 -tx406 = arc b3 res_rdf_first o3 -tx407 = arc b3 res_rdf_rest b4 -tx408 = arc b4 res_rdf_first l1 -tx409 = arc b4 res_rdf_rest res_rdf_nil - -x4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx401,tx402,tx403,tx404, - tx405,tx406,tx407,tx408, - tx409] - } - -tx501 = arc b1 res_owl_sameAs s1 -tx502 = arc b1 res_rdf_first o1 -tx503 = arc b1 res_rdf_rest b2 -tx504 = arc b2 res_rdf_first o2 -tx505 = arc b2 res_rdf_rest b3 -tx506 = arc b3 res_rdf_first o3 -tx507 = arc b3 res_rdf_rest b4 -tx508 = arc b4 res_rdf_first l1 -tx509 = arc b4 res_rdf_rest res_rdf_nil - -x5 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx501,tx502,tx503,tx504, - tx505,tx506,tx507,tx508, - tx509] - } - -tx601 = arc s1 res_rdf_first o1 -tx602 = arc s1 res_rdf_rest b2 -tx603 = arc b2 res_rdf_first o2 -tx604 = arc b2 res_rdf_rest b3 -tx605 = arc b3 res_rdf_first o3 -tx606 = arc b3 res_rdf_rest b4 -tx607 = arc b4 res_rdf_first l1 -tx608 = arc b4 res_rdf_rest res_rdf_nil - -x6 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx601,tx602,tx603,tx604, - tx605,tx606,tx607,tx608] - } - -tx701 = arc b1 p2 f2 -x7f = LookupMap [Formula b1 g2] -x7 = NSGraph - { namespaces = nslist - , formulae = x7f - , statements = [tx701] - } - -tx801 = arc f1 p2 f2 -x8f = LookupMap [Formula f1 g2] -x8 = NSGraph - { namespaces = nslist - , formulae = x8f - , statements = [tx801] - } - -tx901 = tx801 -x9f = LookupMap [Formula f1 g1] -x9 = NSGraph - { namespaces = nslist - , formulae = x9f - , statements = [tx901] - } - --- Test allocation of bnodes carries over a nested formula -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 = NSGraph - { namespaces = emptyNamespaceMap - , formulae = emptyFormulaMap - , statements = [tx1211,tx1212] - } -x12f = LookupMap [Formula b2 x12fg] -x12 = NSGraph - { namespaces = nslist - , formulae = x12f - , statements = [tx1201,tx1202,tx1203,tx1204,tx1205] - } - --- List of simple anon nodes -tx1301 = arc s1 res_rdf_first b1 -tx1302 = arc s1 res_rdf_rest c1 -tx1303 = arc c1 res_rdf_first b2 -tx1304 = arc c1 res_rdf_rest c2 -tx1305 = arc c2 res_rdf_first b3 -tx1306 = arc c2 res_rdf_rest res_rdf_nil -tx1307 = arc b1 p1 o1 -tx1308 = arc b2 p1 o2 -tx1309 = arc b3 p1 o3 - -x13 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1301,tx1302,tx1303,tx1304,tx1305,tx1306, - tx1307,tx1308,tx1309] - } - --- List of more complex anon nodes -tx1401 = arc s1 res_rdf_first b1 -tx1402 = arc s1 res_rdf_rest c1 -tx1403 = arc c1 res_rdf_first b2 -tx1404 = arc c1 res_rdf_rest c2 -tx1405 = arc c2 res_rdf_first b3 -tx1406 = arc c2 res_rdf_rest res_rdf_nil -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1401,tx1402,tx1403,tx1404,tx1405,tx1406, - tx1407,tx1408,tx1409,tx1410,tx1411,tx1412] - } - --- List with nested list -tx1501 = arc s1 res_rdf_first b1 -tx1502 = arc s1 res_rdf_rest c1 -tx1503 = arc c1 res_rdf_first b2 -tx1504 = arc c1 res_rdf_rest c2 -tx1505 = arc c2 res_rdf_first b3 -tx1506 = arc c2 res_rdf_rest res_rdf_nil -tx1507 = arc b1 p1 o1 -tx1508 = arc b2 p2 c3 -tx1509 = arc b3 p1 o3 - -tx1521 = arc c3 res_rdf_first b4 -tx1522 = arc c3 res_rdf_rest c4 -tx1523 = arc c4 res_rdf_first b5 -tx1524 = arc c4 res_rdf_rest c5 -tx1525 = arc c5 res_rdf_first b6 -tx1526 = arc c5 res_rdf_rest res_rdf_nil -tx1527 = arc b4 p1 o1 -tx1528 = arc b5 p1 o2 -tx1529 = arc b6 p1 o3 - -x15 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [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 = arc s1 res_rdf_first b1 -tx1602 = arc s1 res_rdf_rest c1 -tx1603 = arc c1 res_rdf_first b2 -tx1604 = arc c1 res_rdf_rest c2 -tx1605 = arc c2 res_rdf_first b3 -tx1606 = arc c2 res_rdf_rest res_rdf_nil -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 = arc c3 res_rdf_first b4 -tx1622 = arc c3 res_rdf_rest c4 -tx1623 = arc c4 res_rdf_first b5 -tx1624 = arc c4 res_rdf_rest c5 -tx1625 = arc c5 res_rdf_first b6 -tx1626 = arc c5 res_rdf_rest res_rdf_nil -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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tx1601,tx1602,tx1603,tx1604,tx1605,tx1606, - tx1607,tx1608,tx1609,tx1610,tx1611, - tx1621,tx1622,tx1623,tx1624,tx1625,tx1626, - tx1627,tx1628,tx1629,tx1630,tx1631,tx1632] - } - ------------------------------------------------------------- --- Simple parser tests ------------------------------------------------------------- - -commonPrefixes = - "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ - "@prefix base2 : <" ++ nsURI base2 ++ "> . \n" ++ - "@prefix base3 : <" ++ nsURI base3 ++ "> . \n" - --- Single statement using form -simpleN3Graph_g1_01 = - " " ++ - " " ++ - " . " - --- Single statement using prefix:name form -simpleN3Graph_g1_02 = - "@prefix base1 : <" ++ nsURI base1 ++ "> ." ++ - " base1:s1 base1:p1 base1:o1 . " - --- Single statement using :name form -simpleN3Graph_g1_03 = - "@prefix : <" ++ nsURI base1 ++ "> .\n" ++ - " :s1 :p1 :o1 . " - --- Single statement using relative URI form -simpleN3Graph_g1_04 = - "@base <" ++ nsURI base1 ++ "> .\n" ++ - " . " - --- Single statement using blank nodes -simpleN3Graph_g1_05 = - "@base <" ++ nsURI base1 ++ "> .\n" ++ - " _:b1 _:b2 _:b3 . " - --- Single statement with junk following -simpleN3Graph_g1_06 = - "@prefix base1 : <" ++ nsURI base1 ++ "> ." ++ - " base1:s1 base1:p1 base1:o1 . " ++ - " **** " - --- Multiple statements -simpleN3Graph_g2 = - 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 = - commonPrefixes ++ - " base1:s1 base1:p1 base1:o1 . \n" ++ - " base1:s1 base1:p1 \"l1\" . \n" - --- Graph with nodeid -simpleN3Graph_g4 = - commonPrefixes ++ - " base1:s1 base1:p1 base1:o1 . \n" ++ - " base2:s2 base1:p1 _:b1 . \n" - --- Graph with literal and nodeid -simpleN3Graph_g5 = - 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 = - commonPrefixes ++ - " base1:s1 base1:p1 base1:o1 . \n" ++ - " base3:s3 base1:p1 \"\"\"l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'\"\"\" . \n" - --- String escapes -simpleN3Graph_g7 = - commonPrefixes ++ - " base1:s1 base1:p1 base1:o1 . \n" ++ - " base3:s3 base2:p2 " ++ - " \"l3--\\r\\\"\\'\\\\--\\u0020--\\U000000A0--\" " ++ - " . \n" - --- Different verb forms -simpleN3Graph_g8 = - commonPrefixes ++ - " base1:s1 a base1:o1 . \n" ++ - " base2:s2 = base2:o2 . \n" ++ - " base3:s3 + base3:o3 . \n" ++ - " base3:s3 - base3:o3 . \n" ++ - " base3:s3 * base3:o3 . \n" ++ - " base3:s3 / base3:o3 . \n" ++ - " base1:s1 is base1:p1 of base1:o1 . \n" ++ - " base2:s2 has base1:p1 of base2:o2 . \n" ++ - " base1:s1 >- base2:p2 -> base1:o1 . \n" ++ - " base2:s2 <- base2:p2 <- base2:o2 . \n" - -simpleN3Graph_g81 = - commonPrefixes ++ - " base1:s1 a base1:o1 . \n" ++ - " base2:s2 = base2:o2 . \n" - -simpleN3Graph_g82 = - commonPrefixes ++ - " base3:s3 + base3:o3 . \n" ++ - " base3:s3 - base3:o3 . \n" ++ - " base3:s3 * base3:o3 . \n" ++ - " base3:s3 / base3:o3 . \n" - -simpleN3Graph_g83 = - commonPrefixes ++ - " base1:s1 is base1:p1 of base1:o1 . \n" ++ - " base2:s2 has base1:p1 of base2:o2 . \n" ++ - " base1:s1 >- base2:p2 -> base1:o1 . \n" ++ - " base2:s2 <- base2:p2 <- base2:o2 . \n" - --- Semicolons and commas -simpleN3Graph_g9 = - 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 = - commonPrefixes ++ - " base1:s1 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 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" - --- Simple statements using ?var form -simpleN3Graph_g11 = - "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ - " base1:s1 base1:p1 ?var1 . \n" ++ - " ?var2 base1:p1 base1:o1 . \n" ++ - " ?var3 base1:p1 ?var4 . \n" - --- Bare anonymous nodes -simpleN3Graph_g12 = - "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ - " [ base1:p1 base1:o1 ] . \n" ++ - " ( ?var1 ?var2 ) . \n" - --- Literals with dataype and language -simpleN3Graph_g17 = - commonPrefixes ++ - " base1:s1 base1:p1 \"chat\"@fr . \n " ++ - " base2:s2 base2:p2 \"
\"^^rdf:XMLLiteral . \n " ++ - " base3:s3 base3:p3 \"chat\"^^rdf:XMLLiteral . \n " - -simpleTest011 = parseTest "simpleTest011" simpleN3Graph_g1_01 g1 noError -simpleTest012 = parseTest "simpleTest012" simpleN3Graph_g1_02 g1 noError -simpleTest013 = parseTest "simpleTest013" simpleN3Graph_g1_03 g1 noError -simpleTest014 = parseTest "simpleTest014" simpleN3Graph_g1_04 g1 noError -simpleTest015 = parseTest "simpleTest015" simpleN3Graph_g1_05 g1b noError -simpleTest016 = parseTest "simpleTest016" simpleN3Graph_g1_06 emptyRDFGraph - ( "(line 1, column 103):\n"++ - "unexpected \"*\"\n"++ - "expecting URI or blank node or end of input" ) -simpleTest03 = parseTest "simpleTest03" simpleN3Graph_g2 g2 noError -simpleTest04 = parseTest "simpleTest04" simpleN3Graph_g3 g3 noError -simpleTest05 = parseTest "simpleTest05" simpleN3Graph_g4 g4 noError -simpleTest06 = parseTest "simpleTest06" simpleN3Graph_g5 g5 noError -simpleTest07 = parseTest "simpleTest07" simpleN3Graph_g6 g6 noError -simpleTest08 = parseTest "simpleTest08" simpleN3Graph_g7 g7 noError -simpleTest09 = parseTest "simpleTest09" simpleN3Graph_g8 g8 noError -simpleTest10 = parseTest "simpleTest10" simpleN3Graph_g81 g81 noError -simpleTest11 = parseTest "simpleTest11" simpleN3Graph_g82 g82 noError -simpleTest12 = parseTest "simpleTest12" simpleN3Graph_g83 g83 noError -simpleTest13 = parseTest "simpleTest13" simpleN3Graph_g9 g9 noError -simpleTest14 = parseTest "simpleTest14" simpleN3Graph_g10 g10 noError -simpleTest15 = parseTest "simpleTest15" simpleN3Graph_g11 g11 noError -simpleTest16 = parseTest "simpleTest16" simpleN3Graph_g12 g12 noError -simpleTest17 = parseTest "simpleTest17" simpleN3Graph_g17 g17 noError - -simpleTestSuite = TestList - [ simpleTest011 - , simpleTest012 - , simpleTest013 - , simpleTest014 - , simpleTest015 - , simpleTest016 - , simpleTest03 - , simpleTest04 - , simpleTest05 - , simpleTest06 - , simpleTest07 - , simpleTest08 - , simpleTest09 - , simpleTest10 - , simpleTest11 - , simpleTest12 - , simpleTest13 - , simpleTest14 - , simpleTest15 - , simpleTest16 - , simpleTest17 - ] - ------------------------------------------------------------- --- 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 = - 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 = - commonPrefixes ++ - " [ 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 ] = base1:s1 . \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" - - --- 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 = - commonPrefixes ++ - " base1:s1 = (base1:o1 base2:o2 base3:o3 \"l1\") .\n" - -exoticN3Graph_x5 = - commonPrefixes ++ - " (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, with and without :- - -exoticN3Graph_x7 = - 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 . " - -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 " - -- (also omits final periods) - -exoticN3Graph_x8a = - 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" ++ - " base1:f1 base2:p2 base2:f2 . " - -exoticN3Graph_x9a = - commonPrefixes ++ - " base1:f1 :- \n" ++ - " { base1:s1 base1:p1 base1:o1 . } . \n" ++ - " base1:f1 base2:p2 base2:f2 . " - --- Test allocation of bnodes carries over a nested formula -exoticN3Graph_x12 = - 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" - --- 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" - --- 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" - -exoticTest01 = parseTest "exoticTest01" exoticN3Graph_x1 x1 noError -exoticTest02 = parseTest "exoticTest02" exoticN3Graph_x2 x2 noError -exoticTest03 = parseTest "exoticTest03" exoticN3Graph_x3 x3 noError -exoticTest04 = parseTest "exoticTest04" exoticN3Graph_x4 x4 noError -exoticTest05 = parseTest "exoticTest05" exoticN3Graph_x5 x5 noError -exoticTest06 = parseTest "exoticTest06" exoticN3Graph_x6 x6 noError -exoticTest07 = parseTest "exoticTest07" exoticN3Graph_x7 x7 noError -exoticTest08 = parseTest "exoticTest08" exoticN3Graph_x8 x8 noError -exoticTest09 = parseTest "exoticTest09" exoticN3Graph_x9 x9 noError -exoticTest10 = parseTest "exoticTest10" exoticN3Graph_x8a x8 noError -exoticTest11 = parseTest "exoticTest11" exoticN3Graph_x9a x9 noError -exoticTest12 = parseTest "exoticTest12" exoticN3Graph_x12 x12 noError -exoticTest13 = parseTest "exoticTest13" exoticN3Graph_x13 x13 noError -exoticTest14 = parseTest "exoticTest14" exoticN3Graph_x14 x14 noError -exoticTest15 = parseTest "exoticTest15" exoticN3Graph_x15 x15 noError -exoticTest16 = parseTest "exoticTest16" exoticN3Graph_x16 x16 noError -exoticTest20 = testGraphEq "exoticTest20" False x7 x8 -exoticTest21 = testGraphEq "exoticTest21" False x8 x9 - -exoticTestSuite = TestList - [ exoticTest01 - , exoticTest02 - , exoticTest03 - , exoticTest04 - , exoticTest05 - , exoticTest06 - , exoticTest07 - , exoticTest08 - , exoticTest09 - , exoticTest10 - , exoticTest11 - , exoticTest12 - , exoticTest13 - , exoticTest14 - , exoticTest15 - , exoticTest16 - , exoticTest20 - , exoticTest21 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ charTestSuite - , nameTestSuite - , prefixTestSuite - , absUriRefTestSuite - , uriRef2TestSuite - , simpleTestSuite - , exoticTestSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/N3ParserTest.hs,v $ --- $Author: graham $ --- $Revision: 1.25 $ --- $Log: N3ParserTest.hs,v $ --- Revision 1.25 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. --- --- Revision 1.24 2004/01/09 11:23:54 graham --- Fix up N3Parser so that the final statement-terminating '.' in a formula --- or file is optional. --- --- Revision 1.23 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.22 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.21 2003/12/03 17:07:23 graham --- Replace occurrences of QName in N3Parser with ScopedName. --- --- Revision 1.20 2003/12/03 15:42:09 graham --- Eliminate special return type in favour of ErrorM --- --- Revision 1.19 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.18 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.17 2003/10/09 16:26:31 graham --- Added parser support for literal language tags and datatypes. --- (Language tags are names, not strictly per RFC3066) --- --- Revision 1.16 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.15 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.14 2003/07/01 14:18:57 graham --- Allow blank node in predicate position. --- Add parser and formatter test case for this. --- --- Revision 1.13 2003/06/12 00:47:56 graham --- Allowed variable node (?v) and bare anonymous nodes in N3 parser. --- --- Revision 1.12 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.11 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.10 2003/05/23 00:02:42 graham --- Fixed blank node id generation bug in N3Formatter --- --- Revision 1.9 2003/05/22 15:16:39 graham --- Added additional parser test cases for lists --- --- Revision 1.8 2003/05/21 13:55:13 graham --- N3 parser now handles relative URIs and default prefixes. --- (Still need to figure better default base URI handling; i.e. current document) --- --- Revision 1.7 2003/05/21 13:34:13 graham --- Various N3 parser bug fixes. --- Need to fix handling of :name terms. --- --- Revision 1.6 2003/05/14 16:50:32 graham --- Graph matching seems solid now: --- RDFGraphTest and N3ParserTest pass all tests --- Updated TODO file with comments from code --- --- Revision 1.5 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.4 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.3 2003/04/30 12:14:08 graham --- Add formetter test to CVS --- Noted problem with RDFGraph structure: preparing to rework --- --- Revision 1.2 2003/04/17 12:28:05 graham --- Formula parsing seems OK. --- There remains a question about how to represent --- and compare graphs containing formulae. --- --- Revision 1.1 2003/04/17 00:35:38 graham --- Added module N3ParserTest --- N3parser is mostly working --- Formulae remain to test --- diff --git a/Swish/HaskellRDF/ParsecLanguage.hs b/Swish/HaskellRDF/ParsecLanguage.hs deleted file mode 100644 --- a/Swish/HaskellRDF/ParsecLanguage.hs +++ /dev/null @@ -1,115 +0,0 @@ - ----------------------------------------------------------------- --- Daan Leijen (c) 1999-2001, daan@cs.uu.nl --- --- a helper module that defines some language definitions --- that can be used to instantiate a token parser (see ParsecToken) --- --- $Revision: 1.3 $ --- $Author: daan $ --- $Date: 2001/10/03 09:21:38 $ ----------------------------------------------------------------- -module Swish.HaskellRDF.ParsecLanguage( haskellDef, haskell - , mondrianDef, mondrian - - , emptyDef - , haskellStyle - , javaStyle - , LanguageDef (..) - ) where - -import Text.ParserCombinators.Parsec -import Text.ParserCombinators.Parsec.Token - - ------------------------------------------------------------ --- Styles: haskellStyle, javaStyle ------------------------------------------------------------ - -haskellStyle= emptyDef - { commentStart = "{-" - , commentEnd = "-}" - , commentLine = "--" - , nestedComments = True - , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , opStart = opLetter haskellStyle - , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" - , reservedOpNames= [] - , reservedNames = [] - , caseSensitive = True - } - -javaStyle = emptyDef - { commentStart = "/*" - , commentEnd = "*/" - , commentLine = "//" - , nestedComments = True - , identStart = letter - , identLetter = alphaNum <|> oneOf "_'" - , reservedNames = [] - , reservedOpNames= [] - , caseSensitive = False - } - ------------------------------------------------------------ --- minimal language definition ------------------------------------------------------------ -emptyDef = LanguageDef - { commentStart = "" - , commentEnd = "" - , commentLine = "" - , nestedComments = True - , identStart = letter <|> char '_' - , identLetter = alphaNum <|> oneOf "_'" - , opStart = opLetter emptyDef - , opLetter = oneOf ":!#$%&*+./<=>?@\\^|-~" - , reservedOpNames= [] - , reservedNames = [] - , caseSensitive = True - } - - - ------------------------------------------------------------ --- Haskell ------------------------------------------------------------ -haskell :: TokenParser st -haskell = makeTokenParser haskellDef - -haskellDef = haskell98Def - { identLetter = identLetter haskell98Def <|> char '#' - , reservedNames = reservedNames haskell98Def ++ - ["foreign","import","export","primitive" - ,"_ccall_","_casm_" - ,"forall" - ] - } - -haskell98Def = haskellStyle - { reservedOpNames= ["::","..","=","\\","|","<-","->","@","~","=>"] - , reservedNames = ["let","in","case","of","if","then","else", - "data","type", - "class","default","deriving","do","import", - "infix","infixl","infixr","instance","module", - "newtype","where", - "primitive" - -- "as","qualified","hiding" - ] - } - - ------------------------------------------------------------ --- Mondrian ------------------------------------------------------------ -mondrian :: TokenParser st -mondrian = makeTokenParser mondrianDef - -mondrianDef = javaStyle - { reservedNames = [ "case", "class", "default", "extends" - , "import", "in", "let", "new", "of", "package" - ] - , caseSensitive = True - } - - diff --git a/Swish/HaskellRDF/Proof.hs b/Swish/HaskellRDF/Proof.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Proof.hs +++ /dev/null @@ -1,361 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: Proof.hs,v 1.19 2004/01/07 19:49:12 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Proof --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a framework for constructing proofs --- over some expression form. It is intended to be used --- with RDF graphs, but the structures aim to be quite --- generic with respect to the expression forms allowed. --- --- It does not define any proof-finding strategy. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.Proof - ( Proof(..), Step(..) - , checkProof, explainProof, checkStep, showProof, showsProof, showsFormula ) -where - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) - , fwdCheckInference - , showsFormula, showsFormulae, showsWidth ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI ) - -import Swish.HaskellUtils.ShowM - ( ShowM(..), showm ) - -import Swish.HaskellUtils.ListHelpers - ( subset ) - -import Data.List - ( union, intersect, intersperse ) - -import Data.Maybe - ( isJust, fromJust, catMaybes ) - - ------------------------------------------------------------- --- Proof framework ------------------------------------------------------------- - --- |Step in proof chain --- --- The display name for a proof step comes from the display name of its --- consequence formula. -data Step ex = Step - { stepRule :: Rule ex -- ^ Inference rule used - , stepAnt :: [Formula ex] -- ^ Antecedents of inference rule - , stepCon :: Formula ex -- ^ Named consequence of inference rule - } deriving Show - --- |Proof is a structure that presents a chain of rule applications --- that yield a result expression from a given expression -data Proof ex = Proof - { proofContext :: [Ruleset ex] -- ^ Proof context: list of rulesets, - -- each of which provides a number of - -- axioms and rules. - , proofInput :: Formula ex -- ^ Given expression - , proofResult :: Formula ex -- ^ Result expression - , proofChain :: [Step ex] -- ^ Chain of inference rule applications - -- progressing from input to result - } - --- |Return a list of axioms from all the rulesets in a proof -proofAxioms = concat . map rsAxioms . proofContext - --- |Return a list of rules from all the rulesets in a proof -proofRules = concat . map rsRules . proofContext - --- |Return list of axioms actually referenced by a proof -proofAxiomsUsed :: Proof ex -> [Formula ex] -proofAxiomsUsed proof = foldl union [] $ map stepAxioms (proofChain proof) - where - stepAxioms st = stepAnt st `intersect` proofAxioms proof - --- |Check consistency of given proof. --- The supplied rules and axioms are assumed to be correct. -checkProof :: (Expression ex) => Proof ex -> Bool -checkProof pr = - checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr - where - initExpr = (formExpr $ proofInput pr):(map formExpr $ proofAxioms pr) - goalExpr = (formExpr $ proofResult pr) - -checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool -checkProof1 _ prev [] res = res `elem` prev -checkProof1 rules prev (st:steps) res = - checkStep rules prev st && - checkProof1 rules ((formExpr $ stepCon st):prev) steps res - --- A proof step is valid if rule is in list of rules --- and the antecedents are sufficient to obtain the conclusion --- and the antecedents are in the list of formulae already proven. --- --- Note: this function depends on the ruleName of any rule being --- unique among all rules. In particular the name of the step rule --- being in correspondence with the name of one of the indicated --- valid rules of inference. -checkStep :: (Expression ex) => [Rule ex] -> [ex] -> Step ex -> Bool -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, and return identification of failing step. -explainProof :: - (Expression ex) => Proof ex -> Maybe String -explainProof pr = - explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr - where - initExpr = (formExpr $ proofInput pr):(map formExpr $ proofAxioms pr) - goalExpr = (formExpr $ proofResult pr) - -explainProof1 :: - (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String -explainProof1 _ prev [] res = - if res `elem` prev then Nothing else Just "Result not demonstrated" -explainProof1 rules prev (st:steps) res = - case explainStep rules prev st of - Nothing -> explainProof1 rules ((formExpr $ stepCon st):prev) steps res - Just ex -> Just ("Invalid step: "++show (formName $ stepCon st)++": "++ex) - --- A proof step is valid if rule is in list of rules --- and the antecedents are sufficient to obtain the conclusion --- and the antecedents are in the list of formulae already proven. --- --- Note: this function depends on the ruleName of any rule being --- unique among all rules. In particular the name of the step rule --- being in correspondence with the name of one of the indicated --- valid rules of inference. --- --- Return Nothing if step is OK, or Just string describing failure --- -explainStep :: (Expression ex) => [Rule ex] -> [ex] -> Step ex -> Maybe String -explainStep rules prev step = - if null errors then Nothing else Just $ concat (intersperse ", " errors) - where - -- Rule from proof step: - srul = stepRule step - -- Antecedent expressions from proof step: - sant = map formExpr $ stepAnt step - -- Consequentent expression from proof step: - scon = formExpr $ stepCon step - -- Tests for step to be valid - errors = catMaybes - -- Rule name is one of supplied rules, and - [ require (ruleName srul `elem` map ruleName rules) - ("rule "++show (ruleName srul)++" not present") - -- Antecedent expressions are all previously accepted expressions - , require (sant `subset` prev) - ("antecedent not axiom or previous result") - -- Inference rule yields consequence from antecedents - , require (checkInference srul sant scon) - ("rule does not deduce consequence from antecedents") - ] - require b s = if b then Nothing else Just s - --- |showsProof --- 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 :: (ShowM ex) => 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) - --- |showProof --- Returns a simple string representation of a proof. -showProof :: (ShowM ex) => String -> Proof ex -> String -showProof newline proof = showsProof newline proof "" - --- |showsSteps --- Create a displayable form of a list of labelled proof steps -showsSteps :: (ShowM ex) => String -> [Step ex] -> ShowS -showsSteps _ [] = id -showsSteps newline [s] = showsStep newline s -showsSteps newline (s:ss) = showsStep newline s . - showString newline . - showsSteps newline ss - --- |showsStep --- Create a displayable form of a labelled proof step. -showsStep :: (ShowM ex) => String -> Step ex -> ShowS -showsStep newline s = showsFormula newline (stepCon s) . - showString newline . - showString (" (by ["++rulename++"] from "++antnames++")") - where - rulename = show . ruleName $ stepRule s - antnames = showNames $ map (show . formName) (stepAnt s) - --- |showNames --- 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 - --- |showNames --- Return a string representing a single name. -showName n = "["++n++"]" - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Proof.hs,v $ --- $Author: graham $ --- $Revision: 1.19 $ --- $Log: Proof.hs,v $ --- Revision 1.19 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.18 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.17 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.16 2003/09/30 20:02:39 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.15 2003/09/30 16:39:41 graham --- Refactor proof code to use new ruleset logic. --- Moved some support code from RDFProofCheck to RDFRuleset. --- --- Revision 1.14 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.13 2003/07/02 13:51:14 graham --- Intermediate save: partially coded RDFS rules. --- --- Revision 1.12 2003/07/01 14:20:30 graham --- Added instance entailment to proof check module. --- --- Revision 1.11 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.10 2003/06/26 15:37:23 graham --- Added rdfQueryInstance, and tests, all works. --- --- Revision 1.9 2003/06/25 21:16:53 graham --- Reworked N3 formatting logic to support proof display. --- Basic proof display is working. --- --- Revision 1.8 2003/06/24 23:08:18 graham --- Replaced Rule class with algebraic data type --- --- Revision 1.7 2003/06/24 19:56:31 graham --- Basic proof-check now works --- --- Revision 1.6 2003/06/19 19:49:07 graham --- RDFProofCheck compiles, but test fails --- --- Revision 1.5 2003/06/18 18:40:08 graham --- Basic proof backchaining tests OK. --- Next: add filtering on variable bindings. --- --- Revision 1.4 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.3 2003/06/10 01:04:46 graham --- Proof framework in progress; compiles, incomplete --- --- Revision 1.2 2003/06/04 00:49:53 graham --- Proof module compiles OK --- --- Revision 1.1 2003/06/03 19:24:54 graham --- Started work on inference/proof module --- diff --git a/Swish/HaskellRDF/RDFDatatype.hs b/Swish/HaskellRDF/RDFDatatype.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFDatatype.hs +++ /dev/null @@ -1,290 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFDatatype.hs,v 1.14 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatype --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + existential types --- --- This module defines the structures used by Swish to represent and --- manipulate RDF datatypes. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , RDFModifierFn, RDFApplyModifier - , makeRdfDtOpenVarBindingModify, makeRdfDtOpenVarBindingModifiers - , applyRDFDatatypeMod - , RDFDatatypeSub - , fromRDFLabel, toRDFLabel, makeDatatypedLiteral - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , isDatatyped - , getLiteralText - , RDFGraph - ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingModify, RDFOpenVarBindingModify - ) - -import Swish.HaskellRDF.Datatype - ( Datatype -- , typeName, typeRules - , DatatypeVal(..) - , getDTMod - , DatatypeMap(..) - , DatatypeMod(..), ModifierFn - , nullDatatypeMod - , ApplyModifier - , DatatypeSub(..) - ) - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getQName - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings, addVarBinding - , VarBindingModify(..) - ) - -import Data.Maybe - ( Maybe(..), fromMaybe, isJust, fromJust ) - -import Control.Monad - ( liftM ) - ------------------------------------------------------------- --- 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. --- --- dtval is an RDFDatatype value containing details of the datatype --- for which a variable binding modifier is created. --- dtmod is the data value modifier value that defines the calculations --- that are used to implement a variable binding modifier. --- --- 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 -> RDFDatatypeMod vt -> RDFOpenVarBindingModify -makeRdfDtOpenVarBindingModify dtval dtmod = - dmAppf dtmod (dmName dtmod) $ map (makeRDFModifierFn dtval) (dmModf dtmod) - --- |Create all RDFOpenVarBindingModify values for a given datatype value. --- See makeRdfDtOpenVarBindingModify abovr. --- --- dtval is an RDFDatatype value containing details of the datatype --- for which variable binding modifiers are created. --- -makeRdfDtOpenVarBindingModifiers :: - RDFDatatypeVal vt -> [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 = sequence $ map (rdfNodeExtract dtval) ivs - ovals | isJust ivals = fn (fromJust ivals) - | otherwise = [] - in - fromMaybe [] $ sequence $ map (rdfNodeInject dtval) ovals - --- |Extract datatyped value from RDFLabel value, or return Nothing. --- -rdfNodeExtract :: RDFDatatypeVal vt -> RDFLabel -> Maybe vt -rdfNodeExtract dtval node - | isDatatyped dtname node = mapL2V dtmap $ getLiteralText node - | otherwise = Nothing - where - dtname = tvalName dtval - dtmap = tvalMap dtval - --- |Return new RDF literal node with a representation of the supplied --- value, or Nothing. --- -rdfNodeInject :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel -rdfNodeInject dtval val = maybeNode valstr - where - valstr = mapV2L (tvalMap dtval) val - maybeNode Nothing = Nothing - maybeNode (Just str) = Just $ Lit str (Just (tvalName dtval)) - ------------------------------------------------------------- --- Helpers to map between datatype values and RDFLabels ------------------------------------------------------------- - -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 - -toRDFLabel :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel -toRDFLabel dtv = - liftM (makeDatatypedLiteral dtnam) . mapV2L dtmap - where - dtnam = tvalName dtv - dtmap = tvalMap dtv - -makeDatatypedLiteral :: ScopedName -> String -> RDFLabel -makeDatatypedLiteral dtnam strval = - Lit strval (Just dtnam) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFDatatype.hs,v $ --- $Author: graham $ --- $Revision: 1.14 $ --- $Log: RDFDatatype.hs,v $ --- Revision 1.14 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.13 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.12 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.11 2003/12/08 17:29:19 graham --- Moved OpenVarBinding type definitions from -Datatype to -VarBinding modules. --- --- Revision 1.10 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.9 2003/11/25 23:02:17 graham --- Reworked datatype variable modifier logic. --- Limited range of test cases so far all pass. --- --- Revision 1.8 2003/11/24 22:13:09 graham --- Working on reworking datatype variable modifiers to work with --- revised datatype framework. --- --- Revision 1.7 2003/11/14 21:48:35 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.6 2003/11/13 01:14:32 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.4 2003/11/11 21:02:55 graham --- Working on datatype class-constraint inference rule. Incomplete. --- --- Revision 1.3 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.2 2003/10/24 21:05:08 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.1 2003/10/22 15:46:38 graham --- Add RDFDatatype module. --- diff --git a/Swish/HaskellRDF/RDFDatatypeXsdInteger.hs b/Swish/HaskellRDF/RDFDatatypeXsdInteger.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFDatatypeXsdInteger.hs +++ /dev/null @@ -1,609 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFDatatypeXsdInteger.hs,v 1.15 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdInteger --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines the structures used by swish to represent and --- manipulate RDF datatypes. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFDatatypeXsdInteger - ( rdfDatatypeXsdInteger - , rdfDatatypeValXsdInteger - , typeNameXsdInteger, namespaceXsdInteger - , axiomsXsdInteger, rulesXsdInteger - , prefixXsdInteger - ) -where - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula - , makeRDFGraphFromN3String - , makeRDFFormula - ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , makeRdfDtOpenVarBindingModifiers - ) - -import Swish.HaskellRDF.ClassRestrictionRule - ( makeRDFDatatypeRestrictionRules - ) - -import Swish.HaskellRDF.MapXsdInteger - ( mapXsdInteger - ) - -import Swish.HaskellRDF.Datatype - ( Datatype(..) - , DatatypeVal(..) - , DatatypeRel(..), DatatypeRelPr - , altArgs - , UnaryFnTable, unaryFnApp - , BinaryFnTable, binaryFnApp - , BinMaybeFnTable, binMaybeFnApp - , DatatypeMod(..) - , makeVmod_1_1_inv, makeVmod_1_1 - , makeVmod_2_1_inv, makeVmod_2_1 - , makeVmod_2_0 - , makeVmod_2_2 - ) - -import Swish.HaskellRDF.Ruleset - ( makeRuleset - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceMATH - , namespaceXsdType - ) - -import Data.Maybe - ( Maybe (..), maybeToList ) - -import Control.Monad - ( liftM ) - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - --- Local name for Integer datatype -nameXsdInteger = "integer" - --- |Type name for xsd:integer datatype -typeNameXsdInteger = ScopedName namespaceXSD nameXsdInteger - --- |Namespace for xsd:integer datatype functions -namespaceXsdInteger = namespaceXsdType nameXsdInteger - --- Helper to catenate strings with newline separator, --- used for making textual representations of graphs. --- (the newline makes N3 parser diagnostics easier to interpret) --- -infixr 5 +++ -(+++) :: String -> ShowS -(+++) str = ((str++"\n")++) - --- Compose with function of two arguments -c2 = (.) . (.) - --- Integer power (exponentiation) function --- returns Nothing if exponent is negative. --- -intPower :: Integer -> Integer -> Maybe Integer -intPower a b = if b < 0 then Nothing else Just (intPower1 a b) - where - intPower1 a b - | q == 1 = atopsq*a - | p == 0 = 1 - | otherwise = atopsq - where - (p,q) = b `divMod` 2 - atop = intPower1 a p - atopsq = atop*atop - ------------------------------------------------------------- --- Declare exported RDFDatatype value for xsd:integer ------------------------------------------------------------- - -rdfDatatypeXsdInteger :: RDFDatatype -rdfDatatypeXsdInteger = Datatype rdfDatatypeValXsdInteger - ------------------------------------------------------------- --- Implmentation of RDFDatatypeVal for xsd:integer ------------------------------------------------------------- - --- |Define Datatype value for xsd:integer --- Members of this datatype are positive or negative integer values. --- --- The lexical form consists of an option '+' 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. --- (cf. http://www.w3.org/2000/10/swap/doc/CwmBuiltins.html) --- - -relXsdInteger :: [DatatypeRel Integer] -relXsdInteger = - [ relXsdIntegerAbs - , relXsdIntegerNeg - , relXsdIntegerSum - , relXsdIntegerDiff - , relXsdIntegerProd - , relXsdIntegerDivMod - , relXsdIntegerPower - , relXsdIntegerEq - , relXsdIntegerNe - , relXsdIntegerLt - , relXsdIntegerLe - , relXsdIntegerGt - , relXsdIntegerGe - ] - -mkIntRel2 :: - String -> DatatypeRelPr Integer -> UnaryFnTable Integer - -> DatatypeRel Integer -mkIntRel2 nam pr fns = DatatypeRel - { dtRelName = ScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns unaryFnApp - } - -mkIntRel3 :: - String -> DatatypeRelPr Integer -> BinaryFnTable Integer - -> DatatypeRel Integer -mkIntRel3 nam pr fns = DatatypeRel - { dtRelName = ScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns binaryFnApp - } - -mkIntRel3maybe :: - String -> DatatypeRelPr Integer -> BinMaybeFnTable Integer - -> DatatypeRel Integer -mkIntRel3maybe nam pr fns = DatatypeRel - { dtRelName = ScopedName namespaceXsdInteger nam - , dtRelFunc = altArgs pr fns binMaybeFnApp - } - -relXsdIntegerAbs :: DatatypeRel Integer -relXsdIntegerAbs = mkIntRel2 "abs" (const True) - [ ( (>=0), [ (abs,1) ] ) - , ( const True, [ (id,0), (negate,0) ] ) - ] - -relXsdIntegerNeg :: DatatypeRel Integer -relXsdIntegerNeg = mkIntRel2 "neg" (const True) - [ ( const True, [ (negate,1) ] ) - , ( const True, [ (negate,0) ] ) - ] - -relXsdIntegerSum :: DatatypeRel Integer -relXsdIntegerSum = mkIntRel3 "sum" (const True) - [ ( const True, [ ((+),1,2) ] ) - , ( const True, [ ((-),0,2) ] ) - , ( const True, [ ((-),0,1) ] ) - ] - -relXsdIntegerDiff :: DatatypeRel Integer -relXsdIntegerDiff = mkIntRel3 "diff" (const True) - [ ( const True, [ ((-),1,2) ] ) - , ( const True, [ ((+),0,2) ] ) - , ( const True, [ ((-),1,0) ] ) - ] - -relXsdIntegerProd :: DatatypeRel Integer -relXsdIntegerProd = mkIntRel3 "prod" (const True) - [ ( const True, [ ((*),1,2) ] ) - , ( const True, [ (div,0,2) ] ) - , ( const True, [ (div,0,1) ] ) - ] - -relXsdIntegerDivMod :: DatatypeRel Integer -relXsdIntegerDivMod = mkIntRel3 "divmod" (const True) - [ ( const True, [ (div,2,3) ] ) - , ( const True, [ (mod,2,3) ] ) - , ( const True, [ ] ) - , ( const True, [ ] ) - ] - -relXsdIntegerPower :: DatatypeRel Integer -relXsdIntegerPower = mkIntRel3maybe "power" (const True) - [ ( const True, [ (liftM (:[]) `c2` intPower,1,2) ] ) - , ( const True, [ ] ) - , ( (>=0), [ ] ) - ] - -liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool -liftL2 p i1 i2 as = p (i1 as) (i2 as) - -lcomp :: (a->a->Bool) -> [a] -> Bool -lcomp p = liftL2 p head (head . tail) - --- eq - -relXsdIntegerEq :: DatatypeRel Integer -relXsdIntegerEq = mkIntRel2 "eq" (lcomp (==)) - ( repeat (const True, []) ) - --- ne - -relXsdIntegerNe :: DatatypeRel Integer -relXsdIntegerNe = mkIntRel2 "ne" (lcomp (/=)) - ( repeat (const True, []) ) - --- lt - -relXsdIntegerLt :: DatatypeRel Integer -relXsdIntegerLt = mkIntRel2 "lt" (lcomp (<)) - ( repeat (const True, []) ) - --- le - -relXsdIntegerLe :: DatatypeRel Integer -relXsdIntegerLe = mkIntRel2 "le" (lcomp (<=)) - ( repeat (const True, []) ) - --- gt - -relXsdIntegerGt :: DatatypeRel Integer -relXsdIntegerGt = mkIntRel2 "gt" (lcomp (>)) - ( repeat (const True, []) ) - --- ge - -relXsdIntegerGe :: DatatypeRel Integer -relXsdIntegerGe = mkIntRel2 "ge" (lcomp (>=)) - ( repeat (const True, []) ) - --- |modXsdInteger contains variable binding modifiers for xsd:Integer values. --- --- The functions are selected from those defined by CWM as math: --- properties. --- (cf. http://www.w3.org/2000/10/swap/doc/CwmBuiltins.html) --- -modXsdInteger :: [RDFDatatypeMod Integer] -modXsdInteger = - [ modXsdIntegerAbs - , modXsdIntegerNeg - , modXsdIntegerSum - , modXsdIntegerDiff - , modXsdIntegerProd - , modXsdIntegerDivMod - , modXsdIntegerPower - , modXsdIntegerEq - , modXsdIntegerNe - , modXsdIntegerLt - , modXsdIntegerLe - , modXsdIntegerGt - , modXsdIntegerGe - ] - -modXsdIntegerAbs :: RDFDatatypeMod Integer -modXsdIntegerAbs = DatatypeMod - { dmName = (ScopedName namespaceXsdInteger "abs") - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod_1_1 - } - where - f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] - f0 _ = [] - f1 [v2] = [abs v2] - f1 _ = [] - -modXsdIntegerNeg :: RDFDatatypeMod Integer -modXsdIntegerNeg = DatatypeMod - { dmName = (ScopedName namespaceXsdInteger "neg") - , dmModf = [ f0, f1, f1 ] - , dmAppf = makeVmod_1_1_inv - } - where - f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] - f0 _ = [] - f1 [vi] = [-vi] - f1 _ = [] - -modXsdIntegerSum :: RDFDatatypeMod Integer -modXsdIntegerSum = DatatypeMod - { dmName = (ScopedName namespaceXsdInteger "sum") - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod_2_1_inv - } - 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 = (ScopedName namespaceXsdInteger "diff") - , dmModf = [ f0, f1, f2, f3 ] - , dmAppf = makeVmod_2_1_inv - } - 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 = (ScopedName namespaceXsdInteger "prod") - , dmModf = [ f0, f1, f2, f2 ] - , dmAppf = makeVmod_2_1_inv - } - where - f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] - f0 _ = [] - f1 [v2,v3] = [v2*v3] - f1 _ = [] - f2 [v1,vi] = if r == 0 then [q] else [] - where (q,r) = quotRem v1 vi - f2 _ = [] - -modXsdIntegerDivMod :: RDFDatatypeMod Integer -modXsdIntegerDivMod = DatatypeMod - { dmName = (ScopedName namespaceXsdInteger "divmod") - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod_2_2 - } - 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 = (ScopedName namespaceXsdInteger "power") - , dmModf = [ f0, f1 ] - , dmAppf = makeVmod_2_1 - } - 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 = modXsdIntegerCompare "eq" (==) -modXsdIntegerNe = modXsdIntegerCompare "ne" (/=) -modXsdIntegerLt = modXsdIntegerCompare "lt" (<) -modXsdIntegerLe = modXsdIntegerCompare "le" (<=) -modXsdIntegerGt = modXsdIntegerCompare "gt" (>) -modXsdIntegerGe = modXsdIntegerCompare "ge" (>=) - -modXsdIntegerCompare :: - String -> (Integer->Integer->Bool) -> RDFDatatypeMod Integer -modXsdIntegerCompare nam rel = DatatypeMod - { dmName = (ScopedName namespaceXsdInteger nam) - , dmModf = [ f0 ] - , dmAppf = makeVmod_2_0 - } - 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 = - makeRuleset namespaceXsdInteger axiomsXsdInteger rulesXsdInteger - -mkPrefix ns = - "@prefix " ++ nsPrefix ns ++ ": <" ++ nsURI ns ++ "> . \n" - -prefixXsdInteger = - mkPrefix namespaceRDF ++ - mkPrefix namespaceRDFS ++ - mkPrefix namespaceRDFD ++ - mkPrefix namespaceXSD ++ - mkPrefix namespaceXsdInteger ++ - " \n" - -mkAxiom :: String -> String -> RDFFormula -mkAxiom local gr = - makeRDFFormula namespaceXsdInteger local (prefixXsdInteger++gr) - -axiomsXsdInteger = - [ mkAxiom "dt" "xsd:integer rdf:type rdfs:Datatype ." - ] - -rulesXsdInteger = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr - where - gr = makeRDFGraphFromN3String rulesXsdIntegerStr - -rulesXsdIntegerStr = 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFDatatypeXsdInteger.hs,v $ --- $Author: graham $ --- $Revision: 1.15 $ --- $Log: RDFDatatypeXsdInteger.hs,v $ --- Revision 1.15 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.14 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.13 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.12 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.11 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.10 2003/11/27 11:35:49 graham --- Variable modifier tests all run. --- Initial class constraint reasoning tests pass. --- Fixed bug in class constraint backward-chained reasoning that returned --- multiple instances of some statements, and did not filter out all occurrences --- of the original statements. --- --- Revision 1.9 2003/11/25 23:02:17 graham --- Reworked datatype variable modifier logic. --- Limited range of test cases so far all pass. --- --- Revision 1.8 2003/11/24 22:13:09 graham --- Working on reworking datatype variable modifiers to work with --- revised datatype framework. --- --- Revision 1.7 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.6 2003/11/14 21:48:34 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.5 2003/11/14 15:59:51 graham --- Separate MapXsdInteger from RDFDatatypeXsdInteger. --- --- Revision 1.4 2003/11/11 21:02:55 graham --- Working on datatype class-constraint inference rule. Incomplete. --- --- Revision 1.3 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.2 2003/10/24 21:05:08 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.1 2003/10/22 16:19:34 graham --- DatatypeXsdInteger module renamed to RDFDatatypeXsdInteger. --- --- Revision 1.2 2003/10/22 15:47:46 graham --- Working on datatype inference support. --- --- Revision 1.1 2003/10/09 17:16:59 graham --- Add initial attempt at xsd:integer datatype module --- diff --git a/Swish/HaskellRDF/RDFDatatypeXsdIntegerTest.hs b/Swish/HaskellRDF/RDFDatatypeXsdIntegerTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFDatatypeXsdIntegerTest.hs +++ /dev/null @@ -1,1667 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFDatatypeXsdIntegerTest.hs,v 1.13 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdIntegerTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for variable binding values and --- variable binding modifier values. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.RDFDatatypeXsdIntegerTest where - -import Swish.HaskellRDF.RDFDatatypeXsdInteger - ( rdfDatatypeXsdInteger - , rdfDatatypeValXsdInteger - , typeNameXsdInteger, namespaceXsdInteger - , axiomsXsdInteger, rulesXsdInteger - , prefixXsdInteger - ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFClosure, RDFRuleset - , makeRDFGraphFromN3String - , makeRDFFormula - ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , applyRDFDatatypeMod - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..), RDFGraph - ) - -import Swish.HaskellRDF.ClassRestrictionRule - ( ClassRestriction(..), ClassRestrictionFn - , makeDatatypeRestriction, makeDatatypeRestrictionFn - , makeRDFClassRestrictionRules - , makeRDFDatatypeRestrictionRules - , falseGraph, falseGraphStr - ) - -import Swish.HaskellRDF.Datatype - ( Datatype(..) - , typeName, typeRules, typeMkRules - , getTypeAxiom, getTypeRule - , DatatypeVal(..) - , getDTMod - , DatatypeMap(..) - , DatatypeMod(..) - , nullDatatypeMod - ) - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - , getRulesetAxiom, getRulesetRule - ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) - , nullScope, nullFormula, nullRule - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , makeVarBinding - , VarBindingModify(..) - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - , makeScopedName - , matchName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceNull - , namespaceRDF - , namespaceRDFS - , namespaceXSD - , namespaceMATH - , namespaceXsdType - , namespaceDefault - , scopeRDF - , scopeRDFS - , scopeRDFD - ) - -import Swish.HaskellUtils.QName - ( QName(..) - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFind, mapFindMaybe - ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , Assertion - , assertBool, assertEqual, assertString, assertFailure - , runTestTT, runTestText, putTextToHandle - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Control.Monad ( unless ) - -import Data.List - ( sort, union, intersect ) - -import Data.Maybe - ( isJust, fromJust, fromMaybe ) - - ------------------------------------------------------------- --- 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 bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - -testElem :: (Eq a, Show a) => String -> a -> [a] -> Test -testElem lab a1 as = - TestCase ( assertMember ("testElem:"++lab) a1 as ) - -testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test -testLe lab eq a1 a2 = - TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) - --- Test for Just x or Nothing - -testJust :: String -> Maybe a -> Test -testJust lab av = - TestCase ( assertBool ("testJust:"++lab) (isJust av) ) - -testNothing :: String -> Maybe a -> Test -testNothing lab av = - TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) - --- Compare lists and lists of lists and Maybe lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - -testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqvEqv lab a1 a2 = - TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest $ map ListTest a1 - ma2 = ListTest $ map ListTest a2 - -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test -testHasEqv lab a1 a2 = - TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest a1 - ma2 = map ListTest a2 - -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv lab a1 a2 = - TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) - where - ma1 = (MaybeListTest a1) - ma2 = (MaybeListTest a2) - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - -xsd_int_name nam = (ScopedName namespaceXsdInteger nam) - -axiomXsdIntegerDT = xsd_int_name "dt" - -ruleXsdIntegerAbs = xsd_int_name "Abs" -ruleXsdIntegerNeg = xsd_int_name "Neg" -ruleXsdIntegerSum = xsd_int_name "Sum" -ruleXsdIntegerDiff = xsd_int_name "Diff" -ruleXsdIntegerProd = xsd_int_name "Prod" -ruleXsdIntegerDivMod = xsd_int_name "DivMod" -ruleXsdIntegerPower = xsd_int_name "Power" -ruleXsdIntegerEq = xsd_int_name "Eq" -ruleXsdIntegerNe = xsd_int_name "Ne" -ruleXsdIntegerLt = xsd_int_name "Lt" -ruleXsdIntegerLe = xsd_int_name "Le" -ruleXsdIntegerGt = xsd_int_name "Gt" -ruleXsdIntegerGe = xsd_int_name "Ge" - ------------------------------------------------------------- --- Basic rdfDatatypeXsdInteger tests ------------------------------------------------------------- - -getXsdIntegerAxiom scopnam = - fromMaybe nullFormula $ getTypeAxiom scopnam rdfDatatypeXsdInteger - -getXsdIntegerRule scopnam = - fromMaybe nullRule $ getTypeRule scopnam rdfDatatypeXsdInteger - -getXsdIntegerDTmod scopnam = - fromMaybe nullDatatypeMod $ getDTMod scopnam rdfDatatypeValXsdInteger - -testDatatype01 = testEq "testDatatype01" typeNameXsdInteger $ - typeName rdfDatatypeXsdInteger -testDatatype02 = testEq "testDatatype02" namespaceXsdInteger $ - rsNamespace (typeRules rdfDatatypeXsdInteger) -testDatatype03 = testEqv "testDatatype03" axiomsXsdInteger $ - rsAxioms (typeRules rdfDatatypeXsdInteger) -testDatatype04 = testEqv "testDatatype04" rulesXsdInteger $ - rsRules (typeRules rdfDatatypeXsdInteger) -testDatatype05 = testEq "testDatatype05" axiomXsdIntegerDT $ - formName (getXsdIntegerAxiom axiomXsdIntegerDT) -testDatatype06 = testEq "testDatatype06" ruleXsdIntegerAbs $ - ruleName (getXsdIntegerRule ruleXsdIntegerAbs) - -testDatatypeSuite = TestList - [ testDatatype01, testDatatype02, testDatatype03, testDatatype04 - , testDatatype05, testDatatype06 - ] - ------------------------------------------------------------- --- Basic rdfDatatypeValXsdInteger tests ------------------------------------------------------------- - -testDatatypeVal01 = testEq "testDatatypeVal01" (Just 123) $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "123" -testDatatypeVal02 = testEq "testDatatypeVal02" (Just 0) $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "0" -testDatatypeVal03 = testEq "testDatatypeVal03" (Just 456) $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "+000456" -testDatatypeVal04 = testEq "testDatatypeVal04" (Just (-987)) $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "-0987" -testDatatypeVal05 = testEq "testDatatypeVal05" Nothing $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "11x2" -testDatatypeVal06 = testEq "testDatatypeVal06" Nothing $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) " 321" -testDatatypeVal07 = testEq "testDatatypeVal07" Nothing $ - mapL2V (tvalMap rdfDatatypeValXsdInteger) "321 " - -testDatatypeVal11 = testEq "testDatatypeVal11" (Just "123") $ - mapV2L (tvalMap rdfDatatypeValXsdInteger) 123 -testDatatypeVal12 = testEq "testDatatypeVal12" (Just "-987") $ - mapV2L (tvalMap rdfDatatypeValXsdInteger) (-987) - -testDatatypeVal21 = testElem "testDatatypeVal21" dmodXsdIntegerAbs $ - map dmName (tvalMod rdfDatatypeValXsdInteger) -testDatatypeVal22 = testEq "testDatatypeVal22" dmodXsdIntegerAbs $ - dmName (getXsdIntegerDTmod dmodXsdIntegerAbs) - -testDatatypeValSuite = TestList - [ testDatatypeVal01, testDatatypeVal02, testDatatypeVal03, testDatatypeVal04 - , testDatatypeVal05, testDatatypeVal06, testDatatypeVal07 - , testDatatypeVal11, testDatatypeVal12 - , testDatatypeVal21, testDatatypeVal22 - ] - ------------------------------------------------------------- --- Variable binding modifier tests ------------------------------------------------------------- - -dmodXsdIntegerAbs = xsd_int_name "abs" -dmodXsdIntegerNeg = xsd_int_name "neg" -dmodXsdIntegerSum = xsd_int_name "sum" -dmodXsdIntegerDiff = xsd_int_name "diff" -dmodXsdIntegerProd = xsd_int_name "prod" -dmodXsdIntegerDivMod = xsd_int_name "divmod" -dmodXsdIntegerPower = xsd_int_name "power" -dmodXsdIntegerEq = xsd_int_name "eq" -dmodXsdIntegerNe = xsd_int_name "ne" -dmodXsdIntegerLt = xsd_int_name "lt" -dmodXsdIntegerLe = xsd_int_name "le" -dmodXsdIntegerGt = xsd_int_name "gt" -dmodXsdIntegerGe = xsd_int_name "ge" - -testVmod2 = testVmodN [(Var "a"),(Var "b")] - -testVmod3 = testVmodN [(Var "a"),(Var "b"),(Var "c")] - -testVmod4 = testVmodN [(Var "a"),(Var "b"),(Var "c"),(Var "d")] - -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 vars lab Nothing ibinds obinds = TestCase $ - assertFailure $ "testVmodN:"++lab++", null variable binding modifier" - --- make various kinds of RDF variable bindings -rdfVR (v,u) = (Var v,Res u) -- (Variable,Resource) -rdfVB (v,b) = (Var v,Blank b) -- (Variable,Blank) -rdfVL (v,l) = (Var v,Lit l Nothing) -- (Variable,Untyped literal) -rdfVI (v,l) = (Var v,Lit l (Just 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 = testVmod2 "testVarModify00" - (Just nullDatatypeMod) - [makeBVI [("a","123")]] - [makeBVI [("a","123")]] - --- Tests for xsd_integer:abs - -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 "" "http://ex.org/" "123")]] - [] - -testVarModifyAbs10 = testVmod2 "testVarModifyAbs10" - (getDTMod dmodXsdIntegerAbs rdfDatatypeValXsdInteger) - [makeBVB [("b","123")]] - [] - --- Tests for xsd_integer:neg - -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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 = 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 ------------------------------------------------------------- - -mkGraph grstr = makeRDFGraphFromN3String (prefixXsdInteger++base++grstr) - where - base = "@prefix : <"++nsURI namespaceDefault++"> . \n" - -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 lab (Just rule) antstr prestrss = - let - antgr = mkGraph antstr - pregrss = map (map mkGraph) prestrss - in - testEqvEqv lab pregrss $ bwdApply rule antgr -testRuleBwd lab Nothing _ _ = TestCase $ - assertFailure $ "testRuleBwd:"++lab++", null rule supplied" - -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 = (typeRules rdfDatatypeXsdInteger) - -axdt = getRulesetAxiom axiomXsdIntegerDT xsdIntRules - -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 - --- abs - -abs01inp = - "_:a a xsd_integer:Abs ; " - +++ " rdf:_2 \"1\"^^xsd:integer . " -abs01fwd = - [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] -abs01bwd = [] -testRuleFwdAbs01 = testRuleFwd "testRuleFwdAbs01" ruleabs abs01inp abs01fwd -testRuleBwdAbs01 = testRuleBwd "testRuleBwdAbs01" ruleabs abs01inp abs01bwd - -abs02inp = - "_:a a xsd_integer:Abs ; " - +++ " rdf:_2 \"-1\"^^xsd:integer . " -abs02fwd = - [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] -abs02bwd = - [] -testRuleFwdAbs02 = testRuleFwd "testRuleFwdAbs02" ruleabs abs02inp abs02fwd -testRuleBwdAbs02 = testRuleBwd "testRuleBwdAbs02" ruleabs abs02inp abs02bwd - -abs03inp = - "_:a a xsd_integer:Abs ; " - +++ " rdf:_1 \"1\"^^xsd:integer . " -abs03fwd = [] -abs03bwd = - [ [ "_:a a xsd_integer:Abs . " - , "_:a rdf:_2 \"1\"^^xsd:integer . " - ] - , [ "_:a a xsd_integer:Abs . " - , "_:a rdf:_2 \"-1\"^^xsd:integer . " - ] - ] -testRuleFwdAbs03 = testRuleFwd "testRuleFwdAbs03" ruleabs abs03inp abs03fwd -testRuleBwdAbs03 = testRuleBwd "testRuleBwdAbs03" ruleabs abs03inp abs03bwd - -abs04inp = - "_:a a xsd_integer:Abs ; " - +++ " rdf:_1 \"-1\"^^xsd:integer . " -abs04fwd = - [ falseGraphStr - ] -abs04bwd = - [ [ falseGraphStr - ] - ] -testRuleFwdAbs04 = testRuleFwd "testRuleFwdAbs04" ruleabs abs04inp abs04fwd -testRuleBwdAbs04 = testRuleBwd "testRuleBwdAbs04" ruleabs abs04inp abs04bwd - --- neg - -neg01inp = - "_:a a xsd_integer:Neg ; " - +++ " rdf:_2 \"1\"^^xsd:integer . " -neg01fwd = - [ "_:a rdf:_1 \"-1\"^^xsd:integer . " ] -neg01bwd = - [ [ "_:a a xsd_integer:Neg . " - , "_:a rdf:_1 \"-1\"^^xsd:integer . " - ] - ] -testRuleFwdNeg01 = testRuleFwd "testRuleFwdNeg01" ruleneg neg01inp neg01fwd -testRuleBwdNeg01 = testRuleBwd "testRuleBwdNeg01" ruleneg neg01inp neg01bwd - -neg02inp = - "_:a a xsd_integer:Neg ; " - +++ " rdf:_2 \"-2\"^^xsd:integer . " -neg02fwd = - [ "_:a rdf:_1 \"2\"^^xsd:integer . " ] -neg02bwd = - [ [ "_:a a xsd_integer:Neg . " - , "_:a rdf:_1 \"2\"^^xsd:integer . " - ] - ] -testRuleFwdNeg02 = testRuleFwd "testRuleFwdNeg02" ruleneg neg02inp neg02fwd -testRuleBwdNeg02 = testRuleBwd "testRuleBwdNeg02" ruleneg neg02inp neg02bwd - --- sum - -sum01inp = - "_:a a xsd_integer:Sum ; " - +++ " rdf:_2 \"31\"^^xsd:integer ; " - +++ " rdf:_3 \"20\"^^xsd:integer . " -sum01fwd = - [ "_:a rdf:_1 \"51\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdSum01 = testRuleFwd "testRuleFwdSum01" rulesum sum01inp sum01fwd -testRuleBwdSum01 = testRuleBwd "testRuleBwdSum01" rulesum sum01inp sum01bwd - -sum02inp = - "_:a a xsd_integer:Sum ; " - +++ " rdf:_1 \"52\"^^xsd:integer ; " - +++ " rdf:_3 \"21\"^^xsd:integer . " -sum02fwd = - [ "_:a rdf:_2 \"31\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdSum02 = testRuleFwd "testRuleFwdSum02" rulesum sum02inp sum02fwd -testRuleBwdSum02 = testRuleBwd "testRuleBwdSum02" rulesum sum02inp sum02bwd - -sum03inp = - "_:a a xsd_integer:Sum ; " - +++ " rdf:_1 \"53\"^^xsd:integer ; " - +++ " rdf:_2 \"32\"^^xsd:integer . " -sum03fwd = - [ "_:a rdf:_3 \"21\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdSum03 = testRuleFwd "testRuleFwdSum03" rulesum sum03inp sum03fwd -testRuleBwdSum03 = testRuleBwd "testRuleBwdSum03" rulesum sum03inp sum03bwd - --- diff - -diff01inp = - "_:a a xsd_integer:Diff ; " - +++ " rdf:_2 \"222\"^^xsd:integer ; " - +++ " rdf:_3 \"333\"^^xsd:integer . " -diff01fwd = - [ "_:a rdf:_1 \"-111\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdDiff01 = testRuleFwd "testRuleFwdDiff01" rulediff diff01inp diff01fwd -testRuleBwdDiff01 = testRuleBwd "testRuleBwdDiff01" rulediff diff01inp diff01bwd - -diff02inp = - "_:a a xsd_integer:Diff ; " - +++ " rdf:_1 \"-111\"^^xsd:integer ; " - +++ " rdf:_3 \"333\"^^xsd:integer . " -diff02fwd = - [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdDiff02 = testRuleFwd "testRuleFwdDiff02" rulediff diff02inp diff02fwd -testRuleBwdDiff02 = testRuleBwd "testRuleBwdDiff02" rulediff diff02inp diff02bwd - -diff03inp = - "_:a a xsd_integer:Diff ; " - +++ " rdf:_1 \"-111\"^^xsd:integer ; " - +++ " rdf:_2 \"222\"^^xsd:integer . " -diff03fwd = - [ "_:a rdf:_3 \"333\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdDiff03 = testRuleFwd "testRuleFwdDiff03" rulediff diff03inp diff03fwd -testRuleBwdDiff03 = testRuleBwd "testRuleBwdDiff03" rulediff diff03inp diff03bwd - --- prod - -prod01inp = - "_:a a xsd_integer:Prod ; " - +++ " rdf:_2 \"222\"^^xsd:integer ; " - +++ " rdf:_3 \"3\"^^xsd:integer . " -prod01fwd = - [ "_:a rdf:_1 \"666\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdProd01 = testRuleFwd "testRuleFwdProd01" ruleprod prod01inp prod01fwd -testRuleBwdProd01 = testRuleBwd "testRuleBwdProd01" ruleprod prod01inp prod01bwd - -prod02inp = - "_:a a xsd_integer:Prod ; " - +++ " rdf:_1 \"666\"^^xsd:integer ; " - +++ " rdf:_3 \"3\"^^xsd:integer . " -prod02fwd = - [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdProd02 = testRuleFwd "testRuleFwdProd02" ruleprod prod02inp prod02fwd -testRuleBwdProd02 = testRuleBwd "testRuleBwdProd02" ruleprod prod02inp prod02bwd - -prod03inp = - "_:a a xsd_integer:Prod ; " - +++ " rdf:_1 \"666\"^^xsd:integer ; " - +++ " rdf:_2 \"222\"^^xsd:integer . " -prod03fwd = - [ "_:a rdf:_3 \"3\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdProd03 = testRuleFwd "testRuleFwdProd03" ruleprod prod03inp prod03fwd -testRuleBwdProd03 = testRuleBwd "testRuleBwdProd03" ruleprod prod03inp prod03bwd - --- divmod - -divmod01inp = - "_:a a xsd_integer:DivMod ; " - +++ " rdf:_3 \"33\"^^xsd:integer ; " - +++ " rdf:_4 \"5\"^^xsd:integer . " -divmod01fwd = - [ "_:a rdf:_1 \"6\"^^xsd:integer . " - +++ "_:a rdf:_2 \"3\"^^xsd:integer . " - ] -divmod01bwd = - [ {- "_:a a xsd_integer:DivMod . " - , "_:a rdf:_1 \"6\"^^xsd:integer . " - , "_:a rdf:_2 \"3\"^^xsd:integer . " - , "_:a rdf:_4 \"5\"^^xsd:integer . " - -} - ] -testRuleFwdDivMod01 = testRuleFwd "testRuleFwdDivMod01" ruledivmod divmod01inp divmod01fwd -testRuleBwdDivMod01 = testRuleBwd "testRuleBwdDivMod01" ruledivmod divmod01inp divmod01bwd - -divmod02inp = - "_:a a xsd_integer:DivMod ; " - +++ " rdf:_1 \"6\"^^xsd:integer ; " - +++ " rdf:_2 \"3\"^^xsd:integer ; " - +++ " rdf:_4 \"5\"^^xsd:integer . " -divmod02fwd = - [ ] -divmod02bwd = - [ {- "_:a a xsd_integer:DivMod . " - , "_:a rdf:_3 \"33\"^^xsd:integer . " - , "_:a rdf:_4 \"5\"^^xsd:integer . " - -} - ] -testRuleFwdDivMod02 = testRuleFwd "testRuleFwdDivMod02" ruledivmod divmod02inp divmod02fwd -testRuleBwdDivMod02 = testRuleBwd "testRuleBwdDivMod02" ruledivmod divmod02inp divmod02bwd - -divmod03inp = - "_:a a xsd_integer:DivMod ; " - +++ " rdf:_3 \"-33\"^^xsd:integer ; " - +++ " rdf:_4 \"5\"^^xsd:integer . " -divmod03fwd = - [ "_:a rdf:_1 \"-7\"^^xsd:integer . " - +++ "_:a rdf:_2 \"2\"^^xsd:integer . " - ] -divmod03bwd = - [ ] -testRuleFwdDivMod03 = testRuleFwd "testRuleFwdDivMod03" ruledivmod divmod03inp divmod03fwd -testRuleBwdDivMod03 = testRuleBwd "testRuleBwdDivMod03" ruledivmod divmod03inp divmod03bwd - --- power - -power01inp = - "_:a a xsd_integer:Power ; " - +++ " rdf:_2 \"2\"^^xsd:integer ; " - +++ " rdf:_3 \"5\"^^xsd:integer . " -power01fwd = - [ "_:a rdf:_1 \"32\"^^xsd:integer . " ] -power01bwd = - [ ] -testRuleFwdPower01 = testRuleFwd "testRuleFwdPower01" rulepower power01inp power01fwd -testRuleBwdPower01 = testRuleBwd "testRuleBwdPower01" rulepower power01inp power01bwd - -power02inp = - "_:a a xsd_integer:Power ; " - +++ " rdf:_2 \"111\"^^xsd:integer ; " - +++ " rdf:_3 \"0\"^^xsd:integer . " -power02fwd = - [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] -power02bwd = - [ ] -testRuleFwdPower02 = testRuleFwd "testRuleFwdPower02" rulepower power02inp power02fwd -testRuleBwdPower02 = testRuleBwd "testRuleBwdPower02" rulepower power02inp power02bwd - -power03inp = - "_:a a xsd_integer:Power ; " - +++ " rdf:_2 \"22\"^^xsd:integer ; " - +++ " rdf:_3 \"-33\"^^xsd:integer . " -power03fwd = - [ falseGraphStr ] -power03bwd = - [ [ falseGraphStr ] - ] -testRuleFwdPower03 = testRuleFwd "testRuleFwdPower03" rulepower power03inp power03fwd -testRuleBwdPower03 = testRuleBwd "testRuleBwdPower03" rulepower power03inp power03bwd - --- eq - -eq01inp = - "_:a a xsd_integer:Eq ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -eq01fwd = [ ] -eq01bwd = [ ] -testRuleFwdEq01 = testRuleFwd "testRuleFwdEq01" ruleeq eq01inp eq01fwd -testRuleBwdEq01 = testRuleBwd "testRuleBwdEq01" ruleeq eq01inp eq01bwd - -eq02inp = - "_:a a xsd_integer:Eq ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -eq02fwd = [ falseGraphStr ] -eq02bwd = [ [falseGraphStr] ] -testRuleFwdEq02 = testRuleFwd "testRuleFwdEq02" ruleeq eq02inp eq02fwd -testRuleBwdEq02 = testRuleBwd "testRuleBwdEq02" ruleeq eq02inp eq02bwd - -eq03inp = - "_:a a xsd_integer:Eq ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -eq03fwd = [ falseGraphStr ] -eq03bwd = [ [falseGraphStr] ] -testRuleFwdEq03 = testRuleFwd "testRuleFwdEq03" ruleeq eq03inp eq03fwd -testRuleBwdEq03 = testRuleBwd "testRuleBwdEq03" ruleeq eq03inp eq03bwd - --- ne - -ne01inp = - "_:a a xsd_integer:Ne ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -ne01fwd = [ falseGraphStr ] -ne01bwd = [ [falseGraphStr] ] -testRuleFwdNe01 = testRuleFwd "testRuleFwdNe01" rulene ne01inp ne01fwd -testRuleBwdNe01 = testRuleBwd "testRuleBwdNe01" rulene ne01inp ne01bwd - -ne02inp = - "_:a a xsd_integer:Ne ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -ne02fwd = [ ] -ne02bwd = [ ] -testRuleFwdNe02 = testRuleFwd "testRuleFwdNe02" rulene ne02inp ne02fwd -testRuleBwdNe02 = testRuleBwd "testRuleBwdNe02" rulene ne02inp ne02bwd - -ne03inp = - "_:a a xsd_integer:Ne ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -ne03fwd = [ ] -ne03bwd = [ ] -testRuleFwdNe03 = testRuleFwd "testRuleFwdNe03" rulene ne03inp ne03fwd -testRuleBwdNe03 = testRuleBwd "testRuleBwdNe03" rulene ne03inp ne03bwd - --- lt - -lt01inp = - "_:a a xsd_integer:Lt ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -lt01fwd = [ falseGraphStr ] -lt01bwd = [ [falseGraphStr] ] -testRuleFwdLt01 = testRuleFwd "testRuleFwdLt01" rulelt lt01inp lt01fwd -testRuleBwdLt01 = testRuleBwd "testRuleBwdLt01" rulelt lt01inp lt01bwd - -lt02inp = - "_:a a xsd_integer:Lt ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -lt02fwd = [ ] -lt02bwd = [ ] -testRuleFwdLt02 = testRuleFwd "testRuleFwdLt02" rulelt lt02inp lt02fwd -testRuleBwdLt02 = testRuleBwd "testRuleBwdLt02" rulelt lt02inp lt02bwd - -lt03inp = - "_:a a xsd_integer:Lt ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -lt03fwd = [ falseGraphStr ] -lt03bwd = [ [falseGraphStr] ] -testRuleFwdLt03 = testRuleFwd "testRuleFwdLt03" rulelt lt03inp lt03fwd -testRuleBwdLt03 = testRuleBwd "testRuleBwdLt03" rulelt lt03inp lt03bwd - --- le - -le01inp = - "_:a a xsd_integer:Le ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -le01fwd = [ ] -le01bwd = [ ] -testRuleFwdLe01 = testRuleFwd "testRuleFwdLe01" rulele le01inp le01fwd -testRuleBwdLe01 = testRuleBwd "testRuleBwdLe01" rulele le01inp le01bwd - -le02inp = - "_:a a xsd_integer:Le ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -le02fwd = [ ] -le02bwd = [ ] -testRuleFwdLe02 = testRuleFwd "testRuleFwdLe02" rulele le02inp le02fwd -testRuleBwdLe02 = testRuleBwd "testRuleBwdLe02" rulele le02inp le02bwd - -le03inp = - "_:a a xsd_integer:Le ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -le03fwd = [ falseGraphStr ] -le03bwd = [ [falseGraphStr] ] -testRuleFwdLe03 = testRuleFwd "testRuleFwdLe03" rulele le03inp le03fwd -testRuleBwdLe03 = testRuleBwd "testRuleBwdLe03" rulele le03inp le03bwd - --- gt - -gt01inp = - "_:a a xsd_integer:Gt ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -gt01fwd = [ falseGraphStr ] -gt01bwd = [ [falseGraphStr] ] -testRuleFwdGt01 = testRuleFwd "testRuleFwdGt01" rulegt gt01inp gt01fwd -testRuleBwdGt01 = testRuleBwd "testRuleBwdGt01" rulegt gt01inp gt01bwd - -gt02inp = - "_:a a xsd_integer:Gt ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -gt02fwd = [ falseGraphStr ] -gt02bwd = [ [falseGraphStr] ] -testRuleFwdGt02 = testRuleFwd "testRuleFwdGt02" rulegt gt02inp gt02fwd -testRuleBwdGt02 = testRuleBwd "testRuleBwdGt02" rulegt gt02inp gt02bwd - -gt03inp = - "_:a a xsd_integer:Gt ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -gt03fwd = [ ] -gt03bwd = [ ] -testRuleFwdGt03 = testRuleFwd "testRuleFwdGt03" rulegt gt03inp gt03fwd -testRuleBwdGt03 = testRuleBwd "testRuleBwdGt03" rulegt gt03inp gt03bwd - --- ge - -ge01inp = - "_:a a xsd_integer:Ge ; " - +++ " rdf:_1 \"11\"^^xsd:integer ; " - +++ " rdf:_2 \"11\"^^xsd:integer . " -ge01fwd = [ ] -ge01bwd = [ ] -testRuleFwdGe01 = testRuleFwd "testRuleFwdGe01" rulege ge01inp ge01fwd -testRuleBwdGe01 = testRuleBwd "testRuleBwdGe01" rulege ge01inp ge01bwd - -ge02inp = - "_:a a xsd_integer:Ge ; " - +++ " rdf:_1 \"21\"^^xsd:integer ; " - +++ " rdf:_2 \"22\"^^xsd:integer . " -ge02fwd = [ falseGraphStr ] -ge02bwd = [ [falseGraphStr] ] -testRuleFwdGe02 = testRuleFwd "testRuleFwdGe02" rulege ge02inp ge02fwd -testRuleBwdGe02 = testRuleBwd "testRuleBwdGe02" rulege ge02inp ge02bwd - -ge03inp = - "_:a a xsd_integer:Ge ; " - +++ " rdf:_1 \"31\"^^xsd:integer ; " - +++ " rdf:_2 \"-32\"^^xsd:integer . " -ge03fwd = [ ] -ge03bwd = [ ] -testRuleFwdGe03 = testRuleFwd "testRuleFwdGe03" rulege ge03inp ge03fwd -testRuleBwdGe03 = testRuleBwd "testRuleBwdGe03" rulege ge03inp ge03bwd - --- Test cases from design notes - -infixr 5 +++ -(+++) :: String -> ShowS -(+++) str = ((str++"\n")++) - --- Make a vector of rules using the graph string below - -pvRules :: [RDFRule] --- pvRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr -pvRules = typeMkRules rdfDatatypeXsdInteger gr - where - gr = (mkGraph pvRulesStr) - -pvRulesStr = - ":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 = mapFindMaybe - (ScopedName namespaceDefault "PassengerVehicle") - (LookupMap pvRules) -pvRule1 = mapFindMaybe - (ScopedName namespaceDefault "PassengerVehicle1") - (LookupMap pvRules) - -pv01inp = - "_:a a :PassengerVehicle ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :standingCapacity \"20\"^^xsd:integer . " -pv01fwd = - [ "_:a :totalCapacity \"50\"^^xsd:integer . " ] -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 . " - ] - ] -testRuleFwdPv01 = testRuleFwd "testRuleFwdPv01" pvRule0 pv01inp pv01fwd -testRuleBwdPv01 = testRuleBwd "testRuleBwdPv01" pvRule0 pv01inp pv01bwd - -pv02inp = - "_:a a :PassengerVehicle ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :totalCapacity \"51\"^^xsd:integer . " - +++ "_:b a :PassengerVehicle ; " - +++ " :standingCapacity \"20\"^^xsd:integer ; " - +++ " :totalCapacity \"52\"^^xsd:integer . " -pv02fwd = - [ "_:a :standingCapacity \"21\"^^xsd:integer . " - , "_:b :seatedCapacity \"32\"^^xsd:integer . " - ] -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 . " - ] - ] -testRuleFwdPv02 = testRuleFwd "testRuleFwdPv02" pvRule0 pv02inp pv02fwd -testRuleBwdPv02 = testRuleBwd "testRuleBwdPv02" pvRule0 pv02inp pv02bwd - -pv03inp = - "_:a a :PassengerVehicle ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :standingCapacity \"23\"^^xsd:integer ; " - +++ " :totalCapacity \"53\"^^xsd:integer . " -pv03fwd = [] -testRuleFwdPv03 = testRuleFwd "testRuleFwdPv03" pvRule0 pv03inp pv03fwd - -pv04inp = - "_:a a :PassengerVehicle ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :standingCapacity \"20\"^^xsd:integer ; " - +++ " :totalCapacity \"54\"^^xsd:integer . " -pv04fwd = - [ "_:a :standingCapacity \"24\"^^xsd:integer . " - +++ "_:a :seatedCapacity \"34\"^^xsd:integer . " - +++ "_:a :totalCapacity \"50\"^^xsd:integer . " - ] -testRuleFwdPv04 = testRuleFwd "testRuleFwdPv04" pvRule0 pv04inp pv04fwd - -pv05inp = - "_:a a :PassengerVehicle1 ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :standingCapacity \"25\"^^xsd:integer ; " - +++ " :totalCapacity \"55\"^^xsd:integer . " -pv05fwd = [] -testRuleFwdPv05 = testRuleFwd "testRuleFwdPv05" pvRule1 pv05inp pv05fwd - -pv06inp = - "_:a a :PassengerVehicle1 ; " - +++ " :seatedCapacity \"30\"^^xsd:integer ; " - +++ " :standingCapacity \"20\"^^xsd:integer ; " - +++ " :totalCapacity \"56\"^^xsd:integer . " -pv06fwd = - [ falseGraphStr - ] -pv06bwd = - [ [ falseGraphStr - ] - ] -testRuleFwdPv06 = testRuleFwd "testRuleFwdPv06" pvRule1 pv06inp pv06fwd -testRuleBwdPv06 = testRuleBwd "testRuleBwdPv06" pvRule1 pv06inp pv06bwd - -pv07inp = - "_:a a :PassengerVehicle ; " - +++ " :totalCapacity \"57\"^^xsd:integer . " -pv07fwd = [] -pv07bwd = [] -testRuleFwdPv07 = testRuleFwd "testRuleFwdPv07" pvRule0 pv07inp pv07fwd -testRuleBwdPv07 = testRuleFwd "testRuleBwdPv07" pvRule0 pv07inp pv07bwd - --- Full suite for datatype rule tests - -testDatatypeRuleSuite = TestList - [ testRuleFwdAbs01, testRuleFwdAbs02, testRuleFwdAbs03, testRuleFwdAbs04 - , testRuleFwdNeg01, testRuleFwdNeg02 - , testRuleFwdSum01, testRuleFwdSum02, testRuleFwdSum03 - , testRuleFwdDiff01, testRuleFwdDiff02, testRuleFwdDiff03 - , testRuleFwdProd01, testRuleFwdProd02, testRuleFwdProd03 - , testRuleFwdDivMod01, testRuleFwdDivMod02, testRuleFwdDivMod03 - , testRuleFwdPower01, testRuleFwdPower02, testRuleFwdPower03 - , testRuleFwdEq01, testRuleFwdEq02, testRuleFwdEq03 - , testRuleFwdNe01, testRuleFwdNe02, testRuleFwdNe03 - , testRuleFwdLt01, testRuleFwdLt02, testRuleFwdLt03 - , testRuleFwdLe01, testRuleFwdLe02, testRuleFwdLe03 - , testRuleFwdGt01, testRuleFwdGt02, testRuleFwdGt03 - , testRuleFwdGe01, testRuleFwdGe02, testRuleFwdGe03 - -- backard chaining tests - , testRuleBwdAbs01, testRuleBwdAbs02, testRuleBwdAbs03, testRuleBwdAbs04 - , testRuleBwdNeg01, testRuleBwdNeg02 - , testRuleBwdSum01, testRuleBwdSum02, testRuleBwdSum03 - , testRuleBwdDiff01, testRuleBwdDiff02, testRuleBwdDiff03 - , testRuleBwdProd01, testRuleBwdProd02, testRuleBwdProd03 - , testRuleBwdDivMod01, testRuleBwdDivMod02, testRuleBwdDivMod03 - , testRuleBwdPower01, testRuleBwdPower02, testRuleBwdPower03 - , testRuleBwdEq01, testRuleBwdEq02, testRuleBwdEq03 - , testRuleBwdNe01, testRuleBwdNe02, testRuleBwdNe03 - , testRuleBwdLt01, testRuleBwdLt02, testRuleBwdLt03 - , testRuleBwdLe01, testRuleBwdLe02, testRuleBwdLe03 - , testRuleBwdGt01, testRuleBwdGt02, testRuleBwdGt03 - , testRuleBwdGe01, testRuleBwdGe02, testRuleBwdGe03 - -- test cases from design notes - , testRuleFwdPv01, testRuleFwdPv02, testRuleFwdPv03, testRuleFwdPv04 - , testRuleFwdPv05, testRuleFwdPv06, testRuleFwdPv07 - , testRuleBwdPv01, testRuleBwdPv02, testRuleBwdPv06, testRuleBwdPv07 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testDatatypeSuite - , testDatatypeValSuite - , testVarModifySuite - , testDatatypeRuleSuite - ] - -main = runTestTT allTests -trules = runTestTT testDatatypeRuleSuite - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFDatatypeXsdIntegerTest.hs,v $ --- $Author: graham $ --- $Revision: 1.13 $ --- $Log: RDFDatatypeXsdIntegerTest.hs,v $ --- Revision 1.13 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.12 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.11 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.10 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.9 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.8 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.7 2003/11/27 11:35:49 graham --- Variable modifier tests all run. --- Initial class constraint reasoning tests pass. --- Fixed bug in class constraint backward-chained reasoning that returned --- multiple instances of some statements, and did not filter out all occurrences --- of the original statements. --- --- Revision 1.6 2003/11/25 23:02:17 graham --- Reworked datatype variable modifier logic. --- Limited range of test cases so far all pass. --- --- Revision 1.5 2003/11/24 22:13:09 graham --- Working on reworking datatype variable modifiers to work with --- revised datatype framework. --- --- Revision 1.4 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.3 2003/11/11 21:02:55 graham --- Working on datatype class-constraint inference rule. Incomplete. --- --- Revision 1.2 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.1 2003/10/24 21:05:09 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- diff --git a/Swish/HaskellRDF/RDFDatatypeXsdString.hs b/Swish/HaskellRDF/RDFDatatypeXsdString.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFDatatypeXsdString.hs +++ /dev/null @@ -1,362 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFDatatypeXsdString.hs,v 1.2 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFDatatypeXsdString --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines the structures used by swish to represent and --- manipulate RDF xsd:string datatyped literals. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFDatatypeXsdString - ( rdfDatatypeXsdString - , rdfDatatypeValXsdString - , typeNameXsdString, namespaceXsdString - , axiomsXsdString, rulesXsdString - , prefixXsdString - ) -where - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula - , makeRDFGraphFromN3String - , makeRDFFormula - , makeN3ClosureRule - ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBindingModify - ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype - , RDFDatatypeVal - , RDFDatatypeMod - , makeRdfDtOpenVarBindingModifiers - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) ) - -import Swish.HaskellRDF.ClassRestrictionRule - ( makeRDFDatatypeRestrictionRules - ) - -import Swish.HaskellRDF.Datatype - ( Datatype(..) - , DatatypeVal(..) - , DatatypeMap(..) - , DatatypeRel(..), DatatypeRelPr - , altArgs - , UnaryFnTable, unaryFnApp - , BinaryFnTable, binaryFnApp - , BinMaybeFnTable, binMaybeFnApp - , DatatypeMod(..) - , makeVmod_2_0 - ) - -import Swish.HaskellRDF.Ruleset - ( makeRuleset - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceXsdType - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , addVarBinding - , VarBindingModify(..) - ) - -{- in Prelude??? -import Maybe - ( Maybe (..), maybeToList ) - -import Monad - ( liftM ) --} - ------------------------------------------------------------- --- Misc values ------------------------------------------------------------- - --- Local name for Integer datatype -nameXsdString = "string" - --- |Type name for xsd:integer datatype -typeNameXsdString = ScopedName namespaceXSD nameXsdString - --- |Namespace for xsd:integer datatype functions -namespaceXsdString = namespaceXsdType nameXsdString - --- Helper to catenate strings with newline separator, --- used for making textual representations of graphs. --- (the newline makes N3 parser diagnostics easier to interpret) --- -infixr 5 +++ -(+++) :: String -> ShowS -(+++) str = ((str++"\n")++) - --- Compose with function of two arguments -c2 = (.) . (.) - ------------------------------------------------------------- --- Declare exported RDFDatatype value for xsd:integer ------------------------------------------------------------- - -rdfDatatypeXsdString :: RDFDatatype -rdfDatatypeXsdString = Datatype rdfDatatypeValXsdString - ------------------------------------------------------------- --- Implmentation of RDFDatatypeVal for xsd:integer ------------------------------------------------------------- - --- |Define Datatype value for xsd:string --- -rdfDatatypeValXsdString :: RDFDatatypeVal String -rdfDatatypeValXsdString = DatatypeVal - { tvalName = typeNameXsdString - , tvalRules = rdfRulesetXsdString -- Ruleset RDFGraph - , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString - -- RDFGraph -> [RDFRules] - , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdString - , tvalMap = mapXsdString -- DatatypeMap Integer - , tvalRel = relXsdString -- [DatatypeRel Integer] - , tvalMod = modXsdString -- [DatatypeMod Integer] - } - --- |mapXsdString contains functions that perform lexical-to-value --- and value-to-canonical-lexical mappings for xsd:string values --- --- These are identity mappings. --- -mapXsdString :: DatatypeMap String -mapXsdString = DatatypeMap - { -- mapL2V :: String -> Maybe String - mapL2V = Just - -- mapV2L :: String -> Maybe String - , mapV2L = Just - } - --- |relXsdString contains useful relations for xsd:string values. --- -relXsdString :: [DatatypeRel String] -relXsdString = - [ relXsdStringEq - , relXsdStringNe - ] - -mkStrRel2 :: - String -> DatatypeRelPr String -> UnaryFnTable String - -> DatatypeRel String -mkStrRel2 nam pr fns = DatatypeRel - { dtRelName = ScopedName 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 String -relXsdStringEq = mkStrRel2 "eq" (lcomp (==)) - ( repeat (const True, []) ) - --- ne - -relXsdStringNe :: DatatypeRel String -relXsdStringNe = mkStrRel2 "ne" (lcomp (/=)) - ( repeat (const True, []) ) - --- |modXsdString contains variable binding modifiers for xsd:string values. --- -modXsdString :: [RDFDatatypeMod String] -modXsdString = - [ modXsdStringEq - , modXsdStringNe - ] - -modXsdStringEq = modXsdStringCompare "eq" (==) -modXsdStringNe = modXsdStringCompare "ne" (/=) - -modXsdStringCompare :: - String -> (String->String->Bool) -> RDFDatatypeMod String -modXsdStringCompare nam rel = DatatypeMod - { dmName = (ScopedName namespaceXsdString nam) - , dmModf = [ f0 ] - , dmAppf = makeVmod_2_0 - } - 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 = - makeRuleset namespaceXsdString axiomsXsdString rulesXsdString - -mkPrefix ns = - "@prefix " ++ nsPrefix ns ++ ": <" ++ nsURI ns ++ "> . \n" - -prefixXsdString = - mkPrefix namespaceRDF ++ - mkPrefix namespaceRDFS ++ - mkPrefix namespaceRDFD ++ - mkPrefix namespaceXSD ++ - mkPrefix namespaceXsdString ++ - " \n" - -mkAxiom :: String -> String -> RDFFormula -mkAxiom local gr = - makeRDFFormula namespaceXsdString local (prefixXsdString++gr) - -axiomsXsdString = - [ mkAxiom "dt" "xsd:string rdf:type rdfs:Datatype ." - ] - -rulesXsdString = rulesXsdStringClosure ++ rulesXsdStringRestriction - -rulesXsdStringRestriction = - makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString gr - where - gr = makeRDFGraphFromN3String rulesXsdStringStr - -rulesXsdStringStr = 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 = - [ xsdstrls - , xsdstrsl - ] - --- Infer string from plain literal -xsdstrls = makeN3ClosureRule namespaceXsdString "ls" - "?a ?p ?l ." - "?a ?p ?s ." - (stringPlain "?s" "?l") - --- Infer plain literal from string -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 (vn svar) (vn lvar) - where - vn ('?':n) = Var n - --- Variable binding modifier to create new binding to a canonical --- form of a datatyped literal. -stringPlainValue :: - RDFLabel -> RDFLabel -> RDFVarBindingModify -stringPlainValue svar lvar = VarBindingModify - { vbmName = ScopedName namespaceRDFD "stringPlain" - , vbmApply = concatMap app1 - , vbmVocab = [svar,lvar] - , vbmUsage = [[svar],[lvar],[]] - } - where - app1 vbind = app2 (vbMap vbind svar) (vbMap vbind lvar) vbind - app2 (Just (Lit s (Just typeNameXsdString))) - (Just (Lit l (Nothing))) - vbind - | s == l - = [vbind] - app2 (Just (Lit s (Just typeNameXsdString))) - (Nothing) - vbind - = [addVarBinding lvar (Lit s (Nothing)) vbind] - app2 (Nothing) - (Just (Lit l (Nothing))) - vbind - = [addVarBinding svar (Lit l (Just typeNameXsdString)) vbind] - app2 _ _ _ = [] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFDatatypeXsdString.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: RDFDatatypeXsdString.hs,v $ --- Revision 1.2 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.1 2003/12/18 20:46:24 graham --- Added xsd:string module to capture equivalence of xsd:string --- and plain literals without a language tag --- diff --git a/Swish/HaskellRDF/RDFGraph.hs b/Swish/HaskellRDF/RDFGraph.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFGraph.hs +++ /dev/null @@ -1,864 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} -{-# OPTIONS -XTypeSynonymInstances #-} - --------------------------------------------------------------------------------- --- $Id: RDFGraph.hs,v 1.48 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFGraph --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a memory-based RDF graph instance. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Simple labelled directed graph value ------------------------------------------------------------- - -module Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral - , isDatatyped, isMemberProp, isUri, isBlank, isQueryVar - , getLiteralText, getScopedName, makeBlank - , RDFTriple - , NSGraph(..), RDFGraph - , NamespaceMap, RevNamespaceMap - , emptyNamespaceMap - , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap - , addArc, merge - , allLabels, allNodes, remapLabels, remapLabelList - , newNode, newNodes - , setNamespaces, getNamespaces - , setFormulae, getFormulae, setFormula, getFormula - , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} - -- Re-export from GraphClass - , LDGraph(..), Label (..), Arc(..) - , arc, arcSubj, arcPred, arcObj, Selector - -- Export selected RDFLabel values - , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil - , res_rdfs_member - , res_rdfd_GeneralRestriction - , res_rdfd_onProperties, res_rdfd_constraint, res_rdfd_maxCardinality - , res_owl_sameAs - , res_operator_plus, res_operator_minus - , res_operator_slash, res_operator_star - -- Exported for testing: - , grMatchMap, grEq - , mapnode, maplist - ) -where - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , makeNamespaceQName - , getQName, getScopedNameURI - , ScopedName(..) - , makeScopedName, makeQNameScopedName - , nullScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceRDFC - , namespaceRDFO - , namespaceXSD - , namespaceXsdType - , namespaceOWL - , namespaceMATH - , namespaceLOG - , namespaceDAML - , namespaceLang, langTag, isLang - , rdf_type - , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral - , rdfs_member - , rdfd_GeneralRestriction - , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality - , owl_sameAs - , operator_plus, operator_minus, operator_slash, operator_star - ) - -import Swish.HaskellUtils.QName - ( QName(..) - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) - -import Swish.HaskellRDF.GraphClass - ( LDGraph(..), Label (..) - , Arc(..), arc, arcSubj, arcPred, arcObj - , Selector ) - -import Swish.HaskellRDF.GraphMatch - ( graphMatch, LabelMap(..), ScopedLabel(..) ) - -import Swish.HaskellUtils.MiscHelpers - ( hash, lower, quote ) - -import Swish.HaskellUtils.ListHelpers - ( addSetElem ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..), LookupEntryClass(..) - , mapFind, mapFindMaybe, mapReplaceOrAdd, mapEq, mapVals, mapKeys - , mapTranslateKeys, mapTranslateVals - , mapTranslateEntries, mapTranslateEntriesM ) - -import Swish.HaskellUtils.FunctorM - ( FunctorM(..) ) - -import Data.Char - ( isDigit ) - -import Data.Maybe - ( isJust ) - -import Data.List - ( nub, intersect, union, findIndices ) - ------------------------------------------------------------ --- RDF graph node values ------------------------------------------------------------- --- --- cf. http://www.w3.org/TR/rdf-concepts/#section-Graph-syntax --- --- This is extended from the RDF abstract graph syntax in the --- following ways: --- (a) a graph can be part of a resource node or blank node --- (cf. Notation3 formulae) --- (b) a "variable" node option is distinguished from a --- blank node. --- I have found this useful for encoding and handling --- queries, even though query variables can be expressed --- as blank nodes. --- (c) a "NoNode" option is defined. --- This might otherwise be handled by Maybe (RDFLabel g) - -data RDFLabel = - Res ScopedName -- resource - | Lit String (Maybe ScopedName) -- literal [type/language] - | Blank String -- blank node - | Var String -- variable (not used in ordinary graphs) - | NoNode -- no node (not used in ordinary graphs) - -instance Eq RDFLabel where - (==) = labelEq - -instance Show RDFLabel where - show (Res sn) = show sn - show (Lit st Nothing) = quote st - show (Lit st (Just nam)) - | isLang nam = quote st ++ "@" ++ (langTag nam) - | otherwise = quote st ++ "^^" ++ (show nam) - show (Blank ln) = "_:"++ln - show (Var ln) = "?"++ln - show NoNode = "" - -instance Ord RDFLabel where - -- Optimize some common cases.. - compare (Res sn1) (Res sn2) = compare sn1 sn2 - compare (Blank ln1) (Blank ln2) = compare ln1 ln2 - compare (Res _) (Blank _) = LT - compare (Blank _) (Res _) = GT - -- .. else use show string comparison - compare l1 l2 = compare (show l1) (show l2) - -- Similarly for <= - (Res qn1) <= (Res qn2) = qn1 <= qn2 - (Blank ln1) <= (Blank ln2) = ln1 <= ln2 - (Res _) <= (Blank _) = True - (Blank _) <= (Res _) = False - l1 <= l2 = (show l1) <= (show l2) - -instance Label RDFLabel where - labelIsVar (Blank _) = True - labelIsVar (Var _) = True - labelIsVar _ = False - getLocal (Blank loc) = loc - getLocal (Var loc) = '?':loc - getLocal (Res sn) = "Res_"++snLocal sn - getLocal (NoNode) = "None" - getLocal _ = "Lit_" - makeLabel ('?':loc) = Var loc - makeLabel loc = Blank loc - labelHash seed lb = hash seed (showCanon lb) - --- Get canonical string for RDF label. --- Used for hashing, so that equivalent labels always return --- the same hash value. -showCanon :: RDFLabel -> String -showCanon (Res sn) = "<"++getScopedNameURI sn++">" -showCanon (Lit st (Just nam)) - | isLang nam = quote st ++ "@" ++ (langTag nam) - | otherwise = quote st ++ "^^" ++ (getScopedNameURI nam) -showCanon lb = show lb - - --- Define equality of nodes possibly based on different graph types. --- --- The version of equality defined here is not strictly RDF abstract syntax --- equality, but my interpretation of equivalence for the purposes of --- entailment, in the absence of any specific datatype knowledge other --- than XML literals. --- -labelEq :: RDFLabel -> RDFLabel -> Bool -labelEq (Res q1) (Res q2) = (q1 == q2) -labelEq (Blank s1) (Blank s2) = (s1 == s2) -labelEq (Var v1) (Var v2) = (v1 == v2) -labelEq (Lit s1 t1) (Lit s2 t2) = (s1 == s2) && (t1 == t2) -labelEq _ _ = False - ---------------------------------------------------------- --- Selected RDFLabel values ---------------------------------------------------------- - -res_rdf_type = Res rdf_type -res_rdf_first = Res rdf_first -res_rdf_rest = Res rdf_rest -res_rdf_nil = Res rdf_nil -res_rdfs_member = Res rdfs_member -res_rdfd_GeneralRestriction = Res rdfd_GeneralRestriction -res_rdfd_onProperties = Res rdfd_onProperties -res_rdfd_constraint = Res rdfd_constraint -res_rdfd_maxCardinality = Res rdfd_maxCardinality -res_owl_sameAs = Res owl_sameAs -res_operator_plus = Res operator_plus -res_operator_minus = Res operator_minus -res_operator_slash = Res operator_slash -res_operator_star = Res operator_star - ---------------------------------------------------------- --- Additional functions on RDFLabel values ---------------------------------------------------------- - --- |Test if supplied labal is a URI resource node -isUri :: RDFLabel -> Bool -isUri (Res _) = True -isUri _ = False - --- |Test if supplied labal is a literal node -isLiteral :: RDFLabel -> Bool -isLiteral (Lit _ _) = True -isLiteral _ = False - --- |Test if supplied labal is an untyped literal node -isUntypedLiteral :: RDFLabel -> Bool -isUntypedLiteral (Lit _ Nothing ) = True -isUntypedLiteral (Lit _ (Just tn)) = isLang tn -isUntypedLiteral _ = False - --- |Test if supplied labal is an untyped literal node -isTypedLiteral :: RDFLabel -> Bool -isTypedLiteral (Lit _ (Just tn)) = not (isLang tn) -isTypedLiteral _ = False - --- |Test if supplied labal is an XML literal node -isXMLLiteral :: RDFLabel -> Bool -isXMLLiteral = isDatatyped rdf_XMLLiteral - --- |Test if supplied label is an typed literal node of a given datatype -isDatatyped :: ScopedName -> RDFLabel -> Bool -isDatatyped d (Lit _ (Just n)) = (n == d) -isDatatyped _ _ = False - --- |Test if supplied label is a container membership property --- --- Check for namespace is RDF namespace and --- first character of local name is '_' and --- remaining characters of local name are all digits -isMemberProp :: RDFLabel -> Bool -isMemberProp (Res sn) = ( snScope sn == namespaceRDF ) && - ( head loc == '_' ) && - ( and . map isDigit . tail $ loc ) - where - loc = snLocal sn -isMemberProp _ = False - --- |Test if supplied labal is a blank node -isBlank :: RDFLabel -> Bool -isBlank (Blank _) = True -isBlank _ = False - --- |Test if supplied labal is a query variable -isQueryVar :: RDFLabel -> Bool -isQueryVar (Var _) = True -isQueryVar _ = False - --- |Extract text value from a literal node -getLiteralText :: RDFLabel -> String -getLiteralText (Lit s _) = s -getLiteralText _ = "" - --- |Extract ScopedName value from a resource node -getScopedName :: RDFLabel -> ScopedName -getScopedName (Res sn) = sn -getScopedName _ = nullScopedName - --- |Make a blank node from a supplied query variable, --- or return the supplied label unchanged. --- (Use this in when substituting an existential for an --- unsubstituted query variable.) -makeBlank :: RDFLabel -> RDFLabel -makeBlank (Var loc) = Blank loc -makeBlank lb = lb - ---------------------------------------------------------- --- RDF Triple (statement) ---------------------------------------------------------- - -type RDFTriple = Arc RDFLabel - ---------------------------------------------------------- --- Namespace prefix list entry ---------------------------------------------------------- - -type NamespaceMap = LookupMap Namespace - -data RevNamespace = RevNamespace Namespace - -instance LookupEntryClass RevNamespace String String where - keyVal (RevNamespace (Namespace pre uri)) = (uri,pre) - newEntry (uri,pre) = (RevNamespace (Namespace pre uri)) - -type RevNamespaceMap = LookupMap RevNamespace - -emptyNamespaceMap = LookupMap [] :: NamespaceMap - ---------------------------------------------------------- --- Graph formula entry ---------------------------------------------------------- - -data LookupFormula lb gr = Formula - { formLabel :: lb - , formGraph :: gr - } - -instance ( Eq lb, Eq gr ) => Eq (LookupFormula lb gr) where - f1 == f2 = ( formLabel f1 == formLabel f2 ) && - ( formGraph f1 == formGraph f2 ) - -instance (Label lb) - => LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb) - where - keyVal fe = (formLabel fe, formGraph fe) - newEntry (k,v) = Formula { formLabel=k, formGraph=v } - -instance (Label lb) => Show (LookupFormula lb (NSGraph lb)) - where - show (Formula l g) = (show l) ++ " :- { " ++ (showArcs " " g) ++ " }" - -type Formula lb = LookupFormula lb (NSGraph lb) - -type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb)) - -emptyFormulaMap = LookupMap [] :: FormulaMap RDFLabel - -{- given up on trying to do Functor for formulae... -instance Functor (LookupFormula (NSGraph lb)) where - fmap f fm = mapTranslateEntries (mapFormulaEntry f) fm --} - -formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2 -formulaeMap f fm = mapTranslateEntries (formulaEntryMap f) fm - -formulaEntryMap :: - (lb -> l2) - -> LookupFormula lb (NSGraph lb) - -> LookupFormula l2 (NSGraph l2) -formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr) - --- What follows is a monadic variant of formulaeMap, used to --- apply a transformation and collect some result in a single --- pass. - -formulaeMapM :: - (Monad m) => (lb -> m l2) -> FormulaMap lb -> m (FormulaMap l2) -formulaeMapM f fm = mapTranslateEntriesM (formulaEntryMapM f) fm - -formulaEntryMapM :: - (Monad m) - => (lb -> m l2) - -> LookupFormula lb (NSGraph lb) - -> m (LookupFormula l2 (NSGraph l2)) -formulaEntryMapM f (Formula k gr) = - do { f2 <- f k - ; g2 <- (fmapM f gr) - ; return $ Formula f2 g2 - } - ---------------------------------------------------------- --- Memory-based graph with namespaces and subgraphs ---------------------------------------------------------- - -data NSGraph lb = NSGraph - { namespaces :: NamespaceMap - , formulae :: FormulaMap lb - , statements :: [Arc lb] - } - -getNamespaces :: NSGraph lb -> NamespaceMap -getNamespaces g = namespaces g - -setNamespaces :: NamespaceMap -> NSGraph lb -> NSGraph lb -setNamespaces ns g = g { namespaces=ns } - -getFormulae :: NSGraph lb -> FormulaMap lb -getFormulae g = formulae g - -setFormulae :: FormulaMap lb -> NSGraph lb -> NSGraph lb -setFormulae fs g = g { formulae=fs } - -getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb) -getFormula g l = mapFindMaybe l (formulae g) - -setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb -setFormula f g = g { formulae=(mapReplaceOrAdd f (formulae g)) } - -instance (Label lb) => LDGraph NSGraph lb where - getArcs g = statements g - setArcs as g = g { statements=as } - --- Optimized method to add arc .. don't check for duplicates. -addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb -addArc ar gr = gr { statements=(addSetElem ar (statements gr)) } - -instance Functor NSGraph where - fmap f g = g { statements = (map $ fmap f) (statements g) - , formulae = formulaeMap f (formulae g) - } - -instance FunctorM NSGraph where - fmapM f g = - do { s2 <- (mapM $ fmapM f) (statements g) - ; f2 <- formulaeMapM f (formulae g) - ; return $ g { statements = s2, formulae = f2 } - } - -instance (Label lb) => Eq (NSGraph lb) where - (==) = grEq - -instance (Label lb) => Show (NSGraph lb) where - show gr = grShow "" gr - showList grs = grShowList "" grs - -grShowList _ [] = showString "[no graphs]" -grShowList p (g:gs) = showChar '[' . showString (grShow pp g) . showl gs - where - showl [] = showChar ']' -- showString $ "\n" ++ p ++ "]" - showl (g:gs) = showString (",\n "++p++grShow pp g) . showl gs - pp = ' ':p - -grShow :: (Label lb) => String -> NSGraph lb -> String -grShow p g = - "Graph, formulae: " ++ (showForm p g) ++ "\n" ++ - p ++ "arcs: " ++ (showArcs p g) - where - showForm p g = (foldr (++) "" (map ( (pp++) . show ) formulae )) - (LookupMap formulae) = getFormulae g - pp = "\n " ++ p - -showArcs :: (Label lb) => String -> NSGraph lb -> String -showArcs p g = (foldr (++) "" (map ( (pp++) . show ) (getArcs g) )) - where - pp = "\n " ++ p - -grEq :: (Label lb) => NSGraph lb -> NSGraph lb -> Bool -grEq g1 g2 = fst ( grMatchMap g1 g2 ) - -grMatchMap :: (Label lb) => - NSGraph lb -> NSGraph lb -> (Bool, LabelMap (ScopedLabel lb)) -grMatchMap g1 g2 = - graphMatch matchable (getArcs g1) (getArcs g2) - where - matchable l1 l2 = (mapFormula g1 l1) == (mapFormula g2 l2) - mapFormula g l = mapFindMaybe l (getFormulae g) - -toNSGraph :: (Eq lb, Show lb) => [Arc lb] -> NSGraph lb -toNSGraph arcs = - NSGraph - { statements = arcs - , namespaces = emptyNamespaceMap - , formulae = LookupMap [] - } - ---------------------------------------------------------- --- Merge RDF graphs, renaming bnodes in the second graph --- as necessary ---------------------------------------------------------- - --- |Merge RDF graphs, renaming blank and query variable nodes as --- needed to neep variable nodes from the two graphs distinct in --- the resulting graph. -merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb -merge gr1 gr2 = - let - bn1 = allLabels labelIsVar gr1 - bn2 = allLabels labelIsVar gr2 - dupbn = intersect bn1 bn2 - allbn = union bn1 bn2 - in - add gr1 (remapLabels dupbn allbn id gr2) - --- |Return list of all labels (including properties) in the graph --- satisfying a supplied filter predicate. -allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) ) - --- |Return list of all subjects and objects in the graph --- satisfying a supplied filter predicate. -allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allNodes p gr = unionNodes p [] (nodes gr) - --- List all nodes in graph formulae satisfying a supplied predicate -formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -formulaNodes p gr = foldl (unionNodes p) fkeys (map (allLabels p) fvals) - where - -- fm :: (Label lb) => FormulaMap lb - -- LookupMap LookupFormula (NSGraph lb) lb - fm = formulae gr - -- fvals :: (Label lb) => [NSGraph lb] - fvals = mapVals fm - -- fkeys :: (Label lb) => [lb] - fkeys = filter p $ mapKeys fm - --- Helper to filter variable nodes and merge with those found so far -unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb] -unionNodes p ls1 ls2 = ls1 `union` (filter p ls2) - ---------------------------------------------------------- --- Remap selected nodes in a graph ---------------------------------------------------------- - --- |Remap selected nodes in graph: --- --- dupbn is list of variable nodes to be renamed --- allbn is list of variable nodes used that must be avoided --- cnvbn is a 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'. Function 'makeBlank' can be used to convert --- RDF query nodes into RDF blank nodes. --- gr is graph in which nodes are to be renamed --- --- This is the node renaming operation that prevents graph-scoped --- variable nodes from being merged when two graphs are merged. -remapLabels :: - (Label lb) => [lb] -> [lb] -> (lb -> lb) -> NSGraph lb -> NSGraph lb -remapLabels dupbn allbn cnvbn gr = fmap (mapnode dupbn allbn cnvbn) gr - --- |Externally callable function to construct a list of (old,new) --- values to be used for graph label remapping. The supplied arguments --- are (a) a list of labels to be remaped, and (b) a list of labels --- to be avoided by the remapping: the latter should be a list of --- all the variable nodes in the graph to which the remapping will be --- applied. -remapLabelList :: - (Label lb) => [lb] -> [lb] -> [(lb,lb)] -remapLabelList remap avoid = maplist remap avoid id [] - --- Remap a single graph node. --- If the node is not one of those to be remapped, --- the supplied value is returned unchanged. -mapnode :: - (Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb -mapnode dupbn allbn cnvbn nv = - mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn [])) - --- Construct a list of (oldnode,newnode) values to be used for --- graph label remapping. The function operates recursiovely, adding --- new nodes generated to the mapping list (mapbn') and also to the --- list of nodes to be avoided (allbn'). -maplist :: - (Label lb) => [lb] -> [lb] -> (lb -> lb) -> [(lb,lb)] -> [(lb,lb)] -maplist [] _ _ mapbn = mapbn -maplist (dn:dupbn) allbn cnvbn mapbn = maplist dupbn allbn' cnvbn mapbn' - where - dnmap = newNode (cnvbn dn) allbn - mapbn' = (dn,dnmap):mapbn - allbn' = dnmap:allbn - --- |Given a node and a list of existing nodes, find a new node for --- the supplied node that does not clash with any existing node. --- (Generates an non-terminating list of possible replacements, and --- picks the first one that isn't already in use.) --- --- [[[TODO: optimize this for common case nnn and _nnn: --- always generate _nnn and keep track of last allocated]]] -newNode :: (Label lb) => lb -> [lb] -> lb -newNode dn existnodes = - head $ newNodes dn existnodes - --- |Given a node and a list of existing nodes, generate a list of new --- nodes for the supplied node that do not clash with any existing node. -newNodes :: (Label lb) => lb -> [lb] -> [lb] -newNodes dn existnodes = - filter (not . (flip elem existnodes)) $ trynodes (noderootindex dn) - -noderootindex :: (Label lb) => lb -> (String,Int) -noderootindex dn = (nh,nx) where - (nh,nt) = splitnodeid $ getLocal dn - nx = if null nt then 0 else read nt - -splitnodeid :: String -> (String,String) -splitnodeid dn = splitAt (tx+1) dn where - tx = last $ (-1):findIndices (not . isDigit) dn - -trynodes :: (Label lb) => (String,Int) -> [lb] -trynodes (nr,nx) = [ makeLabel (nr++(show n)) | n <- iterate (+1) nx ] - -trybnodes :: (Label lb) => (String,Int) -> [lb] -trybnodes (nr,nx) = [ makeLabel (nr++(show n)) | n <- iterate (+1) nx ] - ---------------------------------------------------------- --- Memory-based RDF graph type and graph class functions ---------------------------------------------------------- - -type RDFGraph = NSGraph RDFLabel - --- |Create a new RDF graph from a supplied list of arcs -toRDFGraph :: [Arc RDFLabel] -> RDFGraph -toRDFGraph arcs = toNSGraph arcs - --- |Create a new, empty RDF graph. -emptyRDFGraph :: RDFGraph -emptyRDFGraph = toRDFGraph [] - -{- --- |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 -> [Arc RDFLabel] -> RDFGraph -updateRDFGraph gr as = gr { statements=as } --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFGraph.hs,v $ --- $Author: graham $ --- $Revision: 1.48 $ --- $Log: RDFGraph.hs,v $ --- Revision 1.48 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. --- --- Revision 1.47 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.46 2004/01/06 16:29:56 graham --- Fix up module exports to avoid GHC warnings --- --- Revision 1.45 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.44 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.43 2003/11/24 15:46:03 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.42 2003/11/14 21:48:35 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.41 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.40 2003/10/24 21:02:42 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.39 2003/10/22 15:47:46 graham --- Working on datatype inference support. --- --- Revision 1.38 2003/10/01 00:36:25 graham --- Added RDFGraph method to test for container membership property label. --- Added RDFQuery filter function to select container membership properties. --- --- Revision 1.37 2003/09/30 16:39:41 graham --- Refactor proof code to use new ruleset logic. --- Moved some support code from RDFProofCheck to RDFRuleset. --- --- Revision 1.36 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.35 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.34 2003/07/03 20:31:07 graham --- Add initial draft of datatype framework. --- --- Revision 1.33 2003/07/02 21:27:30 graham --- Graph closure with instance rule tested. --- About to change ProofTest for graph forward chaining to return --- a single result graph. --- --- Revision 1.32 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.31 2003/06/27 21:02:59 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.30 2003/06/25 21:16:52 graham --- Reworked N3 formatting logic to support proof display. --- Basic proof display is working. --- --- Revision 1.29 2003/06/19 19:49:07 graham --- RDFProofCheck compiles, but test fails --- --- Revision 1.28 2003/06/17 15:43:35 graham --- remapNodes now accepts a node-mapping function rather than just --- a Boolean to control conversion of query variable nodes to blank --- nodes, and who knows what else. --- --- Revision 1.27 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.26 2003/06/12 00:49:05 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- --- Revision 1.25 2003/06/10 17:38:34 graham --- Remove some unneeded calss constraints from data type declarations --- Reworked NSGraph to be an instance of Functor, replacing function --- gmap with fmap. Graph formulae are still not handled well: the data types --- will need re-working so that a "Formula lb" type constructor can be --- introduced having the correct (* -> *) kind to be a Functor. --- --- Revision 1.24 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.23 2003/05/30 15:04:56 graham --- Fix references to defunct GraphHelpers module --- --- Revision 1.22 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.21 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.20 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.19 2003/05/27 19:15:50 graham --- Graph merge (with blank node renaming) complete and passes tests. --- --- Revision 1.18 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.17 2003/05/23 19:33:36 graham --- Added and tested RDF graph label translation functions --- --- Revision 1.16 2003/05/23 00:02:42 graham --- Fixed blank node id generation bug in N3Formatter --- --- Revision 1.15 2003/05/14 22:39:23 graham --- Initial formatter tests all run OK. --- The formatter could still use so,me improvement, --- but it --- passes the minimal round-tripping tests. --- --- Revision 1.14 2003/05/14 16:50:32 graham --- Graph matching seems solid now: --- RDFGraphTest and N3ParserTest pass all tests --- Updated TODO file with comments from code --- --- Revision 1.13 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.12 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.11 2003/05/07 19:25:00 graham --- Restructured formula handling in RDF graph --- --- Revision 1.10 2003/05/01 00:21:41 graham --- Started refactoring LookupMap. --- Revised module compiles OK. --- Working on test module. --- --- Revision 1.9 2003/04/29 22:07:10 graham --- Some refactoring of N3 formatter. --- N3 formatter now handles trivial cases. --- More complex formatter test cases still to be developed. --- --- Revision 1.8 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.7 2003/04/15 21:40:54 graham --- N3Parser compiles --- Some small changes to RDFGraph --- Added some QName methods --- --- Revision 1.6 2003/04/11 17:38:34 graham --- Rename GraphLookupMap to LookupMap --- --- Revision 1.5 2003/04/10 20:08:39 graham --- Reorganized RDFGraph naming (RDFGraphTest OK) --- Progressing N3Parser --- --- Revision 1.4 2003/04/10 15:06:30 graham --- RDFGraph now passes all test cases --- --- Revision 1.3 2003/04/10 13:36:45 graham --- Renamed GraphRDF to RDFGraph --- --- Revision 1.1 2003/04/10 08:36:06 graham --- Graph matching passes battery of new tests --- Started work on RDF graph --- diff --git a/Swish/HaskellRDF/RDFGraphShowM.hs b/Swish/HaskellRDF/RDFGraphShowM.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFGraphShowM.hs +++ /dev/null @@ -1,81 +0,0 @@ -{-# OPTIONS -XTypeSynonymInstances #-} - --------------------------------------------------------------------------------- --- $Id: RDFGraphShowM.hs,v 1.2 2003/09/24 18:50:52 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFGraphShowM --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + ???? --- --- This module defines a ShowM class instance for RDFGraph, to be --- used when displaying RDF Graph values as part of a proof sequence, --- etc. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFGraphShowM() -where - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , isUri, isLiteral, isXMLLiteral, isBlank, isQueryVar, makeBlank - , RDFTriple - , NSGraph(..), RDFGraph ) - -import Swish.HaskellRDF.N3Formatter - ( formatGraphIndent ) - -import Swish.HaskellUtils.ShowM - ( ShowM(..), showm ) - - ------------------------------------------------------------- --- ShowM instance for RDFGraph ------------------------------------------------------------- - -instance ShowM RDFGraph where - showms linebreak graph = formatGraphIndent linebreak False graph - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFGraphShowM.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: RDFGraphShowM.hs,v $ --- Revision 1.2 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.1 2003/06/25 21:20:12 graham --- Add ShowM class and RDF graph instance to CVS. --- This is part of reworking N3 formatting logic to support proof display, --- and other multiline display requirements. --- diff --git a/Swish/HaskellRDF/RDFGraphTest.hs b/Swish/HaskellRDF/RDFGraphTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFGraphTest.hs +++ /dev/null @@ -1,1575 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFGraphTest.hs,v 1.32 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFGraphTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for module RDFGraph. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.RDFGraphTest where - -import Swish.HaskellUtils.FunctorM - ( FunctorM(..) ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) - , mapFind, mapFindMaybe, mapContains ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Swish.HaskellRDF.GraphClass - ( Label(..), Arc, arcSubj, arcPred, arcObj, arc ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , makeQNameScopedName - , nullScopedName - , makeUriScopedName - ) - -import Swish.HaskellUtils.QName - ( QName(..) - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFTriple, RDFGraph, RDFLabel(..), NSGraph(..) - , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral - , isDatatyped, isMemberProp - , isUri, isBlank, isQueryVar, makeBlank - , getScopedName - -- , LookupNamespace(..), Namespace - , NamespaceMap, emptyNamespaceMap - , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap - , setArcs, getArcs, addArc, add, delete, extract, labels, merge - , allLabels, remapLabels, remapLabelList - , setNamespaces, getNamespaces - , setFormulae, getFormulae, setFormula, getFormula - , emptyRDFGraph, toRDFGraph - , newNode, newNodes - , grMatchMap, grEq ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF -{- - , namespaceRDFS - , namespaceRDFD - , namespaceRDFC - , namespaceRDFO - , namespaceXSD - , namespaceXsdType - , namespaceOWL - , namespaceMATH - , namespaceLOG - , namespaceDAML --} - , namespaceLang, langName, langTag, isLang - , rdf_type - , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral - , rdfs_member - , rdfd_GeneralRestriction - , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality - , owl_sameAs - , operator_plus, operator_minus, operator_slash, operator_star - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - -import Data.List - ( elemIndex ) - -import Data.Maybe - ( fromJust ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle ) - ------------------------------------------------------------- --- Common definitions ------------------------------------------------------------- - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - ------------------------------------------------------------- --- Test language tag comparisons ------------------------------------------------------------- - -type Lang = Maybe ScopedName - -lt0 = Nothing -lt1 = Just (langName "en") -lt2 = Just (langName "EN") -lt3 = Just (langName "fr") -lt4 = Just (langName "FR") -lt5 = Just (langName "en-us") -lt6 = Just (langName "en-US") -lt7 = Just (langName "EN-us") -lt8 = Just (langName "EN-US") - -langlist = - [ ("lt0",lt0), - ("lt1",lt1), ("lt2",lt2), ("lt3",lt3), ("lt4",lt4), - ("lt5",lt5), ("lt6",lt6), ("lt7",lt7), ("lt8",lt8) ] - -langeqlist = - [ - ("lt1","lt2"), - ("lt3","lt4"), - ("lt5","lt6"), - ("lt5","lt7"), - ("lt5","lt8"), - ("lt6","lt7"), - ("lt6","lt8"), - ("lt7","lt8") - ] - -testLangEq :: String -> Bool -> Lang -> Lang -> Test -testLangEq lab eq l1 l2 = - TestCase ( assertEqual ("testLangEq:"++lab) eq (l1==l2) ) - -testLangEqSuite = TestList - [ testLangEq (testLab l1 l2) (testEq l1 l2) t1 t2 - | (l1,t1) <- langlist , (l2,t2) <- langlist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` langeqlist || - (l2,l1) `elem` langeqlist - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node#" -base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" -base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" -base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" - -qb1s1 = ScopedName base1 "s1" -qb2s2 = ScopedName base2 "s2" -qb3s3 = ScopedName base3 "s3" -qb3 = ScopedName base3 "" -qb3bm = ScopedName base3 "basemore" -qb4m = ScopedName base4 "more" - -s1 = Res qb1s1 :: RDFLabel -s2 = Res qb2s2 :: RDFLabel -s3 = Res qb3s3 :: RDFLabel -s4 = Res qb3 :: RDFLabel -s5 = Blank "s5" :: RDFLabel -s6 = Res qb3bm :: RDFLabel -s7 = Res qb4m :: RDFLabel -s8 = Blank "s8" :: RDFLabel - -qb1st1 = ScopedName base1 "st1" -qb2st2 = ScopedName base2 "st2" -qb3st3 = ScopedName base3 "st3" - -st1 = Res qb1st1 :: RDFLabel -st2 = Res qb2st2 :: RDFLabel -st3 = Res qb3st3 :: RDFLabel - -bb = Blank "bb" :: RDFLabel -bb0 = Blank "bb0" :: RDFLabel -b1 = Blank "b1" :: RDFLabel -b2 = Blank "b2" :: RDFLabel -b3 = Blank "b3" :: RDFLabel -b4 = Blank "b4" :: RDFLabel -b5 = Blank "b5" :: RDFLabel -b6 = Blank "b6" :: RDFLabel -b7 = Blank "b7" :: RDFLabel -b8 = Blank "b8" :: RDFLabel -b9 = Blank "b9" :: RDFLabel -b10 = Blank "b10" :: RDFLabel - -c1 = Blank "c1" :: RDFLabel -c2 = Blank "c2" :: RDFLabel -c3 = Blank "c3" :: RDFLabel -c4 = Blank "c4" :: RDFLabel - -ba1 = Blank "_1" :: RDFLabel -ba2 = Blank "_2" :: RDFLabel -ba3 = Blank "_3" :: RDFLabel -ba4 = Blank "_4" :: RDFLabel - -bn3 = Blank "3" :: RDFLabel -bn4 = Blank "4" :: RDFLabel -bn5 = Blank "5" :: RDFLabel -bn6 = Blank "6" :: RDFLabel - -qb1p1 = ScopedName base1 "p1" -qb2p2 = ScopedName base2 "p2" -qb3p3 = ScopedName base3 "p3" -qb4p4 = ScopedName base3 "p4" -qb1o1 = ScopedName base1 "o1" -qb2o2 = ScopedName base2 "o2" -qb3o3 = ScopedName base3 "o3" - -p1 = Res qb1p1 :: RDFLabel -p2 = Res qb2p2 :: RDFLabel -p3 = Res qb3p3 :: RDFLabel -p4 = Res qb4p4 :: RDFLabel - -o1 = Res qb1o1 :: RDFLabel -o2 = Res qb2o2 :: RDFLabel -o3 = Res qb3o3 :: RDFLabel -o4 = Res qb3 :: RDFLabel -o5 = Blank "o5" :: RDFLabel -o6 = Blank "s5" :: RDFLabel - -qb1t1 = ScopedName base1 "type1" -qb1t2 = ScopedName base1 "type2" - -l1 = Lit "l1" Nothing :: RDFLabel -l2 = Lit "l2" (Just (langName "en")) :: RDFLabel -l3 = Lit "l2" (Just (langName "fr")) :: RDFLabel -l4 = Lit "l4" (Just qb1t1) :: RDFLabel -l5 = Lit "l4" (Just qb1t1) :: RDFLabel -- (Lang "en") -l6 = Lit "l4" (Just qb1t1) :: RDFLabel -- (Lang "fr") -l7 = Lit "l4" (Just qb1t2) :: RDFLabel -l8 = Lit "l4" (Just qb1t2) :: RDFLabel -- (Lang "en") -l9 = Lit "l4" (Just qb1t2) :: RDFLabel -- (Lang "fr") -l10 = Lit "l10" (Just rdf_XMLLiteral) :: RDFLabel -l11 = Lit "l10" (Just rdf_XMLLiteral) :: RDFLabel -- (Lang "en") -l12 = Lit "l10" (Just rdf_XMLLiteral) :: RDFLabel -- (Lang "fr") - -v1 = Var "v1" :: RDFLabel -v2 = Var "v2" :: RDFLabel -v3 = Var "v3" :: RDFLabel -v4 = Var "v4" :: RDFLabel -vb3 = Blank "v3" :: RDFLabel -vb4 = Blank "v4" :: RDFLabel - --- Test cases for isMemberProp -qcm1 = ScopedName namespaceRDF "_1" -qcm2 = ScopedName namespaceRDF "_234567" -qnm1 = ScopedName namespaceRDF "987" -qnm2 = ScopedName namespaceRDF "_987a65" - -cm1 = Res qcm1 :: RDFLabel -cm2 = Res qcm2 :: RDFLabel -nm1 = Res qnm1 :: RDFLabel -nm2 = Res qnm2 :: RDFLabel - ------------------------------------------------------------- --- RDFLabel construction and equality tests ------------------------------------------------------------- - -testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test -testLabelEq lab eq n1 n2 = - TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) - -nodelist = - [ ("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), ("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 = - [ ("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 = TestList - [ testLabelEq (testLab l1 l2) (testEq l1 l2) n1 n2 - | (l1,n1) <- nodelist , (l2,n2) <- nodelist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` nodeeqlist || - (l2,l1) `elem` nodeeqlist - ------------------------------------------------------------- --- RDFLabel classification tests ------------------------------------------------------------- - -testClass :: String -> (RDFLabel -> Bool) -> RDFLabel -> Bool -> Test -testClass lab clsf nod eq = - TestCase ( assertEqual ("testClass:"++lab) eq (clsf nod) ) - -testClass01 = testClass "testClass01" isUri s1 True -testClass02 = testClass "testClass02" isUri s5 False -testClass03 = testClass "testClass03" isUri ba1 False -testClass04 = testClass "testClass04" isUri l1 False -testClass05 = testClass "testClass05" isUri l10 False -testClass06 = testClass "testClass06" isUri cm1 True -testClass07 = testClass "testClass07" isUri nm1 True -testClass08 = testClass "testClass08" isUri v1 False - -testClass10 = testClass "testClass10" isLiteral s1 False -testClass11 = testClass "testClass11" isLiteral s5 False -testClass12 = testClass "testClass12" isLiteral ba1 False -testClass13 = testClass "testClass13" isLiteral l1 True -testClass14 = testClass "testClass14" isLiteral l4 True -testClass15 = testClass "testClass15" isLiteral l5 True -testClass16 = testClass "testClass16" isLiteral l10 True -testClass17 = testClass "testClass17" isLiteral l11 True -testClass18 = testClass "testClass18" isLiteral cm1 False -testClass19 = testClass "testClass19" isLiteral v1 False - -testClass20 = testClass "testClass20" isTypedLiteral s1 False -testClass21 = testClass "testClass21" isTypedLiteral s5 False -testClass22 = testClass "testClass22" isTypedLiteral ba1 False -testClass23 = testClass "testClass23" isTypedLiteral l1 False -testClass24 = testClass "testClass24" isTypedLiteral l2 False -testClass25 = testClass "testClass25" isTypedLiteral l4 True -testClass26 = testClass "testClass26" isTypedLiteral l5 True -testClass27 = testClass "testClass27" isTypedLiteral l10 True -testClass28 = testClass "testClass28" isTypedLiteral l11 True -testClass29 = testClass "testClass29" isTypedLiteral v1 False - -testClass30 = testClass "testClass30" isUntypedLiteral s1 False -testClass31 = testClass "testClass31" isUntypedLiteral s5 False -testClass32 = testClass "testClass32" isUntypedLiteral ba1 False -testClass33 = testClass "testClass33" isUntypedLiteral l1 True -testClass34 = testClass "testClass34" isUntypedLiteral l2 True -testClass35 = testClass "testClass35" isUntypedLiteral l4 False -testClass36 = testClass "testClass36" isUntypedLiteral l5 False -testClass37 = testClass "testClass37" isUntypedLiteral l10 False -testClass38 = testClass "testClass38" isUntypedLiteral l11 False -testClass39 = testClass "testClass39" isUntypedLiteral v1 False - -testClass40 = testClass "testClass40" isXMLLiteral s1 False -testClass41 = testClass "testClass41" isXMLLiteral s5 False -testClass42 = testClass "testClass42" isXMLLiteral ba1 False -testClass43 = testClass "testClass43" isXMLLiteral l1 False -testClass44 = testClass "testClass44" isXMLLiteral l2 False -testClass45 = testClass "testClass45" isXMLLiteral l4 False -testClass46 = testClass "testClass46" isXMLLiteral l5 False -testClass47 = testClass "testClass47" isXMLLiteral l10 True -testClass48 = testClass "testClass48" isXMLLiteral l11 True -testClass49 = testClass "testClass49" isXMLLiteral v1 False - -altIsXmlLit = isDatatyped rdf_XMLLiteral -testClass50 = testClass "testClass50" altIsXmlLit s1 False -testClass51 = testClass "testClass51" altIsXmlLit s5 False -testClass52 = testClass "testClass52" altIsXmlLit ba1 False -testClass53 = testClass "testClass53" altIsXmlLit l1 False -testClass54 = testClass "testClass54" altIsXmlLit l2 False -testClass55 = testClass "testClass55" altIsXmlLit l4 False -testClass56 = testClass "testClass56" altIsXmlLit l5 False -testClass57 = testClass "testClass57" altIsXmlLit l10 True -testClass58 = testClass "testClass58" altIsXmlLit l11 True - -testClass60 = testClass "testClass60" isMemberProp s1 False -testClass61 = testClass "testClass61" isMemberProp s5 False -testClass62 = testClass "testClass62" isMemberProp ba1 False -testClass63 = testClass "testClass63" isMemberProp l1 False -testClass64 = testClass "testClass64" isMemberProp l10 False -testClass65 = testClass "testClass65" isMemberProp cm1 True -testClass66 = testClass "testClass66" isMemberProp cm2 True -testClass67 = testClass "testClass67" isMemberProp nm1 False -testClass68 = testClass "testClass68" isMemberProp nm2 False - -testClass70 = testClass "testClass70" isBlank s7 False -testClass71 = testClass "testClass71" isBlank s5 True -testClass72 = testClass "testClass72" isBlank ba1 True -testClass73 = testClass "testClass73" isBlank l1 False -testClass74 = testClass "testClass74" isBlank l4 False -testClass75 = testClass "testClass75" isBlank l5 False -testClass76 = testClass "testClass76" isBlank l10 False -testClass77 = testClass "testClass77" isBlank l11 False -testClass78 = testClass "testClass78" isBlank cm1 False -testClass79 = testClass "testClass79" isBlank v1 False - -testClass80 = testClass "testClass80" isQueryVar s8 False -testClass81 = testClass "testClass81" isQueryVar s5 False -testClass82 = testClass "testClass82" isQueryVar ba1 False -testClass83 = testClass "testClass83" isQueryVar l1 False -testClass84 = testClass "testClass84" isQueryVar l4 False -testClass85 = testClass "testClass85" isQueryVar l5 False -testClass86 = testClass "testClass86" isQueryVar l10 False -testClass87 = testClass "testClass87" isQueryVar l11 False -testClass88 = testClass "testClass88" isQueryVar cm1 False -testClass89 = testClass "testClass89" isQueryVar v1 True - -testNodeClassSuite = TestList - [ testClass01, testClass02, testClass03, testClass04 - , testClass05, testClass06, testClass07, testClass08 - , testClass10, testClass11, testClass12, testClass13, testClass14 - , testClass15, testClass16, testClass17, testClass18, testClass19 - , testClass20, testClass21, testClass22, testClass23, testClass24 - , testClass25, testClass26, testClass27, testClass28, testClass29 - , testClass30, testClass31, testClass32, testClass33, testClass34 - , testClass35, testClass36, testClass37, testClass38, testClass39 - , testClass40, testClass41, testClass42, testClass43, testClass44 - , testClass45, testClass46, testClass47, testClass48, testClass49 - , testClass50, testClass51, testClass52, testClass53, testClass54 - , testClass55, testClass56, testClass57, testClass58 - , testClass60, testClass61, testClass62, testClass63, testClass64 - , testClass65, testClass66, testClass67, testClass68 - , testClass70, testClass71, testClass72, testClass73, testClass74 - , testClass75, testClass76, testClass77, testClass78, testClass79 - , testClass80, testClass81, testClass82, testClass83, testClass84 - , testClass85, testClass86, testClass87, testClass88, testClass89 - ] - ------------------------------------------------------------- --- RDFLabel local part separation and recombination tests ------------------------------------------------------------- - -testLocalEq :: String -> String -> String -> Test -testLocalEq lab l1 l2 = - TestCase ( assertEqual ("testLocalEq:"++lab) l1 l2 ) - -testLocalLabEq :: String -> RDFLabel -> RDFLabel -> Test -testLocalLabEq lab l1 l2 = - TestCase ( assertEqual ("testLocalEq:"++lab) l1 l2 ) - -testNodeLocal01 = testLocalEq "01" "b1" (getLocal b1) -testNodeLocal02 = testLocalEq "02" "b2" (getLocal b2) -testNodeLocal03 = testLocalEq "03" "?v1" (getLocal v1) -testNodeLocal04 = testLocalEq "04" "?v2" (getLocal v2) -testNodeLocal05 = testLocalLabEq "05" b1 (makeLabel "b1") -testNodeLocal06 = testLocalLabEq "06" b2 (makeLabel "b2") -testNodeLocal07 = testLocalLabEq "07" v1 (makeLabel "?v1") -testNodeLocal08 = testLocalLabEq "08" v2 (makeLabel "?v2") - -testNodeLocalSuite = TestList - [ testNodeLocal01 - , testNodeLocal02 - , testNodeLocal03 - , testNodeLocal04 - , testNodeLocal05 - , testNodeLocal06 - , testNodeLocal07 - , testNodeLocal08 - ] - ------------------------------------------------------------- --- Node generation tests ------------------------------------------------------------- - -testNodeEq :: String -> RDFLabel -> RDFLabel -> Test -testNodeEq lab l1 l2 = - TestCase ( assertEqual ("testNodeEq:"++lab) l1 l2 ) - -tnn01 = (newNode v1 [b1,b3,v1,v2]) -tnn02 = (newNode b1 [b1,b3,v1,v2]) -tnn03 = (newNodes b1 [b1,b3,v1,v2])!!0 -tnn04 = (newNodes b1 [b1,b3,v1,v2])!!1 -tnn05 = (newNodes b1 [b1,b3,v1,v2])!!2 -tnn06 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!0 -tnn07 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!1 -tnn08 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!2 -tnn09 = (newNodes l1 [b1,b3,v1,v2,tnns3])!!2 - -tnns1 = Blank "Res_s1" -tnns2 = Blank "Res_s2" -tnns3 = Blank "Res_s3" -tnns4 = Blank "Res_s4" -tnnl1 = Blank "Lit_2" - -testNewNode01 = testNodeEq "testNewNode01" v3 tnn01 -testNewNode02 = testNodeEq "testNewNode02" b2 tnn02 -testNewNode03 = testNodeEq "testNewNode03" b2 tnn03 -testNewNode04 = testNodeEq "testNewNode04" b4 tnn04 -testNewNode05 = testNodeEq "testNewNode05" b5 tnn05 -testNewNode06 = testNodeEq "testNewNode06" tnns1 tnn06 -testNewNode07 = testNodeEq "testNewNode07" tnns2 tnn07 -testNewNode08 = testNodeEq "testNewNode08" tnns4 tnn08 -testNewNode09 = testNodeEq "testNewNode09" tnnl1 tnn09 - -testNewNodeSuite = TestList - [ testNewNode01 - , testNewNode02 - , testNewNode03 - , testNewNode04 - , testNewNode05 - , testNewNode06 - , testNewNode07 - , testNewNode08 - , testNewNode09 - ] - ------------------------------------------------------------- --- 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 = - -- literals - [ "l1" - , "l11", "l12", "l10" - , "l2", "l3" - , "l5", "l6", "l4", "l8", "l9", "l7" - -- variables - , "v1", "v2" - -- URIs - , "o1", "p1", "s1" - , "o2", "p2", "s2" - , "s4", "o4", "s6", "s7" - , "o3", "p3", "p4", "s3" - -- blank nodes - , "b1", "b2", "b3", "b4" - , "o5", "s5", "s8" - ] - -testNodeOrdSuite = TestList - [ testLabelOrd (testLab l1 l2) (testOrd l1 l2) n1 n2 - | (l1,n1) <- nodelist , (l2,n2) <- nodelist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testOrd l1 l2 - | testEq l1 l2 = EQ - | otherwise = compare (fromJust $ elemIndex l1 nodeorder) - (fromJust $ elemIndex l2 nodeorder) - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` nodeeqlist || - (l2,l1) `elem` nodeeqlist - ------------------------------------------------------------- --- Other RDFLabel tests ------------------------------------------------------------- - -testLabelName01 = testEq "testLabelName01" (getScopedName s1) qb1s1 -testLabelName02 = testEq "testLabelName02" (getScopedName b1) nullScopedName -testLabelName03 = testEq "testLabelName03" (getScopedName l1) nullScopedName -testLabelName04 = testEq "testLabelName04" (getScopedName v1) nullScopedName - -testLabelOtherSuite = TestList - [ testLabelName01, testLabelName02, testLabelName03, testLabelName04 - ] - ------------------------------------------------------------- --- Statement construction and equality tests ------------------------------------------------------------- - -testStmtEq :: String -> Bool -> RDFTriple -> RDFTriple -> Test -testStmtEq lab eq t1 t2 = - TestCase ( assertEqual ("testStmtEq:"++lab) eq (t1==t2) ) - -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 = - [ (lab s p o,trp s p o) | s <- slist, p <- plist, o <- olist ] - where - lab (s,_) (p,_) (o,_) = s++"."++p++"."++o - trp (_,s) (_,p) (_,o) = arc s p o - -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 = TestList - [ testStmtEq (testLab l1 l2) (testEq l1 l2) t1 t2 - | (l1,t1) <- tlist , (l2,t2) <- tlist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` stmteqlist || - (l2,l1) `elem` stmteqlist - ------------------------------------------------------------- --- Graph construction and equality tests ------------------------------------------------------------- - -testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test -testGraphEq lab eq g1 g2 = - -- 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 - TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - else - TestList - [ TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - , TestCase ( assertEqual ("testGraphEq:"++lab) g1 g2 ) - ] - -testGraphEqM :: String -> Bool -> Maybe RDFGraph -> Maybe RDFGraph -> Test -testGraphEqM lab eq g1 g2 = - TestCase ( assertEqual ("testGraphEq:"++lab) eq (g1==g2) ) - -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 = arc s1 p1 b1 -t11 = arc b1 p2 b2 -t12 = arc b2 p3 o1 - -t20 = arc s1 p1 b3 -t21 = arc b3 p2 b4 -t22 = arc b4 p3 o1 - -tt01 = arc st1 p1 o1 -tt02 = arc st2 p1 o2 -tt03 = arc st3 p1 o3 -tt04 = arc st1 p1 l1 -tt05 = arc st2 p1 l4 -tt06 = arc st3 p1 l10 - -makeNewPrefixNamespace :: (String,Namespace) -> Namespace -makeNewPrefixNamespace (pre,ns) = Namespace pre (nsURI ns) - -nslist = LookupMap $ map makeNewPrefixNamespace - [ ("base1",base1) - , ("base2",base2) - , ("base3",base3) - , ("base4",base4) - ] - -nslistalt = LookupMap $ map makeNewPrefixNamespace - [ ("altbase1",base1) - , ("altbase2",base2) - , ("altbase3",base3) - ] - -g1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01] - } - -gt1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tt01] - } - --- Check for nonsensitivety of graph equility to namespace differences: -g1alt = NSGraph - { namespaces = nslistalt - , formulae = emptyFormulaMap - , statements = [t01] - } - --- Construct version of g1 using just URIs -uris1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" -urip1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#p1" -urio1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#o1" -tu01 = arc (Res uris1) (Res urip1) (Res urio1) -g1uri = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tu01] - } - -g2 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05,t06] - } - -gt2 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tt01,tt02,tt03,tt04,tt05,tt06] - } - -g3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t06,t05,t04,t03,t02,t01] - } - -gt3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tt06,tt05,tt04,tt03,tt02,tt01] - } - -g4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05,t06,t10,t11,t12] - } - -g5 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05,t06,t20,t21,t22] - } - -g6 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] - } - -g7 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t01,t02] - } - -g8 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t02,t01] - } - -g9 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t03,t02,t01] - } - -g9a = addArc t03 g8 - -g10 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [t02,t02,t01] - } - -g10a = addArc t02 g8 - -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 = - [ ("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 = TestList - [ testGraphEq (testLab l1 l2) (testEq l1 l2) g1 g2 - | (l1,g1) <- glist , (l2,g2) <- glist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` grapheqlist || - (l2,l1) `elem` grapheqlist - --- Selected tests for debugging -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 -geq99a = testGraphEq "g9-g9a" True g9 g9a -geq1010a = testGraphEq "g10-g10a" True g10 g10a - -testGraphEqSelSuite = TestList - [ geq12 - , geq21 - , geq22 - , geq23 - , geq14 - , geq24 - , geq77 - , geq78 - , geq87 - , geq99a - , geq1010a - ] - - ------------------------------------------------------------- --- Test updating formulae ------------------------------------------------------------- - -testFormulaLookup :: - String -> FormulaMap RDFLabel -> RDFLabel -> Maybe RDFGraph -> Test -testFormulaLookup lab fs fl gr = - TestCase ( assertEqual ("testFormulaLookup:"++lab) gr jfg ) - where - jfg = mapFindMaybe fl fs - -testMaybeEq :: (Eq a, Show a) => String -> Maybe a -> Maybe a -> Test -testMaybeEq lab m1 m2 = - TestCase ( assertEqual ("testMaybeEq:"++lab) m1 m2 ) - -g1f1 = g1 -f1 = getFormulae g1f1 -testGraphFormula01a = testFormulaLookup "01a" f1 s1 Nothing -testGraphFormula01b = testFormulaLookup "01b" f1 s2 Nothing -testGraphFormula01c = testFormulaLookup "01c" f1 s3 Nothing - -fm2 = LookupMap [Formula s2 g2] -g1f2 = setFormulae fm2 g1f1 -f2 = getFormulae g1f2 -testGraphFormula02a = testFormulaLookup "02a" f2 s1 Nothing -testGraphFormula02b = testFormulaLookup "02b" f2 s2 (Just g2) -testGraphFormula02c = testFormulaLookup "02c" f2 s3 Nothing - -fm3 = LookupMap [Formula s1 g1,Formula s2 g2,Formula s3 g3] -g1f3 = setFormulae fm3 g1f1 -f3 = getFormulae g1f3 -testGraphFormula03a = testFormulaLookup "03a" f3 s1 (Just g1) -testGraphFormula03b = testFormulaLookup "03b" f3 s2 (Just g2) -testGraphFormula03c = testFormulaLookup "03c" f3 s3 (Just g3) - -fm4 = LookupMap [Formula s1 g1,Formula s2 g3,Formula s3 g3] -g1f4 = setFormulae fm4 g1f1 -f4 = getFormulae g1f4 -testGraphFormula04a = testFormulaLookup "04a" f4 s1 (Just g1) -testGraphFormula04b = testFormulaLookup "04b" f4 s2 (Just g3) -testGraphFormula04c = testFormulaLookup "04c" f4 s3 (Just g3) - -fm5 = LookupMap [Formula s1 g1,Formula s2 g4,Formula s3 g6] -g1f5 = setFormulae fm5 g1f1 -f5 = getFormulae g1f5 -testGraphFormula05a = testFormulaLookup "05a" f5 s1 (Just g1) -testGraphFormula05b = testFormulaLookup "05b" f5 s2 (Just g4) -testGraphFormula05c = testFormulaLookup "05c" f5 s3 (Just g6) - -fm6 = LookupMap [Formula s1 g1,Formula s2 g5,Formula s3 g6] -g1f6 = setFormulae fm6 g1f1 -f6 = getFormulae g1f6 -testGraphFormula06a = testFormulaLookup "06a" f6 s1 (Just g1) -testGraphFormula06b = testFormulaLookup "06b" f6 s2 (Just g5) -testGraphFormula06c = testFormulaLookup "06c" f6 s3 (Just g6) - -fm7 = LookupMap [Formula s1 g1,Formula s2 g7,Formula s3 g6] -g1f7 = setFormulae fm7 g1f1 -f7 = getFormulae g1f7 -testGraphFormula07a = testFormulaLookup "07a" f7 s1 (Just g1) -testGraphFormula07b = testFormulaLookup "07b" f7 s2 (Just g7) -testGraphFormula07c = testFormulaLookup "07c" f7 s3 (Just g6) - --- 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 = g2 -f8 = getFormulae g2f1 -testGraphFormula08a = testFormulaLookup "08a" f8 s1 Nothing -testGraphFormula08b = testFormulaLookup "08b" f8 s2 Nothing -testGraphFormula08c = testFormulaLookup "08c" f8 s3 Nothing - -g2f2 = setFormulae fm2 g2f1 -f9 = getFormulae g2f2 -testGraphFormula09a = testFormulaLookup "09a" f9 s1 Nothing -testGraphFormula09b = testFormulaLookup "09b" f9 s2 (Just g2) -testGraphFormula09c = testFormulaLookup "09c" f9 s3 Nothing - -g2f3 = setFormulae fm3 g2f1 -f10 = getFormulae g2f3 -testGraphFormula10a = testFormulaLookup "10a" f10 s1 (Just g1) -testGraphFormula10b = testFormulaLookup "10b" f10 s2 (Just g2) -testGraphFormula10c = testFormulaLookup "10c" f10 s3 (Just g3) - --- 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. -testGraphFormula11a = testGraphEq "g1f1-g1f1" True g1f1 g1f1 -testGraphFormula11b = testGraphEq "g1f1-g1f2" True g1f1 g1f2 -testGraphFormula11c = testGraphEq "g1f1-g1f3" False g1f1 g1f3 - -testGraphFormula12a = testGraphEq "g1f2-g1f1" True g1f2 g1f1 -testGraphFormula12b = testGraphEq "g1f2-g1f2" True g1f2 g1f2 -testGraphFormula12c = testGraphEq "g1f2-g1f3" False g1f2 g1f3 - -testGraphFormula13a = testGraphEq "g1f3-g1f1" False g1f3 g1f1 -testGraphFormula13b = testGraphEq "g1f3-g1f2" False g1f3 g1f2 -testGraphFormula13c = testGraphEq "g1f3-g1f3" True g1f3 g1f3 - -testGraphFormula14a = testGraphEq "g1f4-g1f3" True g1f4 g1f3 -testGraphFormula14b = testGraphEq "g1f4-g1f4" True g1f4 g1f4 -testGraphFormula14c = testGraphEq "g1f4-g1f5" True g1f4 g1f5 - -testGraphFormula15a = testGraphEq "g1f5-g1f5" True g1f5 g1f5 -testGraphFormula15b = testGraphEq "g1f5-g1f6" True g1f5 g1f6 -testGraphFormula15c = testGraphEq "g1f5-g1f7" True g1f5 g1f7 - -testGraphFormula16a = testGraphEq "g1f6-g1f5" True g1f6 g1f5 -testGraphFormula16b = testGraphEq "g1f6-g1f6" True g1f6 g1f6 -testGraphFormula16c = testGraphEq "g1f6-g1f7" True g1f6 g1f7 - -testGraphFormula17a = testGraphEq "g1f7-g1f5" True g1f7 g1f5 -testGraphFormula17b = testGraphEq "g1f7-g1f6" True g1f7 g1f6 -testGraphFormula17c = testGraphEq "g1f7-g1f7" True g1f7 g1f7 - -testGraphFormula18a = testGraphEq "g2f1-g2f1" True g2f1 g2f1 -testGraphFormula18b = testGraphEq "g2f1-g2f2" False g2f1 g2f2 -testGraphFormula18c = testGraphEq "g2f1-g2f3" False g2f1 g2f3 - -testGraphFormula19a = testGraphEq "g2f2-g2f1" False g2f2 g2f1 -testGraphFormula19b = testGraphEq "g2f2-g2f2" True g2f2 g2f2 -testGraphFormula19c = testGraphEq "g2f2-g2f3" False g2f2 g2f3 - -testGraphFormula20a = testGraphEq "g2f3-g2f1" False g2f3 g2f1 -testGraphFormula20b = testGraphEq "g2f3-g2f2" False g2f3 g2f2 -testGraphFormula20c = testGraphEq "g2f3-g2f3" True g2f3 g2f3 - --- Test methods to set/access an individual formula in a graph -g1f21 = setFormula (Formula s1 g7) g1f2 -f21 = getFormulae g1f21 -testGraphFormula21a = testFormulaLookup "21a" f21 s1 (Just g7) -testGraphFormula21b = testFormulaLookup "21b" f21 s2 (Just g2) -testGraphFormula21c = testFormulaLookup "21c" f21 s3 Nothing - -g1f22 = setFormula (Formula s1 g1) g1f21 -f22 = getFormulae g1f22 -testGraphFormula22a = testFormulaLookup "22a" f22 s1 (Just g1) -testGraphFormula22b = testFormulaLookup "22b" f22 s2 (Just g2) -testGraphFormula22c = testFormulaLookup "22c" f22 s3 Nothing - -f23a = getFormula g1f22 s1 -f23b = getFormula g1f22 s2 -f23c = getFormula g1f22 s3 -testGraphFormula23a = testMaybeEq "23a" f23a (Just g1) -testGraphFormula23b = testMaybeEq "23b" f23b (Just g2) -testGraphFormula23c = testMaybeEq "23c" f23c Nothing - - -testGraphFormulaSuite = TestLabel "TestFormulae" $ TestList - [ testGraphFormula01a, testGraphFormula01b, testGraphFormula01c - , testGraphFormula02a, testGraphFormula02b, testGraphFormula02c - , testGraphFormula03a, testGraphFormula03b, testGraphFormula03c - , testGraphFormula04a, testGraphFormula04b, testGraphFormula04c - , testGraphFormula05a, testGraphFormula05b, testGraphFormula05c - , testGraphFormula06a, testGraphFormula06b, testGraphFormula06c - , testGraphFormula07a, testGraphFormula07b, testGraphFormula07c - , testGraphFormula08a, testGraphFormula08b, testGraphFormula08c - , testGraphFormula09a, testGraphFormula09b, testGraphFormula09c - , testGraphFormula10a, testGraphFormula10b, testGraphFormula10c - , testGraphFormula11a, testGraphFormula11b, testGraphFormula11c - , testGraphFormula12a, testGraphFormula12b, testGraphFormula12c - , testGraphFormula13a, testGraphFormula13b, testGraphFormula13c - , testGraphFormula14a, testGraphFormula14b, testGraphFormula14c - , testGraphFormula15a, testGraphFormula15b, testGraphFormula15c - , testGraphFormula16a, testGraphFormula16b, testGraphFormula16c - , testGraphFormula17a, testGraphFormula17b, testGraphFormula17c - , testGraphFormula18a, testGraphFormula18b, testGraphFormula18c - , testGraphFormula19a, testGraphFormula19b, testGraphFormula19c - , testGraphFormula20a, testGraphFormula20b, testGraphFormula20c - , testGraphFormula21a, testGraphFormula21b, testGraphFormula21c - , testGraphFormula22a, testGraphFormula22b, testGraphFormula22c - , testGraphFormula23a, testGraphFormula23b, testGraphFormula23c - ] - ------------------------------------------------------------- --- Test fmap translations of graphs, including formulae ------------------------------------------------------------- - -translate lab - | lab == s1 = st1 - | lab == s2 = st2 - | lab == s3 = st3 - | otherwise = lab - -translateM lab - | lab == s1 = Just st1 - | lab == s2 = Just st2 - | lab == s3 = Just st3 - | isBlank lab = Nothing - | otherwise = Just lab - -gt1f1a = gt1 -gt1f1b = fmap translate g1f1 -ft1 = getFormulae gt1f1b -testGraphTranslate01a = testGraphEq "gt1f1a-gt1f1b" True gt1f1a gt1f1b -testGraphTranslate01b = testFormulaLookup "GraphTranslate01b" ft1 st1 Nothing -testGraphTranslate01c = testFormulaLookup "GraphTranslate01c" ft1 st2 Nothing -testGraphTranslate01d = testFormulaLookup "GraphTranslate01d" ft1 st3 Nothing -testGraphTranslate01e = testEq "gt1f1a-gt1f1b" gt1f1a gt1f1b - -ftm2 = LookupMap [Formula st2 gt2] -gt1f2a = setFormulae ftm2 gt1 -gt1f2b = fmap translate g1f2 -ft2 = getFormulae gt1f2b -testGraphTranslate02a = testGraphEq "gt1f2a-gt1f2b" True gt1f2a gt1f2b -testGraphTranslate02b = testFormulaLookup "GraphTranslate02b" ft2 st1 Nothing -testGraphTranslate02c = testFormulaLookup "GraphTranslate02c" ft2 st2 (Just gt2) -testGraphTranslate02d = testFormulaLookup "GraphTranslate02d" ft2 st3 Nothing - -ftm3 = LookupMap [Formula st1 gt1,Formula st2 gt2,Formula st3 gt3] -gt1f3a = setFormulae ftm3 gt1 -gt1f3b = fmap translate g1f3 -ft3 = getFormulae gt1f3b -testGraphTranslate03a = testGraphEq "gt1f3a-gt1f3b" True gt1f3a gt1f3b -testGraphTranslate03b = testFormulaLookup "GraphTranslate03b" ft3 st1 (Just gt1) -testGraphTranslate03c = testFormulaLookup "GraphTranslate03c" ft3 st2 (Just gt2) -testGraphTranslate03d = testFormulaLookup "GraphTranslate03d" ft3 st3 (Just gt3) - -gt2f1a = gt2 -gt2f1b = fmap translate g2f1 -ft4 = getFormulae gt2f1b -testGraphTranslate04a = testGraphEq "gt2f1a-gt2f1b" True gt2f1a gt2f1b -testGraphTranslate04b = testFormulaLookup "GraphTranslate04b" ft4 st1 Nothing -testGraphTranslate04c = testFormulaLookup "GraphTranslate04c" ft4 st2 Nothing -testGraphTranslate04d = testFormulaLookup "GraphTranslate04d" ft4 st3 Nothing - -gt2f2a = setFormulae ftm2 gt2 -gt2f2b = fmap translate g2f2 -ft5 = getFormulae gt2f2b -testGraphTranslate05a = testGraphEq "gt2f2a-gt2f2b" True gt2f2a gt2f2b -testGraphTranslate05b = testFormulaLookup "GraphTranslate05b" ft5 st1 Nothing -testGraphTranslate05c = testFormulaLookup "GraphTranslate05c" ft5 st2 (Just gt2) -testGraphTranslate05d = testFormulaLookup "GraphTranslate05d" ft5 st3 Nothing - -gt2f3a = setFormulae ftm3 gt2 -gt2f3b = fmap translate g2f3 -ft6 = getFormulae gt2f3b -testGraphTranslate06a = testGraphEq "gt2f3a-gt2f3b" True gt2f3a gt2f3b -testGraphTranslate06b = testFormulaLookup "GraphTranslate06b" ft6 st1 (Just gt1) -testGraphTranslate06c = testFormulaLookup "GraphTranslate06c" ft6 st2 (Just gt2) -testGraphTranslate06d = testFormulaLookup "GraphTranslate06d" ft6 st3 (Just gt3) - --- Monadic translate tests, using Maybe Monad -gt1f1aM = Just gt1 -gt1f1bM = fmapM translateM g1f1 -ft1M = getFormulae $ fromJust gt1f1bM -testGraphTranslate07a = testGraphEqM "gt1f1aM-gt1f1bM" True gt1f1aM gt1f1bM -testGraphTranslate07b = testFormulaLookup "GraphTranslate07b" ft1M st1 Nothing -testGraphTranslate07c = testFormulaLookup "GraphTranslate07c" ft1M st2 Nothing -testGraphTranslate07d = testFormulaLookup "GraphTranslate07d" ft1M st3 Nothing -testGraphTranslate07e = testEq "gt1f1aM-gt1f1bM" gt1f1aM gt1f1bM - -gt1f2aM = Just gt1f2a -gt1f2bM = fmapM translateM g1f2 -ft2M = getFormulae $ fromJust gt1f2bM -testGraphTranslate08a = testGraphEqM "gt1f2aM-gt1f2bM" True gt1f2aM gt1f2bM -testGraphTranslate08b = testFormulaLookup "GraphTranslate08b" ft2M st1 Nothing -testGraphTranslate08c = testFormulaLookup "GraphTranslate08c" ft2M st2 (Just gt2) -testGraphTranslate08d = testFormulaLookup "GraphTranslate08d" ft2M st3 Nothing -testGraphTranslate08e = testEq "gt1f2aM-gt1f2bM" gt1f2aM gt1f1bM - -gt1f5M = fmapM translateM g1f5 -testGraphTranslate09a = testEq "GraphTranslate09a" Nothing gt1f5M - -testGraphTranslateSuite = TestLabel "TestTranslate" $ TestList - [ testGraphTranslate01a - , testGraphTranslate01b, testGraphTranslate01c, testGraphTranslate01d - , testGraphTranslate01e - , testGraphTranslate02a - , testGraphTranslate02b, testGraphTranslate02c, testGraphTranslate02d - , testGraphTranslate03a - , testGraphTranslate03b, testGraphTranslate03c, testGraphTranslate03d - , testGraphTranslate04a - , testGraphTranslate04b, testGraphTranslate04c, testGraphTranslate04d - , testGraphTranslate05a - , testGraphTranslate05b, testGraphTranslate05c, testGraphTranslate05d - , testGraphTranslate06a - , testGraphTranslate06b, testGraphTranslate06c, testGraphTranslate06d - , testGraphTranslate07a - , testGraphTranslate07b, testGraphTranslate07c, testGraphTranslate07d - , testGraphTranslate07e - , testGraphTranslate08a - , testGraphTranslate08b, testGraphTranslate08c, testGraphTranslate08d - , testGraphTranslate08e - , testGraphTranslate09a - ] - ------------------------------------------------------------- --- Test merge with conflicting bnodes, including formulae ------------------------------------------------------------- - -testMerge :: String -> RDFGraph -> RDFGraph -> RDFGraph -> Test -testMerge lab g1 g2 gr = - TestCase ( assertEquiv ("testMerge:"++lab) gr (merge g1 g2) ) - where - grequiv g1 g2 = (getArcs g1) `equiv` (getArcs g2) - assertEquiv lab g1 g2 = assertString $ - if grequiv g1 g2 then "" - else lab++"\nExpected: "++(show g1)++"\nObtained: "++(show g2) - - -testEquiv :: (Eq a) => String -> [a] -> [a] -> Test -testEquiv lab l1 l2 = TestCase $ assertBool lab (l1 `equiv` l2) - -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 = 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 = arc s1 p1 b2 -tm42 = arc b2 p1 o2 -tm43 = arc b2 p1 o3 -tm44 = arc b4 p2 b5 - -tm41a = arc s1 p1 b4 -tm44a = arc b5 p2 b6 - -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 - -gm1 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm01,tm02,tm03,tm04,tm05,tm06,tm07,tm08 - ,tm09,tm10,tm11,tm12,tm13,tm14 - ] - } - -gm11 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [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 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm01] - } - -gm2f = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm41] - } - -gm22 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm01,tm41] - } - -gm3 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm04] - } - -gm3f = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm44] - } - -gm33 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm04,tm44] - } - -gm4 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm01,tm04] - } - -gm44 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm01,tm04,tm41a,tm44a] - } - -gm5 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula b1 gm2] - , statements = [tm01,tm02,tm03] - } - -gm55 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula b1 gm2,Formula b2 gm2f] - , statements = [tm01,tm02,tm03,tm41,tm42,tm43] - } - -gm6 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula ba1 gm2,Formula bn3 gm3] - , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14] - } - -gm66 = NSGraph - { namespaces = nslist - , formulae = LookupMap - [Formula ba1 gm2,Formula bn3 gm3 - ,Formula ba3 gm2f,Formula bn5 gm3f - ] - , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14 - ,tm67,tm68,tm69,tm70,tm71,tm72,tm73,tm74 - ] - } - - -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 - -gm81 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm81,tm82] - } - -gm82 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm811,tm821] - } -gm82a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm81 -gm82b1 = remapLabelList [v1,v2] [v1,v2,b1,b2] -gm82b2 = [(v1,v3),(v2,v4)] - -gm83 = NSGraph - { namespaces = nslist - , formulae = emptyFormulaMap - , statements = [tm811,tm821] - } -gm83a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm81 - -gm84 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula b1 gm81,Formula v2 gm81] - , statements = [tm81,tm82] - } - -gm85 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula b1 gm82,Formula v4 gm82] - , statements = [tm811,tm821] - } -gm85a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm84 - -gm86 = NSGraph - { namespaces = nslist - , formulae = LookupMap [Formula b1 gm82,Formula vb4 gm82] - , statements = [tm812,tm822] - } -gm86a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm84 - -testMerge01 = testMerge "01" gm1 gm1 gm11 -testMerge02 = testMerge "02" gm2 gm2 gm22 -testMerge03 = testMerge "03" gm3 gm3 gm33 -testMerge04 = testMerge "04" gm4 gm4 gm44 -testMerge05 = testMerge "05" gm5 gm5 gm55 -testMerge06 = testMerge "06" gm6 gm6 gm66 - -testRemap07 = testGraphEq "Remap07" True gm82 gm82a -testRemapList07 = testEquiv "testRemapList07" gm82b2 gm82b1 -testRemap08 = testGraphEq "Remap08" True gm83 gm83a -testRemap09 = testGraphEq "Remap09" True gm85 gm85a -testRemap10 = testGraphEq "Remap10" True gm86 gm86a - -testMergeSuite = TestList - [ testMerge01 - , testMerge02 - , testMerge03 - , testMerge04 - , testMerge05 - , testMerge06 - , testRemap07 - , testRemapList07 - , testRemap08 - , testRemap09 - , testRemap10 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testLangEqSuite - , testNodeEqSuite - , testNodeClassSuite - , testNodeLocalSuite - , testNewNodeSuite - , testNodeOrdSuite - , testLabelOtherSuite - , testStmtEqSuite - , testGraphEqSuite - , testGraphEqSelSuite - , testGraphFormulaSuite - , testGraphTranslateSuite - , testMergeSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - -geq = testGraphEqSuite -nord = testNodeOrdSuite -gtr = testGraphTranslateSuite - -gmm g1 g2 = grMatchMap g1 g2 - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFGraphTest.hs,v $ --- $Author: graham $ --- $Revision: 1.32 $ --- $Log: RDFGraphTest.hs,v $ --- Revision 1.32 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.31 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.30 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.29 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.28 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.27 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.26 2003/10/01 00:36:25 graham --- Added RDFGraph method to test for container membership property label. --- Added RDFQuery filter function to select container membership properties. --- --- Revision 1.25 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.24 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.23 2003/07/02 21:27:30 graham --- Graph closure with instance rule tested. --- About to change ProofTest for graph forward chaining to return --- a single result graph. --- --- Revision 1.22 2003/07/01 14:20:30 graham --- Added instance entailment to proof check module. --- --- Revision 1.21 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.20 2003/06/17 15:43:35 graham --- remapNodes now accepts a node-mapping function rather than just --- a Boolean to control conversion of query variable nodes to blank --- nodes, and who knows what else. --- --- Revision 1.19 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.18 2003/06/12 00:49:05 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- --- Revision 1.17 2003/06/10 17:38:34 graham --- Remove some unneeded calss constraints from data type declarations --- Reworked NSGraph to be an instance of Functor, replacing function --- gmap with fmap. Graph formulae are still not handled well: the data types --- will need re-working so that a "Formula lb" type constructor can be --- introduced having the correct (* -> *) kind to be a Functor. --- --- Revision 1.16 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.15 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.14 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.13 2003/05/27 19:15:50 graham --- Graph merge (with blank node renaming) complete and passes tests. --- --- Revision 1.12 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.11 2003/05/23 19:33:36 graham --- Added and tested RDF graph label translation functions --- --- Revision 1.10 2003/05/14 16:50:32 graham --- Graph matching seems solid now: --- RDFGraphTest and N3ParserTest pass all tests --- Updated TODO file with comments from code --- --- Revision 1.9 2003/05/08 18:55:36 graham --- Updated graph matching module to deal consistently --- with graphs containing formulae. All graph tests now --- run OK, but the GraphMatch module is a mess and --- desperately needs restructuring. Also, graph matching --- performance needs to be improved. --- --- Revision 1.8 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.7 2003/05/07 19:25:00 graham --- Restructured formula handling in RDF graph --- --- Revision 1.6 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.5 2003/04/17 00:35:39 graham --- Added module N3ParserTest --- N3parser is mostly working --- Formulae remain to test --- --- Revision 1.4 2003/04/15 21:40:54 graham --- N3Parser compiles --- Some small changes to RDFGraph --- Added some QName methods --- --- Revision 1.3 2003/04/10 20:08:39 graham --- Reorganized RDFGraph naming (RDFGraphTest OK) --- Progressing N3Parser --- --- Revision 1.2 2003/04/10 15:06:30 graham --- RDFGraph now passes all test cases --- --- Revision 1.1 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- --- Revision 1.1 2003/03/12 23:00:43 graham --- Graph model coded and working, except for graph isomorphism test. --- diff --git a/Swish/HaskellRDF/RDFProof.hs b/Swish/HaskellRDF/RDFProof.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFProof.hs +++ /dev/null @@ -1,481 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XUndecidableInstances #-} --------------------------------------------------------------------------------- --- $Id: RDFProof.hs,v 1.22 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProof --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + multi-parameter classes --- --- 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.HaskellRDF.RDFProof - ( RDFProof, RDFProofStep - , makeRDFProof, makeRDFProofStep - , makeRdfInstanceEntailmentRule - , makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule ) -where - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryInstance - , rdfQuerySubs - ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleset ) - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..), RDFGraph - --, makeBlank - , merge , allLabels , remapLabelList - {-, newNode, newNodes - , toRDFGraph -}, emptyRDFGraph - ) - -import Swish.HaskellRDF.VarBinding - ( makeVarBinding - ) - -import Swish.HaskellRDF.Proof - ( Proof(..), Step(..) ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Rule(..) ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) - ) - -import Swish.HaskellRDF.GraphClass - ( Label(..), LDGraph(..), replaceArcs ) - -import Swish.HaskellUtils.LookupMap - ( makeLookupMap, mapFind ) - -import Swish.HaskellUtils.ListHelpers - ( subset - , powerSet - , powerSequences_len - , flist - ) - ------------------------------------------------------------- --- Type instantiation of Proof framework for RDFGraph data ------------------------------------------------------------- --- --- This is a partial instantiation of the proof framework. --- Details for applying inference rules are specific to the --- graph instance type. - ------------------------------------------------------------- --- Proof datatypes for graph values ------------------------------------------------------------- - --- |Instances of LDGraph are also instance of the --- Expression class, for which proofs can be constructed. --- The empty RDF graph is always True (other enduring --- truths are asserted as axioms. -instance (Label lb, LDGraph lg lb) => Expression (lg lb) where - isValid gr = null $ getArcs gr - ------------------------------------------------------------- --- Define RDF-specific types for proof framework ------------------------------------------------------------- - -type RDFProof = Proof RDFGraph - -type RDFProofStep = Step RDFGraph - ------------------------------------------------------------- --- Helper functions for constructing proofs on RDF graphs ------------------------------------------------------------- - --- |Make an RDF graph proof step --- --- rul is a rule to use for this step --- ants is a list of antecedent RDF formulae for this step --- con is an RDF formula that is the consequent for this step --- -makeRDFProofStep :: - RDFRule -> [RDFFormula] -> RDFFormula - -> RDFProofStep -makeRDFProofStep rul ants con = Step - { stepRule = rul - , stepAnt = ants - , stepCon = con - } - --- |Make an RDF proof --- --- rsets is a list of RDF rulesets that constitute a proof context --- for this proof. --- base is an initial statement from which the goal is claimed --- to be proven. --- goal is a statement that is claimed to be proven. --- -makeRDFProof :: - [RDFRuleset] -> RDFFormula -> RDFFormula - -> [RDFProofStep] - -> RDFProof -makeRDFProof rsets base goal steps = Proof - { proofContext = rsets - , proofInput = base - , proofResult = goal - , proofChain = steps - } - ------------------------------------------------------------- --- RDF instance entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF instance entailment; --- i.e. entailments that are due to replacement of a URI or literal --- node with a blank node. --- --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' and 'bwdApply' functions defined here may return --- rather large results if applied to graphs with many variables or --- a large vocabulary, and are defined for experimentation. --- --- Forward and backward chaining is performed with respect to a --- specified vocabulary. In the case of backward chaining, it would --- otherwise be impossible to bound the options thus generated. --- In the case of forward chaining, it is often not desirable to --- have the properties generalized. If forward or backward backward --- chaining will not be used, supply an empty vocabulary. --- Note: graph method 'allNodes' can be used to obtain a list of all --- the subjects and objuects used ina graph, not counting nested --- formulae; use a call of the form: --- allNodes (not . labelIsVar) graph -makeRdfInstanceEntailmentRule :: ScopedName -> [RDFLabel] -> RDFRule -makeRdfInstanceEntailmentRule name vocab = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = rdfInstanceEntailFwdApply vocab - , bwdApply = rdfInstanceEntailBwdApply vocab - , checkInference = rdfInstanceEntailCheckInference - } - --- Instance entailment forward chaining --- --- Note: unless the initial graph is small, the total result --- here could be very large. The existential generalizations are --- sequenced in increasing number of substitutions applied. --- This sequencing is determined by the powerset function used, --- which generates subsets in increasing order of size --- (see module 'ListHelpers'). --- --- The instances generated are all copies of the merge of the --- supplied graphs, with some or all of the non-variable nodes --- replaced by blank nodes. -rdfInstanceEntailFwdApply :: [RDFLabel] -> [RDFGraph] -> [RDFGraph] -rdfInstanceEntailFwdApply vocab ante = - let - -- Merge antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - mergeGraph = if null ante then emptyRDFGraph - else (foldl1 merge ante) - -- Obtain lists of variable and non-variable nodes - -- (was: nonvarNodes = allLabels (not . labelIsVar) mergeGraph) - nonvarNodes = vocab - varNodes = allLabels (labelIsVar) mergeGraph - -- Obtain list of possible remappings for non-variable nodes - mapList = remapLabelList nonvarNodes varNodes - mapSubLists = powerSet mapList - mapGr ls gr = fmap (\l -> mapFind l l (makeLookupMap ls)) gr - in - -- Return all remappings of the original merged graph - flist (map mapGr mapSubLists) mergeGraph - --- Instance entailment backward chaining (for specified vocabulary) --- --- [[[TODO: this is an incomplete implementation, there being no --- provision for instantiating some variables and leaving others --- alone. This can be overcome in many cases by combining instance --- and subgraph chaining. --- Also, there is no provision for instantiating some variables in --- a triple and leaving others alone. This may be fixed later if --- this function is really needed to be completely faithful to the --- precise notion of instance entailment.]]] -rdfInstanceEntailBwdApply :: [RDFLabel] -> RDFGraph -> [[RDFGraph]] -rdfInstanceEntailBwdApply vocab cons = - let - -- Obtain list of variable nodes - varNodes = allLabels (labelIsVar) cons - -- Generate a substitution for each combination of variable - -- and vocabulary node. - varBindings = map (makeVarBinding . zip varNodes) vocSequences - vocSequences = powerSequences_len (length varNodes) vocab - in - -- Generate a substitution for each combination of variable - -- and vocabulary: - [ rdfQuerySubs [v] cons | v <- varBindings ] - --- Instance entailment inference checker -rdfInstanceEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfInstanceEntailCheckInference ante cons = - let - mante = if null ante then emptyRDFGraph -- merged antecedents - else (foldl1 merge ante) - qvars = rdfQueryInstance cons mante -- all query matches - bsubs = rdfQuerySubs qvars cons -- all back substitutions - in - -- Return True if any back-substitution matches the original - -- merged antecendent graph. - or (map (mante ==) bsubs) - --- Instance entailment notes. --- --- Relation to simple entailment (s-entails): --- --- (1) back-substitution yields original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o1 by [_:o1/ex:o1] --- --- (2) back-substitution yields original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] --- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/_:o1] --- --- (3) back-substitution does not yield original graph --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] --- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/ex:o1] --- --- (4) consider --- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 ex:o1 --- ex:s1 ex:p1 ex:o2 ex:s1 ex:p1 ex:o2 --- ex:s1 ex:p1 ex:o3 ex:s1 ex:p1 _:o1 --- ex:s1 ex:p1 _:o2 --- where [_:o1/ex:o1,_:o2/ex:o2] yields a simple entailment but not --- an instance entailment, but [_:o1/ex:o3,_:o2/ex:o3] is also --- (arguably) an instance entailment. Therefore, it is not sufficient --- to look only at the "largest" substitutions to determine instance --- entailment. --- --- All this means that when checking for instance entailment by --- back substitution, all of the query results must be checked. --- This seems clumsy. If this function is heavily used with --- multiple query matches, a modified query that uses each --- triple of the target graph exactly once may be required. - ------------------------------------------------------------- --- RDF subgraph entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF subgraph entailment. --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' function defined here may return rather large --- results. But in the name of completeness and experimentation --- with the possibilities of lazy evaluation, it has been defined. --- --- Backward chaining is not performed, as there is no reasonable way --- to choose a meaningful supergraph of that supplied. -makeRdfSubgraphEntailmentRule :: ScopedName -> RDFRule -makeRdfSubgraphEntailmentRule name = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = rdfSubgraphEntailFwdApply - , bwdApply = const [] - , checkInference = rdfSubgraphEntailCheckInference - } - --- Subgraph entailment forward chaining --- --- Note: unless the initial graph is small, the total result --- here could be very large. The subgraphs are sequenced in --- increasing size of the sub graph. This sequencing is determined --- by the 'powerSet' function used which generates subsets in --- increasing order of size (see module 'ListHelpers'). -rdfSubgraphEntailFwdApply :: [RDFGraph] -> [RDFGraph] -rdfSubgraphEntailFwdApply ante = - let - -- Merge antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - mergeGraph = if null ante then emptyRDFGraph - else (foldl1 merge ante) - in - -- Return all subgraphs of the full graph constructed above - map (replaceArcs mergeGraph) (init $ powerSet $ getArcs mergeGraph) - --- Subgraph entailment inference checker --- --- This is of dubious utiltiy, as it doesn't allow for node renaming. --- The simple entailment inference rule is probably more useful here. -rdfSubgraphEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfSubgraphEntailCheckInference ante cons = - let - -- Combine antecedents to single graph, renaming bnodes if needed. - -- (Null test and using 'foldl1' to avoid merging if possible.) - fullGraph = if null ante then emptyRDFGraph - else (foldl1 add ante) - in - -- Check each consequent graph arc is in the antecedent graph - getArcs cons `subset` getArcs fullGraph - ------------------------------------------------------------- --- RDF simple entailment inference rule ------------------------------------------------------------- - --- |Make an inference rule dealing with RDF simple entailment. --- The part of this rule expected to be useful is 'checkInference'. --- The 'fwdApply' and 'bwdApply' functions defined return null --- results, indicating that they are not useful for the purposes --- of proof discovery. -makeRdfSimpleEntailmentRule :: ScopedName -> RDFRule -makeRdfSimpleEntailmentRule name = newrule - where - newrule = Rule - { ruleName = name - , fwdApply = const [] - , bwdApply = const [] - , checkInference = rdfSimpleEntailCheckInference - } - --- Simple entailment inference checker --- --- Note: antecedents here are presumed to share bnodes. --- (Use 'merge' instead of 'add' for non-shared bnodes) --- -rdfSimpleEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool -rdfSimpleEntailCheckInference ante cons = - let agr = if null ante then emptyRDFGraph else foldl1 add ante - in - not $ null $ rdfQueryInstance cons agr - -{- original.. - not $ null $ rdfQueryInstance cons (foldl1 merge ante) --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFProof.hs,v $ --- $Author: graham $ --- $Revision: 1.22 $ --- $Log: RDFProof.hs,v $ --- Revision 1.22 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.21 2003/12/16 07:05:37 graham --- Working on updated RDFProofContext --- --- Revision 1.20 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.19 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.18 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.17 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.16 2003/09/30 20:02:39 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.15 2003/09/30 16:39:41 graham --- Refactor proof code to use new ruleset logic. --- Moved some support code from RDFProofCheck to RDFRuleset. --- --- Revision 1.14 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.13 2003/07/02 21:27:30 graham --- Graph closure with instance rule tested. --- About to change ProofTest for graph forward chaining to return --- a single result graph. --- --- Revision 1.12 2003/07/01 14:20:30 graham --- Added instance entailment to proof check module. --- --- Revision 1.11 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.10 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.9 2003/06/25 21:16:53 graham --- Reworked N3 formatting logic to support proof display. --- Basic proof display is working. --- --- Revision 1.8 2003/06/25 09:52:25 graham --- Replaced Rule class with algebraic data type --- --- Revision 1.7 2003/06/24 23:08:18 graham --- Replaced Rule class with algebraic data type --- --- Revision 1.6 2003/06/24 19:56:31 graham --- Basic proof-check now works --- --- Revision 1.5 2003/06/19 19:49:07 graham --- RDFProofCheck compiles, but test fails --- --- Revision 1.4 2003/06/18 18:40:08 graham --- Basic proof backchaining tests OK. --- Next: add filtering on variable bindings. --- --- Revision 1.3 2003/06/18 01:29:29 graham --- Fixed up some problems with backward chaining queries. --- Query test cases still to complete. --- Proof incomplete. --- --- Revision 1.2 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.1 2003/06/12 00:49:06 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- diff --git a/Swish/HaskellRDF/RDFProofContext.hs b/Swish/HaskellRDF/RDFProofContext.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFProofContext.hs +++ /dev/null @@ -1,890 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFProofContext.hs,v 1.13 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProofContext --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- 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.HaskellRDF.RDFProofContext - ( rulesetRDF - , rulesetRDFS - , rulesetRDFD ) -where - -import Swish.HaskellRDF.BuiltInDatatypes - ( findRDFDatatype ) - -import Swish.HaskellRDF.RDFProof - ( makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula - , makeRDFFormula - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeN3ClosureModifyRule - , makeN3ClosureAllocatorRule - , makeNodeAllocTo ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding - , RDFVarBindingModify - , RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , isUri, isDatatyped - , getLiteralText ) - -import Swish.HaskellRDF.VarBinding - ( applyVarBinding - , addVarBinding - , VarBindingModify(..) - , makeVarFilterModify - , varFilterDisjunction - ) - -import Swish.HaskellRDF.Ruleset - ( makeRuleset ) - -import Swish.HaskellRDF.Datatype - ( typeMkCanonicalForm ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..), ScopedName(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , scopeRDF - , scopeRDFS - , scopeRDFD - ) - -import Data.Maybe - ( isJust, fromJust ) - -import Control.Monad - ( liftM ) - ------------------------------------------------------------- --- Define query binding filter auxiliaries ------------------------------------------------------------- - -makeFormula :: Namespace -> String -> String -> RDFFormula -makeFormula scope local gr = - makeRDFFormula scope local (prefixRDF++gr) - -requireAny :: [RDFVarBindingFilter] -> RDFVarBindingFilter -requireAny rs = varFilterDisjunction rs - -isLiteralV :: String -> RDFVarBindingFilter -isLiteralV ('?':l) = rdfVarBindingLiteral (Var l) - -isUntypedLitV :: String -> RDFVarBindingFilter -isUntypedLitV ('?':l) = rdfVarBindingUntypedLiteral (Var l) - -isXMLLitV :: String -> RDFVarBindingFilter -isXMLLitV ('?':x) = rdfVarBindingXMLLiteral (Var x) - -isUriRefV :: String -> RDFVarBindingFilter -isUriRefV ('?':u) = rdfVarBindingUriRef (Var u) - -isBlankV :: String -> RDFVarBindingFilter -isBlankV ('?':b) = rdfVarBindingBlank (Var b) - -isDatatypedV :: String -> String -> RDFVarBindingFilter -isDatatypedV ('?':d) ('?':l) = rdfVarBindingDatatyped (Var d) (Var l) - -isMemberPropV :: String -> RDFVarBindingFilter -isMemberPropV ('?':l) = rdfVarBindingMemberProp (Var l) - - -allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify -allocateTo bv av = makeNodeAllocTo (vn bv) (vn av) - where - vn ('?':n) = Var n - --- Create new binding for datatype -valueSame :: String -> String -> String -> String -> RDFVarBindingModify -valueSame val1 typ1 val2 typ2 = - sameDatatypedValue (vn val1) (vn typ1) (vn val2) (vn typ2) - where - vn ('?':n) = Var n - --- 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 = ScopedName 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 vbinds = - {- - trace "\nsameDatatypedValueApplyAll:" $ - seq (traceShow "\nval1:" val1) $ - seq (traceShow "\ntyp1:" typ1) $ - seq (traceShow "\nval2:" val2) $ - seq (traceShow "\ntyp2:" typ2) $ - seq (traceShow "\nvbinds:" vbinds) $ - trace "\n" $ - -} - concatMap (sameDatatypedValueApply val1 typ1 val2 typ2) vbinds - --- Auxiliary function that handles variable binding updates --- for sameDatatypedValue -sameDatatypedValueApply :: - RDFLabel -> RDFLabel -> RDFLabel -> RDFLabel - -> RDFVarBinding - -> [RDFVarBinding] -sameDatatypedValueApply val1 typ1 val2 typ2 vbind = - {- - trace "\nsameDatatypedValueApply:" $ - seq (traceShow "\nval1:" val1) $ - seq (traceShow "\ntyp1:" typ1) $ - seq (traceShow "\nval2:" val2) $ - seq (traceShow "\ntyp2:" typ2) $ - seq (traceShow "\nvbind:" vbind) $ - seq (traceShow "\nresult:" result) $ - trace "\n" $ - -} - 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 - if isJust sametype then - [addVarBinding val2 (fromJust $ sametype) vbind] - else - [] - 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 = case t1 of { (Res dqnam) -> dqnam } - dqn2 = case t2 of { (Res dqnam) -> dqnam } - mdt1 = findRDFDatatype dqn1 - dt1 = fromJust mdt1 - mkLit st = Lit st (Just dqn2) - -{- -- 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 ------------------------------------------------------------- - -prefixRDF :: String -prefixRDF = - "@prefix rdf: <" ++ nsURI namespaceRDF ++ "> . \n" ++ - "@prefix rdfs: <" ++ nsURI namespaceRDFS ++ "> . \n" ++ - "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ - " \n" - ------------------------------------------------------------- --- 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 :: Swish.HaskellRDF.RDFRuleset.RDFRule -rdfsub = makeRdfSubgraphEntailmentRule (ScopedName 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 = makeRdfSimpleEntailmentRule (ScopedName scopeRDF "se") - --- RDF bnode-for-literal assignments (from RDF semantics document section 7.1) --- -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 = 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.) --- -rdfr1 = makeN3ClosureSimpleRule scopeRDF "r1" - "?x ?a ?y ." - "?a rdf:type rdf:Property ." - -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 = makeN3ClosureRule scopeRDF "cp1" - "?x ?c ?y . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfcp2 = makeN3ClosureRule scopeRDF "cp2" - "?c ?p ?y . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfcp3 = makeN3ClosureRule scopeRDF "cp3" - "?x ?p ?c . " - "?c rdf:type rdf:Property ." - (makeVarFilterModify $ isMemberPropV "?c") - --- Collect RDF rules --- -rulesRDF = - [ rdfsub, rdfse - , rdflg, rdfgl - , rdfr1, rdfr2 - , rdfcp1, rdfcp2, rdfcp3 - ] - --- Define ruleset for RDF inference - -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.) --- -rdfsr1 = makeN3ClosureRule scopeRDFS "r1" - "?x ?a ?b . ?b rdf:_allocatedTo ?l . " - "?b rdf:type rdfs:Literal ." - (makeVarFilterModify $ isUntypedLitV "?l" ) - -rdfsr2 = makeN3ClosureSimpleRule scopeRDFS "r2" - "?x ?a ?y . ?a rdfs:domain ?z ." - "?x rdf:type ?z ." - -rdfsr3 = makeN3ClosureRule scopeRDFS "r3" - "?u ?a ?v . ?a rdfs:range ?z ." - "?v rdf:type ?z ." - (makeVarFilterModify $ requireAny [isUriRefV "?v",isBlankV "?v"]) - -rdfsr4a = makeN3ClosureSimpleRule scopeRDFS "r4a" - "?x ?a ?y ." - "?x rdf:type rdfs:Resource ." - -rdfsr4b = makeN3ClosureRule scopeRDFS "r4b" - "?x ?a ?u ." - "?u rdf:type rdfs:Resource ." - (makeVarFilterModify $ requireAny [isUriRefV "?u",isBlankV "?u"]) - -rdfsr5 = makeN3ClosureSimpleRule scopeRDFS "r5" - "?a rdfs:subPropertyOf ?b . ?b rdfs:subPropertyOf ?c ." - "?a rdfs:subPropertyOf ?c ." - -rdfsr6 = makeN3ClosureSimpleRule scopeRDFS "r6" - "?x rdf:type rdf:Property ." - "?x rdfs:subPropertyOf ?x ." - -rdfsr7 = makeN3ClosureSimpleRule scopeRDFS "r7" - "?x ?a ?y . ?a rdfs:subPropertyOf ?b ." - "?x ?b ?y ." - -rdfsr8 = makeN3ClosureSimpleRule scopeRDFS "r8" - "?x rdf:type rdfs:Class ." - "?x rdfs:subClassOf rdfs:Resource ." - -rdfsr9 = makeN3ClosureSimpleRule scopeRDFS "r9" - "?x rdfs:subClassOf ?y . ?a rdf:type ?x ." - "?a rdf:type ?y ." - -rdfsr10 = makeN3ClosureSimpleRule scopeRDFS "r10" - "?x rdf:type rdfs:Class ." - "?x rdfs:subClassOf ?x ." - -rdfsr11 = makeN3ClosureSimpleRule scopeRDFS "r11" - "?x rdfs:subClassOf ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:subClassOf ?z ." - -rdfsr12 = makeN3ClosureSimpleRule scopeRDFS "r12" - "?x rdf:type rdfs:ContainerMembershipProperty ." - "?x rdfs:subPropertyOf rdfs:member ." - -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 = makeN3ClosureSimpleRule scopeRDFS "ext1" - "?x rdfs:domain ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:domain ?z ." - -rdfsrext2 = makeN3ClosureSimpleRule scopeRDFS "ext2" - "?x rdfs:range ?y . ?y rdfs:subClassOf ?z ." - "?x rdfs:range ?z ." - -rdfsrext3 = makeN3ClosureSimpleRule scopeRDFS "ext3" - "?x rdfs:domain ?y . ?z rdfs:subPropertyOf ?x ." - "?z rdfs:domain ?y ." - -rdfsrext4 = makeN3ClosureSimpleRule scopeRDFS "ext4" - "?x rdfs:range ?y . ?z rdfs:subPropertyOf ?x ." - "?z rdfs:range ?y ." - -rdfsrext5 = makeN3ClosureSimpleRule scopeRDFS "ext5" - "rdf:type rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Resource rdfs:subClassOf ?y ." - -rdfsrext6 = makeN3ClosureSimpleRule scopeRDFS "rext6" - "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Class rdfs:subClassOf ?y ." - -rdfsrext7 = makeN3ClosureSimpleRule scopeRDFS "rext7" - "rdfs:subPropertyOf rdfs:subPropertyOf ?z . ?z rdfs:domain ?y ." - "rdfs:Property rdfs:subClassOf ?y ." - -rdfsrext8 = makeN3ClosureSimpleRule scopeRDFS "rext8" - "rdfs:subClassOf rdfs:subPropertyOf ?z . ?z rdfs:range ?y ." - "rdfs:Class rdfs:subClassOf ?y ." - -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 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?c ?y . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp12 = makeN3ClosureRule scopeRDFS "cp1" - "?c ?p ?y . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp13 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?p ?c . " - "?c rdf:type rdfs:ContainerMembershipProperty ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp21 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?c ?y . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp22 = makeN3ClosureRule scopeRDFS "cp1" - "?c ?p ?y . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp23 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?p ?c . " - "?c rdfs:domain rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp31 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?c ?y . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp32 = makeN3ClosureRule scopeRDFS "cp1" - "?c ?p ?y . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - -rdfscp33 = makeN3ClosureRule scopeRDFS "cp1" - "?x ?p ?c . " - "?c rdfs:range rdfs:Resource ." - (makeVarFilterModify $ isMemberPropV "?c") - --- Collect RDFS rules --- -rulesRDFS = - [ rdfsr1, rdfsr2, rdfsr3, rdfsr4a, rdfsr4b - , rdfsr5, rdfsr6, rdfsr7, rdfsr8, rdfsr9 - , rdfsr10, rdfsr11, rdfsr12, rdfsr13 - , rdfscp11, rdfscp12, rdfscp13 - , rdfscp21, rdfscp22, rdfscp23 - , rdfscp31, rdfscp32, rdfscp33 - ] - --- Define ruleset for RDFS inference - -rulesetRDFS = makeRuleset scopeRDFS axiomsRDFS rulesRDFS - ------------------------------------------------------------- --- Define RDFD (datatyping) axioms ------------------------------------------------------------- - --- scopeRDFD = Namespace "rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" - -axiomsRDFD = - [ - ] - ------------------------------------------------------------- --- Define RDFD (datatyping) axioms ------------------------------------------------------------- - --- RDFD closure rules from semantics document, section 7.4 - --- Infer type of datatyped literal --- -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 = 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 = makeN3ClosureModifyRule scopeRDFD "r3" - ( "?d rdf:type rdfs:Datatype . ?e rdf:type rdfs:Datatype . " ++ - "?a ?p ?s ." ) - "?a ?p ?t ." - (makeVarFilterModify $ isDatatypedV "?s" "?d") - (valueSame "?s" "?d" "?t" "?e") - --- Collect RDFD rules --- -rulesRDFD = - [ rdfdr1, rdfdr2, rdfdr3 - ] - --- Define ruleset for RDFD inference --- -rulesetRDFD = makeRuleset scopeRDFD axiomsRDFD rulesRDFD - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFProofContext.hs,v $ --- $Author: graham $ --- $Revision: 1.13 $ --- $Log: RDFProofContext.hs,v $ --- Revision 1.13 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.12 2003/12/20 12:00:14 graham --- Introduced new TraceHelpers module for Hugs-2003 compatibility. --- --- Revision 1.11 2003/12/19 21:01:25 graham --- Change Debug.Trace import (from Hugs.Trace) --- --- Revision 1.10 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.9 2003/12/16 07:05:37 graham --- Working on updated RDFProofContext --- --- Revision 1.8 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.7 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.6 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. --- --- Revision 1.5 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.4 2003/10/22 16:18:37 graham --- Move common namespace definitions into Namespace module --- (May later move these into separate modules.) --- --- Revision 1.3 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.2 2003/10/09 13:58:59 graham --- Sync with CVS. Preparing to eliminate QueryBindingFilter in favour --- of using just QueryBindingModifier. --- --- Revision 1.1 2003/10/02 13:39:41 graham --- RDF axioms and rules defined as Rulesets, and moved out of module --- RDFProofCheck into RDFProorfContext, with corresponding test cases --- moved to module RDFProorfContextTest. --- diff --git a/Swish/HaskellRDF/RDFProofContextTest.hs b/Swish/HaskellRDF/RDFProofContextTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFProofContextTest.hs +++ /dev/null @@ -1,672 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFProofContextTest.hs,v 1.14 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProofContextTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains RDF proof-checking test cases based on the RDF --- semantics specifications, as capured in module RDFProofContext. --- --------------------------------------------------------------------------------- - --- WNH RIP OUTmodule Swish.HaskellRDF.RDFProofContextTest where - -import Swish.HaskellRDF.BuiltInMap - ( rdfRulesetMap, allRulesets ) - -import Swish.HaskellRDF.RDFProofContext - ( rulesetRDF - , rulesetRDFS - , rulesetRDFD ) - -import Swish.HaskellRDF.RDFProof - ( RDFProof, RDFProofStep - , makeRDFProof, makeRDFProofStep - , makeRdfInstanceEntailmentRule - , makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFClosure, RDFRuleset - , nullRDFFormula - , makeRDFGraphFromN3String - , makeRDFFormula - , makeNodeAllocTo ) - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph ) - -import Swish.HaskellRDF.RDFGraphShowM() - -import Swish.HaskellRDF.Proof - ( Proof(..), Step(..) - , checkProof, checkStep, showProof, showsProof, showsFormula - , explainProof) - -import Swish.HaskellRDF.Ruleset - ( getContextAxiom, getContextRule ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) - , nullScope, nullFormula, nullRule ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..), ScopedName(..) ) - -import Swish.HaskellUtils.LookupMap - ( mapFindMaybe ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceXSD - , namespaceXsdType - , scopeRDF - , scopeRDFS - , scopeRDFD - ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - , putStr ) - -import Data.Maybe - ( isJust, isNothing, fromJust, fromMaybe ) - --- misc helpers - -test :: String -> Bool -> Test -test lab tst = TestCase $ assertBool lab tst - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab e a = TestCase $ assertEqual lab e a - -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) - -testGr :: String -> RDFGraph -> [RDFGraph] -> Test -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 -> String -> String -> RDFFormula -makeFormula scope local gr = - makeRDFFormula scope local (prefix++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 = ScopedName ns loc - where - (pre,_:loc) = break (==':') nam - ns = case pre of - "rs_rdf" -> scopeRDF - "rs_rdfs" -> scopeRDFS - "rs_rdfd" -> scopeRDFD - "xsd_integer" -> (namespaceXsdType "integer") - "xsd_string" -> (namespaceXsdType "string") - otherwise -> error ("makeSName: Unrecognized prefix in rule name: "++nam) - --- Common definitions - -prefix = - "@prefix rdf: <" ++ nsURI namespaceRDF ++ "> . \n" ++ - "@prefix rdfs: <" ++ nsURI namespaceRDFS ++ "> . \n" ++ - "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ - "@prefix xsd: <" ++ nsURI namespaceXSD ++ "> . \n" ++ - "@prefix ex: . \n" ++ - " \n" - -scopeex = Namespace "ex" "http://id.ninebynine.org/wip/2003/RDFProofCheck#" - -rdfContext = [ rulesetRDF ] - -rdfsContext = [ rulesetRDF, rulesetRDFS ] - -rdfdContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD ] - -xsdintContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD, rulesetXsdInt ] - -xsdstrContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD, rulesetXsdStr ] - -Just rulesetXsdInt = mapFindMaybe (namespaceXsdType "integer") rdfRulesetMap - -Just rulesetXsdStr = mapFindMaybe (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 = getRule "rs_rdf:r1" -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 ." ++ - "ex:p2 rdf:type rdf:Property ." -bwd01 = formExpr $ makeFormula scopeex "bwd01a" $ - "_:s1 ex:p1 _:o1 . " ++ - "_:s2 ex:p2 _:o2 . " -testRule01a = testEq "testRule01a" "rs_rdf:r1" (show $ ruleName rdfr1) -testRule01b = testEq "testRule01b" [con01] (fwdApply rdfr1 [ant01]) -testRule01c = testEq "testRule01c" [[bwd01]] (bwdApply rdfr1 con01) -testRule01d = test "testRule01d" (checkInference rdfr1 [ant01] con01) -testRule01e = test "testRule01e" (checkInference rdfr1 [bwd01] con01) - --- Simple rule test - no match forward or backward --- --- rdfsr2 = "?x ?a ?y . ?a rdfs:domain ?z ." => "?x rdf:type ?z ." --- -rdfsr2 = getRule "rs_rdfs:r2" -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 ." -testRule02a = testEq "testRule02a" "rs_rdfs:r2" (show $ ruleName rdfsr2) -testRule02b = testEq "testRule02b" [] (fwdApply rdfsr2 [ant02]) -testRule02c = testEq "testRule02c" [] (bwdApply rdfsr2 con02) -testRule02d = testEq "testRule02d" False (checkInference rdfsr2 [ant02] con02) - --- 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 = getRule "rs_rdf:lg" -rdfr2 = getRule "rs_rdf:r2" -ant03 = formExpr $ makeFormula scopeex "ant03" $ - "ex:s ex:p1 \"lit1\"^^rdf:XMLLiteral ; " ++ - " ex:p2a \"lit2\"^^rdf:XMLLiteral ; " ++ - " ex:p2b \"lit2\"^^rdf:XMLLiteral ." -con03lg = formExpr $ makeFormula scopeex "con03" $ - "ex:s ex:p1 _:l1 ; ex:p2a _:l2; ex:p2b _:l2 ." ++ - "_:l1 rdf:_allocatedTo \"lit1\"^^rdf:XMLLiteral ." ++ - "_:l2 rdf:_allocatedTo \"lit2\"^^rdf:XMLLiteral ." -con03r2 = formExpr $ makeFormula scopeex "con03" $ - "_:l1 rdf:type rdf:XMLLiteral ." ++ - "_:l2 rdf:type rdf:XMLLiteral ." - -testRule03a = testEq "testRule03a" "rs_rdf:lg" (show $ ruleName rdflg) -testRule03b = testEq "testRule03b" "rs_rdf:r2" (show $ ruleName rdfr2) -testRule03c = testEq "testRule03c" [con03lg] (fwdApply rdflg [ant03]) -testRule03d = testEq "testRule03d" [] (bwdApply rdflg con03lg) -testRule03e = test "testRule03e" (checkInference rdflg [ant03] con03lg) -testRule03f = testEq "testRule03f" [con03r2] (fwdApply rdfr2 [con03lg]) -testRule03g = testEq "testRule03g" [] (bwdApply rdfr2 con03r2) -testRule03h = test "testRule03h" (checkInference rdfr2 [con03lg] con03r2) - --- Rule with member property test, match forwards and backwards --- rdfcp1 = "?x ?c ?y . " => "?c rdf:type rdf:Property ." --- where: --- (isMemberProp "?c") --- -rdfcp = getRule "rs_rdf:cp1" -ant04 = formExpr $ makeFormula scopeex "ant04" $ - "ex:s rdf:_123 ex:o1 ; " ++ - " rdf:_2 ex:o2 . " -con04 = formExpr $ makeFormula scopeex "con04" $ - "rdf:_123 rdf:type rdf:Property ." ++ - "rdf:_2 rdf:type rdf:Property ." -bwd04 = formExpr $ makeFormula scopeex "bwd04a" $ - "_:s1 rdf:_123 _:o1 . " ++ - "_:s2 rdf:_2 _:o2 . " -testRule04a = testEq "testRule04a" "rs_rdf:cp1" (show $ ruleName rdfcp) -testRule04b = testEq "testRule04b" [con04] (fwdApply rdfcp [ant04]) -testRule04c = testEq "testRule04c" [[bwd04]] (bwdApply rdfcp con04) -testRule04d = test "testRule04d" (checkInference rdfcp [ant04] con04) -testRule04e = test "testRule01e" (checkInference rdfcp [bwd04] con04) - --- 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 = getRule "rs_rdfs:r3" -ant05 = formExpr $ makeFormula scopeex "ant05" $ - "ex:s ex:p1 ex:o1 ; " ++ - " ex:p2 _:o2 . " ++ - "ex:p1 rdfs:range ex:pr1 . " ++ - "ex:p2 rdfs:range ex:pr2 . " -con05 = formExpr $ makeFormula scopeex "con05" $ - "ex:o1 rdf:type ex:pr1 ." ++ - "_:o2 rdf:type ex:pr2 ." -bwd05 = formExpr $ makeFormula scopeex "bwd05a" $ - "_:s1 _:p1 ex:o1 . " ++ - "_:s2 _:p2 _:o2 . " ++ - "_:p1 rdfs:range ex:pr1 . " ++ - "_:p2 rdfs:range ex:pr2 . " -testRule05a = testEq "testRule05a" "rs_rdfs:r3" (show $ ruleName rdfsr3) -testRule05b = testEq "testRule05b" [con05] (fwdApply rdfsr3 [ant05]) -testRule05c = testEq "testRule05c" [[bwd05]] (bwdApply rdfsr3 con05) -testRule05d = test "testRule05d" (checkInference rdfsr3 [ant05] con05) -testRule05e = test "testRule01e" (checkInference rdfsr3 [bwd05] con05) - --- 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 = formExpr $ makeFormula scopeex "ant06" $ - "ex:s ex:p1 \"lit1\" . " ++ - "ex:p1 rdfs:range ex:pr1 . " -con06 = formExpr $ makeFormula scopeex "con06" $ - "_:o1 rdf:type ex:pr1 ." -bwd06 = formExpr $ makeFormula scopeex "bwd06a" $ - "_:s1 _:p1 _:o1 . " ++ - "_:p1 rdfs:range ex:pr1 . " -chk06 = formExpr $ makeFormula scopeex "bwd06a" $ - "_:s1 _:p1 \"lit1\" . " ++ - "_:p1 rdfs:range ex:pr1 . " -testRule06a = testEq "testRule06a" "rs_rdfs:r3" (show $ ruleName rdfsr3) -testRule06b = testEq "testRule06b" [] (fwdApply rdfsr3 [ant06]) -testRule06c = testEq "testRule06c" [[bwd06]] (bwdApply rdfsr3 con06) -testRule06d = testEq "testRule06d" False (checkInference rdfsr3 [ant06] con06) -testRule06e = testEq "testRule06e" True (checkInference rdfsr3 [bwd06] con06) -testRule06f = testEq "testRule06e" False (checkInference rdfsr3 [chk06] con06) - --- Collected rule tests - -testRules = TestList - [ testRule01a, testRule01b, testRule01c, testRule01d, testRule01e - , testRule02a, testRule02b, testRule02c, testRule02d - , testRule03a, testRule03b, testRule03c, testRule03d, testRule03e - , testRule03f, testRule03g, testRule03h - , testRule04a, testRule04b, testRule04c, testRule04d, testRule04e - , testRule05a, testRule05b, testRule05c, testRule05d, testRule05e - , testRule06a, testRule06b, testRule06c, testRule06d, testRule06e - , testRule06f - ] - ------------------------- --- Complete proof tests ------------------------- --- --- These are a few tests of complete RDF proof chains based on the --- RDF semantic rules. - - --- RDF entailment proof checks - -rdfBase01 = makeFormula scopeex "rdfBase01" "ex:s ex:p ex:o ." -rdfGoal01 = makeFormula scopeex "rdfGoal01" "ex:p rdf:type rdf:Property ." -rdfStep01a = makeRDFProofStep (getRule "rs_rdf:r1") [rdfBase01] rdfGoal01 -rdfProof01 = makeRDFProof rdfsContext rdfBase01 rdfGoal01 - [ rdfStep01a ] - -rdfBase02 = makeFormula scopeex "rdfBase02" $ - "ex:s ex:p \"l1\"^^rdf:XMLLiteral ." -rdfCon02a = makeFormula scopeex "rdfStep02a" $ - "ex:s ex:p _:lll . " ++ - "_:lll rdf:_allocatedTo \"l1\"^^rdf:XMLLiteral . " -rdfGoal02 = makeFormula scopeex "rdfGoal02" $ - "_:lll rdf:type rdf:XMLLiteral . " -rdfStep02a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase02] rdfCon02a -rdfStep02b = makeRDFProofStep (getRule "rs_rdf:r2") [rdfCon02a] rdfGoal02 -rdfProof02 = makeRDFProof rdfsContext rdfBase02 rdfGoal02 - [ rdfStep02a, rdfStep02b ] - -rdfBase03 = makeFormula scopeex "rdfBase03" $ - "ex:s ex:p ex:o ." -rdfCon03a = makeFormula scopeex "rdfStep03a" $ - "ex:s ex:p _:lll . " ++ - "_:lll rdf:_allocatedTo \"l1\"^^rdf:XMLLiteral . " -rdfGoal03 = makeFormula scopeex "rdfGoal03" $ - "_:lll rdf:type rdf:XMLLiteral . " -rdfStep03a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase03] rdfCon03a -rdfStep03b = makeRDFProofStep (getRule "rs_rdf:r2") [rdfCon03a] rdfGoal03 -rdfProof03 = makeRDFProof rdfsContext rdfBase03 rdfGoal03 - [ rdfStep03a, rdfStep03b ] - -rdfBase04 = makeFormula scopeex "rdfBase04" "ex:s ex:p ex:o ." -rdfGoal04 = makeFormula scopeex "rdfGoal04" "_:s ex:p _:o ." -rdfStep04a = makeRDFProofStep (getRule "rs_rdf:se") [rdfBase04] rdfGoal04 -rdfProof04 = makeRDFProof rdfsContext rdfBase04 rdfGoal04 - [ rdfStep04a ] - -rdfBase05 = makeFormula scopeex "rdfBase05" $ - "ex:s ex:p rdf:nil ." -rdfStep05a = makeRDFProofStep (getRule "rs_rdf:r1") [rdfBase05] rdfCons05a -rdfCons05a = makeFormula scopeex "rdfCons05a" $ - "ex:p rdf:type rdf:Property ." -rdfStep05b = makeRDFProofStep (getRule "rs_rdf:se") - [rdfBase05,rdfCons05a,(getAxiom "rs_rdf:a8")] rdfGoal05 -rdfGoal05 = makeFormula scopeex "rdfGoal05" $ - "ex:s _:p _:n ." ++ - "_:p rdf:type rdf:Property ." ++ - "_:n rdf:type rdf:List ." -rdfProof05 = makeRDFProof rdfsContext rdfBase05 rdfGoal05 - [ rdfStep05a, rdfStep05b ] - --- Swap rdfProof05 proof steps: -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 = makeFormula scopeex "rdfBase07" $ - "ex:s1 ex:p1 \"lll\" ." ++ - "ex:s2 ex:p2 \"lll\" ." ++ - "ex:s3 ex:p3 \"mmm\" ." -rdfStep07a = makeRDFProofStep (getRule "rs_rdf:lg") [rdfBase07] rdfCons07a -rdfCons07a = makeFormula scopeex "rdfCons07a" $ - "ex:s1 ex:p1 _:l ." ++ - "ex:s2 ex:p2 _:l ." ++ - "_:l rdf:_allocatedTo \"lll\" ." ++ - "ex:s3 ex:p3 _:m ." ++ - "_:m rdf:_allocatedTo \"mmm\" ." -rdfStep07b = makeRDFProofStep (getRule "rs_rdfs:r1") [rdfCons07a] rdfCons07b -rdfCons07b = makeFormula scopeex "rdfCons07a" $ - "_:l rdf:type rdfs:Literal ." ++ - "_:m rdf:type rdfs:Literal ." -rdfStep07c = makeRDFProofStep (getRule "rs_rdf:sub") - [rdfCons07a,rdfCons07b] rdfGoal07 -rdfGoal07 = makeFormula scopeex "rdfGoal07" $ - "ex:s1 ex:p1 _:l ." ++ - "ex:s2 ex:p2 _:l ." ++ - "_:l rdf:type rdfs:Literal ." -rdfProof07 = makeRDFProof rdfsContext rdfBase07 rdfGoal07 - [ rdfStep07a, rdfStep07b, rdfStep07c ] - --- Proof of: --- rdf:_123 rdfs:supPropertyOf rdfs:member - -rdfBase08 = makeFormula scopeex "rdfBase08" $ - "ex:s1 rdf:_123 ex:o ." -rdfStep08a = makeRDFProofStep (getRule "rs_rdfs:cp1") [rdfBase08] rdfCons08a -rdfCons08a = makeFormula scopeex "rdfCons08a" $ - "rdf:_123 rdf:type rdfs:ContainerMembershipProperty ." -rdfStep08b = makeRDFProofStep (getRule "rs_rdfs:r12") [rdfCons08a] rdfGoal08 -rdfGoal08 = makeFormula scopeex "rdfCons08b" $ - "rdf:_123 rdfs:subPropertyOf rdfs:member ." -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 = getContextAxiom - (ScopedName (namespaceXsdType "integer") "dt") - nullFormula - allRulesets - -rdfAxiom09 = testEq "rdfAxiom09" "xsd_integer:dt" $ - show (formName rdfAxiomIntDt) - -rdfBase09 = makeFormula scopeex "rdfBase09" $ - "ex:s ex:p \"010\"^^xsd:integer ." -rdfStep09a = makeRDFProofStep (getRule "rs_rdfd:r2") - [rdfAxiomIntDt,rdfBase09] rdfCons09a -rdfCons09a = makeFormula scopeex "rdfCons09a" $ - "ex:s ex:p \"10\"^^xsd:integer ." -rdfStep09b = makeRDFProofStep (getRule "rs_rdf:lg") - [rdfCons09a] rdfCons09b -rdfCons09b = makeFormula scopeex "rdfCons09b" $ - "ex:s ex:p _:l ." ++ - "_:l rdf:_allocatedTo \"10\"^^xsd:integer ." -rdfStep09c = makeRDFProofStep (getRule "rs_rdfd:r1") - [rdfAxiomIntDt,rdfCons09a,rdfCons09b] rdfCons09c -rdfCons09c = makeFormula scopeex "rdfCons09c" $ - "_:l rdf:type xsd:integer ." -rdfStep09d = makeRDFProofStep (getRule "rs_rdf:sub") - [rdfCons09a,rdfCons09b,rdfCons09c] rdfGoal09 -rdfGoal09 = makeFormula scopeex "rdfGoal09" $ - "ex:s ex:p \"10\"^^xsd:integer ." ++ - "_:l rdf:_allocatedTo \"10\"^^xsd:integer ." ++ - "_:l rdf:type xsd:integer ." -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 = getContextAxiom - (ScopedName (namespaceXsdType "string") "dt") - nullFormula - allRulesets - -rdfAxiom10 = testEq "rdfAxiom10" "xsd_string:dt" $ - show (formName rdfAxiomStrDt) - -rdfRule10 = testEq "rdfRule10" "xsd_string:ls" $ - show (ruleName (getRule "xsd_string:ls")) - -rdfBase10 = makeFormula scopeex "rdfBase10" $ - "ex:s ex:p \"abc\" . " ++ - "ex:s ex:p \"def\"^^xsd:string . " -rdfStep10a = makeRDFProofStep (getRule "xsd_string:ls") - [rdfBase10] rdfCons10a -rdfCons10a = makeFormula scopeex "rdfCons10a" $ - "ex:s ex:p \"abc\"^^xsd:string . " -rdfStep10b = makeRDFProofStep (getRule "xsd_string:sl") - [rdfBase10] rdfCons10b -rdfCons10b = makeFormula scopeex "rdfCons10b" $ - "ex:s ex:p \"def\" . " -rdfStep10c = makeRDFProofStep (getRule "rs_rdf:sub") - [rdfCons10a,rdfCons10b,rdfAxiomStrDt] rdfGoal10 -rdfGoal10 = makeFormula scopeex "rdfGoal10" $ - "ex:s ex:p \"abc\"^^xsd:string . " ++ - "ex:s ex:p \"def\" . " ++ - "xsd:string rdf:type rdfs:Datatype . " -rdfProof10 = makeRDFProof xsdstrContext rdfBase10 rdfGoal10 - [ rdfStep10a, rdfStep10b, rdfStep10c ] - -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 = TestList - [ testRules - , testRdf - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - -p10 = runTestTT $ TestList - [ rdfAxiom10 - , rdfRule10 - , testProof "rdfProof10" True rdfProof10 - ] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFProofContextTest.hs,v $ --- $Author: graham $ --- $Revision: 1.14 $ --- $Log: RDFProofContextTest.hs,v $ --- Revision 1.14 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.13 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.12 2003/12/20 12:53:40 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.11 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.10 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.9 2003/12/16 07:05:37 graham --- Working on updated RDFProofContext --- --- Revision 1.8 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.7 2003/12/10 03:48:57 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.6 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.5 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.4 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.3 2003/10/09 17:16:13 graham --- Added test cases to exercise features of rules used to capture --- RDF semantics. Also added proof test case using XML literal. --- --- Revision 1.2 2003/10/09 13:58:59 graham --- Sync with CVS. Preparing to eliminate QueryBindingFilter in favour --- of using just QueryBindingModifier. --- --- Revision 1.1 2003/10/02 13:39:41 graham --- RDF axioms and rules defined as Rulesets, and moved out of module --- RDFProofCheck into RDFProorfContext, with corresponding test cases --- moved to module RDFProorfContextTest. --- diff --git a/Swish/HaskellRDF/RDFProofTest.hs b/Swish/HaskellRDF/RDFProofTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFProofTest.hs +++ /dev/null @@ -1,1080 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFProofTest.hs,v 1.21 2004/01/06 13:53:10 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFProofTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module tests the RDFproof module, which instantiates the proof --- rule class over RDF graphs. --- --------------------------------------------------------------------------------- - --- WNH RIP OUTmodule Swish.HaskellRDF.RDFProofTest where - -import Swish.HaskellRDF.RDFProof - ( RDFProof, RDFProofStep - , makeRDFProof, makeRDFProofStep - , makeRdfInstanceEntailmentRule - , makeRdfSubgraphEntailmentRule - , makeRdfSimpleEntailmentRule - ) - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryFind, rdfQuerySubs ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBindingFilter, RDFVarBindingModify ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFClosure, RDFRuleset - , GraphClosure(..), makeGraphClosureRule - , makeRDFGraphFromN3String - , makeRDFFormula - , makeN3ClosureAllocatorRule - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeNodeAllocTo - ) - -import Swish.HaskellRDF.RDFGraph - ( Label(..), RDFLabel(..), NSGraph(..), RDFGraph - , getArcs, add, allLabels, allNodes ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..), nullVarBinding - , VarBindingModify(..) - , makeVarFilterModify - , varBindingId -- , varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE - ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..), ScopedName(..) ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - -import Data.Maybe - ( isJust, fromJust ) - --- misc helpers - -test :: String -> Bool -> Test -test lab tst = TestCase $ assertBool lab tst - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab e a = TestCase $ assertEqual lab e a - -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) - -testIn :: (Eq a, Show a) => String -> a -> [a] -> Test -testIn lab eg a = TestCase $ assertBool lab (eg `elem` a) - --- test1: simple query with URI, literal and blank nodes. - -scope1 = Namespace "scope1" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope1" - -prefix1 = - "@prefix ex: . \n" ++ - " \n" - -graph1 = makeRDFGraphFromN3String graph1str -graph1str = prefix1 ++ - "ex:s1 ex:p ex:o1 . \n" ++ - "ex:s2 ex:p \"lit1\" . \n" ++ - "[ ex:p ex:o3 ] . \n" - -query11 = makeRDFGraphFromN3String query11str -query11str = prefix1 ++ - "?s ex:p ?o . \n" - -result11 = makeRDFGraphFromN3String result11str -result11str = prefix1 ++ - "?s ex:r ?o . \n" - -result11a = makeRDFGraphFromN3String result11astr -result11astr = prefix1 ++ - "ex:s1 ex:r ex:o1 . \n" ++ - "ex:s2 ex:r \"lit1\" . \n" ++ - "[ ex:r ex:o3 ] . \n" - -result11b = makeRDFGraphFromN3String result11bstr -result11bstr = prefix1 ++ - "ex:s1 ex:r ex:o1 . \n" - -result11c = makeRDFGraphFromN3String result11cstr -result11cstr = prefix1 ++ - "ex:s2 ex:r \"lit1\" . \n" - -backsub11a = makeRDFGraphFromN3String backsub11astr -backsub11astr = prefix1 ++ - "ex:s1 ex:p ex:o1 . \n" ++ - "ex:s2 ex:p \"lit1\" . \n" - -backsub11b = makeRDFGraphFromN3String backsub11bstr -backsub11bstr = prefix1 ++ - "ex:s2 ex:p \"lit1\" . \n" - -rul11 = makeN3ClosureSimpleRule scope1 "rul11" query11str result11str -fwd11 = fwdApply rul11 [graph1] -testFwd11 = testEq "testFwd11" 1 (length fwd11) -testFwd11a = testIn "testFwd11a" result11a fwd11 -bwd11 = bwdApply rul11 (add result11b result11c) -testBwd11 = testEq "testBwd11" 1 (length (head bwd11)) -testBwd11a = testIn "testBwd11a" backsub11a (head bwd11) - -test1 = TestList - [ testFwd11 - , testFwd11a - , testBwd11 - , testBwd11a - ] - - --- test2: a range of more complex queries based on a --- single relationship graph. - -scope2 = Namespace "scope2" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope2" - -prefix2 = - "@prefix pers: . \n" ++ - "@prefix rel: . \n" ++ - " \n" - -graph2 = makeRDFGraphFromN3String graph2str -graph2str = prefix2 ++ - "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 = makeRDFGraphFromN3String query21str -query21str = prefix2 ++ - "?a rel:wife ?b . \n" - -result21 = makeRDFGraphFromN3String result21str -result21str = prefix2 ++ - "?b rel:husband ?a . \n" - -result21a = makeRDFGraphFromN3String result21astr -result21astr = prefix2 ++ - "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 = makeRDFGraphFromN3String result21bstr -result21bstr = prefix2 ++ - "pers:Do1 rel:husband pers:St1 . \n" ++ - "pers:Ma2 rel:husband pers:Pa2 . \n" - -bwd21a = makeRDFGraphFromN3String bwd21astr -bwd21astr = prefix2 ++ - "pers:St1 rel:wife pers:Do1 . \n" ++ - "pers:Pa2 rel:wife pers:Ma2 . \n" - -rul21 = makeN3ClosureSimpleRule scope2 "rul21" query21str result21str -fwd21 = fwdApply rul21 [graph2] -testFwd21 = testEq "testResult21" 1 (length fwd21) -testFwd21a = testIn "testResult21a" result21a fwd21 -bwd21 = bwdApply rul21 result21b -testBwd21 = testEq "testBwd21" 1 (length $ head bwd21) -testBwd21a = testIn "testBwd21a" bwd21a (head bwd21) - - -query22 = makeRDFGraphFromN3String query22str -query22str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?b rel:son ?c . \n" - -result22 = makeRDFGraphFromN3String result22str -result22str = prefix2 ++ - "?a rel:grandparent ?c . \n" - -result22a = makeRDFGraphFromN3String result22astr -result22astr = prefix2 ++ - "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 = makeRDFGraphFromN3String result22bstr -result22bstr = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Ro4 . \n" ++ - "pers:Pa2 rel:grandparent pers:Ol4 . \n" - -bwd22a = makeRDFGraphFromN3String bwd22astr -bwd22astr = prefix2 ++ - "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 = makeN3ClosureSimpleRule scope2 "rul22" query22str result22str -fwd22 = fwdApply rul22 [graph2] -testFwd22 = testEq "testResult22" 1 (length fwd22) -testFwd22a = testIn "testResult22a" result22a fwd22 -bwd22 = bwdApply rul22 result22b -testBwd22 = testEq "testBwd22" 1 (length $ head bwd22) -testBwd22a = testIn "testBwd22a" bwd22a (head bwd22) - - -query23 = makeRDFGraphFromN3String query23str -query23str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result23 = makeRDFGraphFromN3String result23str -result23str = prefix2 ++ - "?b rel:brother ?c . \n" - -result23a = makeRDFGraphFromN3String result23astr -result23astr = prefix2 ++ - "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 = makeRDFGraphFromN3String result23bstr -result23bstr = prefix2 ++ - "pers:Gr3 rel:brother pers:Gr3 . \n" ++ - "pers:Gr3 rel:brother pers:La3 . \n" - -bwd23a = makeRDFGraphFromN3String bwd23astr -bwd23astr = prefix2 ++ - "_: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 = makeN3ClosureSimpleRule scope2 "rul23" query23str result23str -fwd23 = fwdApply rul23 [graph2] -testFwd23 = testEq "testResult23" 1 (length fwd23) -testFwd23a = testIn "testResult23a" result23a fwd23 -bwd23 = bwdApply rul23 result23b -testBwd23 = testEq "testBwd23" 1 (length $ head bwd23) -testBwd23a = testIn "testBwd23a" bwd23a (head bwd23) - - --- Test case to return multiple alternative bindings --- --- (?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) - -graph24 = makeRDFGraphFromN3String graph24str -graph24str = prefix2 ++ - "pers:Ma2 rel:son pers:Gr3 . \n" ++ - "pers:Ma2 rel:stepson pers:St3 . \n" - -query24 = makeRDFGraphFromN3String query24str -query24str = prefix2 ++ - "?c rel:son ?a . \n" ++ - "?c rel:stepson ?b . \n" - -result24 = makeRDFGraphFromN3String result24str -result24str = prefix2 ++ - "?a rel:stepbrother ?b . \n" ++ - "?b rel:stepbrother ?a . \n" - -result24a = makeRDFGraphFromN3String result24astr -result24astr = prefix2 ++ - "pers:Gr3 rel:stepbrother pers:St3 . \n" ++ - "pers:St3 rel:stepbrother pers:Gr3 . \n" - -bwd24a1 = makeRDFGraphFromN3String bwd24a1str -bwd24a1str = prefix2 ++ - "_: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 = makeRDFGraphFromN3String bwd24a2str -bwd24a2str = prefix2 ++ - "_:c1 rel:son pers:Gr3 . \n" ++ - "_:c1 rel:stepson pers:St3 . \n" - -bwd24a3 = makeRDFGraphFromN3String bwd24a3str -bwd24a3str = prefix2 ++ - "_:c2 rel:stepson pers:Gr3 . \n" ++ - "_:c2 rel:son pers:St3 . \n" - -bwd24a4 = makeRDFGraphFromN3String bwd24a4str -bwd24a4str = prefix2 ++ - "_: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 = makeN3ClosureSimpleRule scope2 "rul24" query24str result24str -fwd24 = fwdApply rul24 [graph24] -testFwd24 = testEq "testResult24" 1 (length fwd24) -testFwd24a = testIn "testResult24a" result24a fwd24 -bwd24 = bwdApply rul24 result24a -testBwd24 = testEq "testBwd24" 4 (length bwd24) -testBwd24a1 = testIn "testBwd24a1" bwd24a1 (bwd24!!0) -testBwd24a2 = testIn "testBwd24a2" bwd24a2 (bwd24!!1) -testBwd24a3 = testIn "testBwd24a3" bwd24a3 (bwd24!!2) -testBwd24a4 = testIn "testBwd24a4" bwd24a4 (bwd24!!3) - - --- bwd chain from partial conclusion --- Also, fail because conclusion is more than the rule --- can derive from any input. - -query25 = makeRDFGraphFromN3String query25str -query25str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?a rel:daughter ?c . \n" - -result25 = makeRDFGraphFromN3String result25str -result25str = prefix2 ++ - "?b rel:sister ?c . \n" ++ - "?c rel:brother ?b . \n" - -result25a = makeRDFGraphFromN3String result25astr -result25astr = prefix2 ++ - "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 = makeRDFGraphFromN3String result25bstr -result25bstr = prefix2 ++ - "pers:Ro4 rel:sister pers:Rh4 . \n" ++ - "pers:Rh4 rel:brother pers:Ro4 . \n" --} - -result25c = makeRDFGraphFromN3String result25cstr -result25cstr = prefix2 ++ - "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 = makeRDFGraphFromN3String result25dstr -result25dstr = prefix2 ++ - "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 = makeRDFGraphFromN3String conc25str -conc25str = prefix2 ++ - "pers:Wi3 rel:sister pers:Ma3 . \n" ++ - "pers:Rh4 rel:brother pers:Ro4 . \n" - -bwd25a = makeRDFGraphFromN3String bwd25astr -bwd25astr = prefix2 ++ - "_: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 = makeN3ClosureSimpleRule scope2 "rul25" query25str result25str -fwd25 = fwdApply rul25 [graph2] -testFwd25 = testEq "testResult25" 1 (length fwd25) -testFwd25a = testIn "testResult25a" result25a fwd25 -bwd25 = bwdApply rul25 conc25 -testBwd25 = testEq "testBwd25" 1 (length $ head bwd25) -testBwd25a = testIn "testBwd25a" bwd25a (head bwd25) --- testBwd25a1 = testEq "testBwd25a" bwd25a (head $ head bwd25) -bwd25c = bwdApply rul25 result25c -testBwd25c = testNo "testBwd25c" bwd25c -bwd25d = bwdApply rul25 result25d -testBwd25d = testNo "testBwd25d" bwd25d - - -test2 = TestList - [ testFwd21 - , testFwd21a - , testBwd21 - , testBwd21a - , testFwd22 - , testFwd22a - , testBwd22 - , testBwd22a - , testFwd23 - , testFwd23a - , testBwd23 - , testBwd23a - , testFwd24, testFwd24a - , testBwd24, testBwd24a1, testBwd24a2, testBwd24a3, testBwd24a4 - , testFwd25 - , testFwd25a - , testBwd25 - , testBwd25a, testBwd25c, testBwd25d - ] - --- test3: check variable binding filters - -scope3 = Namespace "scope3" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope3" - -query31 = makeRDFGraphFromN3String query31str -query31str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -modify31 :: RDFVarBindingModify -modify31 = makeVarFilterModify $ varFilterNE (Var "b") (Var "c") - -result31 = makeRDFGraphFromN3String result31str -result31str = prefix2 ++ - "?b rel:brother ?c . \n" - -result31a = makeRDFGraphFromN3String result31astr -result31astr = prefix2 ++ - "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 = makeRDFGraphFromN3String result31bstr -result31bstr = prefix2 ++ - "pers:Gr3 rel:brother pers:Gr3 . \n" - -result31c = makeRDFGraphFromN3String result31cstr -result31cstr = prefix2 ++ - "pers:Gr3 rel:brother pers:La3 . \n" - -bwd31c = makeRDFGraphFromN3String bwd31cstr -bwd31cstr = prefix2 ++ - "_:a rel:son pers:Gr3 . \n" ++ - "_:a rel:son pers:La3 . \n" - -rul31 = makeN3ClosureRule scope3 "rul31" query31str result31str modify31 -fwd31 = fwdApply rul31 [graph2] -testFwd31 = testEq "testResult31" 1 (length fwd31) -testFwd31a = testIn "testResult31a" result31a fwd31 -calcbwd31b = bwdApply rul31 result31b -testBwd31b = testEq "testBwd31" 0 (length calcbwd31b) -calcbwd31c = bwdApply rul31 result31c -testBwd31cn = testEq "testBwd31" 1 (length $ head calcbwd31c) -testBwd31c = testIn "testBwd31c" bwd31c (head calcbwd31c) - -test3 = TestList - [ testFwd31 - , testFwd31a - , testBwd31b - , testBwd31cn, testBwd31c - ] - --- Instance entailment tests - -scope4 = Namespace "scope4" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope4" - -graph4 = makeRDFGraphFromN3String graph4str -graph4str = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" - -vocab4 = allNodes (not . labelIsVar) graph4 - -name4 = ScopedName scope4 "instance4" - -rule4 = makeRdfInstanceEntailmentRule name4 vocab4 - -fwd42a = makeRDFGraphFromN3String fwd42astr -fwd42astr = prefix2 ++ - "pers:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" - -fwd42b = makeRDFGraphFromN3String fwd42bstr -fwd42bstr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter _:Rh4 . \n" - -fwd42c = makeRDFGraphFromN3String fwd42cstr -fwd42cstr = prefix2 ++ - "pers:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:daughter _:Rh4 . \n" - -fwd42d = makeRDFGraphFromN3String fwd42dstr -fwd42dstr = prefix2 ++ - "_:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" - -fwd42e = makeRDFGraphFromN3String fwd42estr -fwd42estr = prefix2 ++ - "_:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" - -fwd42f = makeRDFGraphFromN3String fwd42fstr -fwd42fstr = prefix2 ++ - "_:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter _:Rh4 . \n" - -fwd42g = makeRDFGraphFromN3String fwd42gstr -fwd42gstr = prefix2 ++ - "_:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:daughter _:Rh4 . \n" - --- Non-entailments - -fwd42w = makeRDFGraphFromN3String fwd42wstr -fwd42wstr = prefix2 ++ - "pers:Gr3 rel:daughter pers:Ro4 . \n" - -fwd42x = makeRDFGraphFromN3String fwd42xstr -fwd42xstr = prefix2 ++ - "pers:Gr3 rel:daughter pers:Ro4 . \n" - -fwd42y = makeRDFGraphFromN3String fwd42ystr -fwd42ystr = prefix2 ++ - "_:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter pers:Ro4 . \n" - -fwd42z = makeRDFGraphFromN3String fwd42zstr -fwd42zstr = prefix2 ++ - "_:Gr3 rel:son _:Ro4 ; \n" ++ - " rel:son _:Rh4 . \n" - - -bwd43 = makeRDFGraphFromN3String bwd43str -bwd43str = prefix2 ++ - "_:a1 rel:son pers:Ro4 . \n" ++ - "_:a2 rel:daughter pers:Rh4 . \n" - -bwd43a = makeRDFGraphFromN3String bwd43astr -bwd43astr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" - -bwd43b = makeRDFGraphFromN3String bwd43bstr -bwd43bstr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" ++ - "pers:Ro4 rel:daughter pers:Rh4 . \n" - -bwd43c = makeRDFGraphFromN3String bwd43cstr -bwd43cstr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" ++ - "pers:Rh4 rel:daughter pers:Rh4 . \n" - -bwd43d = makeRDFGraphFromN3String bwd43dstr -bwd43dstr = prefix2 ++ - "pers:Ro4 rel:son pers:Ro4 . \n" ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" - -bwd43e = makeRDFGraphFromN3String bwd43estr -bwd43estr = prefix2 ++ - "pers:Ro4 rel:son pers:Ro4 . \n" ++ - "pers:Ro4 rel:daughter pers:Rh4 . \n" - -bwd43f = makeRDFGraphFromN3String bwd43fstr -bwd43fstr = prefix2 ++ - "pers:Ro4 rel:son pers:Ro4 . \n" ++ - "pers:Rh4 rel:daughter pers:Rh4 . \n" - -bwd43g = makeRDFGraphFromN3String bwd43gstr -bwd43gstr = prefix2 ++ - "pers:Rh4 rel:son pers:Ro4 . \n" ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" - -bwd43h = makeRDFGraphFromN3String bwd43hstr -bwd43hstr = prefix2 ++ - "pers:Rh4 rel:son pers:Ro4 . \n" ++ - "pers:Ro4 rel:daughter pers:Rh4 . \n" - -bwd43i = makeRDFGraphFromN3String bwd43istr -bwd43istr = prefix2 ++ - "pers:Rh4 rel:son pers:Ro4 . \n" ++ - "pers:Rh4 rel:daughter pers:Rh4 . \n" - --- Check basics -testRuleName41 = testEq "testRuleName41" name4 (ruleName rule4) -testVocab41 = testEq "testVocab41" 3 (length vocab4) - --- Forward chaining -fwdApply42 = fwdApply rule4 [graph4] -testFwdLength42 = testEq "testFwdLength42" 7 (length fwdApply42) -testFwdApply42a = testIn "testFwdApply42a" fwd42a fwdApply42 -testFwdApply42b = testIn "testFwdApply42b" fwd42b fwdApply42 -testFwdApply42c = testIn "testFwdApply42c" fwd42c fwdApply42 -testFwdApply42d = testIn "testFwdApply42d" fwd42d fwdApply42 -testFwdApply42e = testIn "testFwdApply42e" fwd42e fwdApply42 -testFwdApply42f = testIn "testFwdApply42f" fwd42f fwdApply42 -testFwdApply42g = testIn "testFwdApply42g" fwd42g fwdApply42 - --- Backward chaining -bwdApply43 = bwdApply rule4 bwd43 -testBwdLength43 = testEq "testBwdLength43" 9 (length bwdApply43) -testBwdApply43a = testIn "testBwdApply43a" [bwd43a] bwdApply43 -testBwdApply43b = testIn "testBwdApply43b" [bwd43b] bwdApply43 -testBwdApply43c = testIn "testBwdApply43c" [bwd43c] bwdApply43 -testBwdApply43d = testIn "testBwdApply43d" [bwd43d] bwdApply43 -testBwdApply43e = testIn "testBwdApply43e" [bwd43e] bwdApply43 -testBwdApply43f = testIn "testBwdApply43f" [bwd43f] bwdApply43 -testBwdApply43g = testIn "testBwdApply43g" [bwd43g] bwdApply43 -testBwdApply43h = testIn "testBwdApply43h" [bwd43h] bwdApply43 -testBwdApply43i = testIn "testBwdApply43i" [bwd43i] bwdApply43 - --- Entailment checks -testEntail44a = testEq "testEntail44a" True (checkInference rule4 [graph4] fwd42a) -testEntail44b = testEq "testEntail44b" True (checkInference rule4 [graph4] fwd42b) -testEntail44g = testEq "testEntail44g" True (checkInference rule4 [graph4] fwd42g) -testEntail44w = testEq "testEntail44w" False (checkInference rule4 [graph4] fwd42w) -testEntail44x = testEq "testEntail44x" False (checkInference rule4 [graph4] fwd42x) -testEntail44y = testEq "testEntail44y" False (checkInference rule4 [graph4] fwd42y) -testEntail44z = testEq "testEntail44z" False (checkInference rule4 [graph4] fwd42z) - -test4 = TestList - [ testRuleName41 - , testVocab41 - , testFwdLength42 - , testFwdApply42a - , testFwdApply42b - , testFwdApply42c - , testFwdApply42d - , testFwdApply42e - , testFwdApply42f - , testFwdApply42g - , testBwdLength43 - , testBwdApply43a - , testBwdApply43b - , testBwdApply43c - , testBwdApply43d - , testBwdApply43e - , testBwdApply43f - , testBwdApply43g - , testBwdApply43h - , testBwdApply43i - , testEntail44a - , testEntail44b - , testEntail44g - , testEntail44w - , testEntail44x - , testEntail44y - , testEntail44z - ] - --- Subgraph entailment tests - -scope5 = Namespace "scope5" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope5" - -graph5 = makeRDFGraphFromN3String graph5str -graph5str = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" ++ - "pers:Si3 rel:son pers:Ol4 . \n" - -name5 = ScopedName scope5 "subgraph5" - -rule5 = makeRdfSubgraphEntailmentRule name5 - --- Forward chaining excludes null agraph and copy of antecedent -fwd52a = makeRDFGraphFromN3String fwd52astr -fwd52astr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" - -fwd52b = makeRDFGraphFromN3String fwd52bstr -fwd52bstr = prefix2 ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" - -fwd52c = makeRDFGraphFromN3String fwd52cstr -fwd52cstr = prefix2 ++ - "pers:Si3 rel:son pers:Ol4 . \n" - -fwd52d = makeRDFGraphFromN3String fwd52dstr -fwd52dstr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" - -fwd52e = makeRDFGraphFromN3String fwd52estr -fwd52estr = prefix2 ++ - "pers:Gr3 rel:son pers:Ro4 . \n" ++ - "pers:Si3 rel:son pers:Ol4 . \n" - -fwd52f = makeRDFGraphFromN3String fwd52fstr -fwd52fstr = prefix2 ++ - "pers:Gr3 rel:daughter pers:Rh4 . \n" ++ - "pers:Si3 rel:son pers:Ol4 . \n" - --- Check basics -testRuleName51 = testEq "testRuleName51" name5 (ruleName rule5) - --- Forward chaining -fwdApply52 = fwdApply rule5 [graph5] -testFwdLength52 = testEq "testFwdLength52" 6 (length fwdApply52) -testFwdApply52a = testIn "testFwdApply52a" fwd52a fwdApply52 -testFwdApply52b = testIn "testFwdApply52b" fwd52b fwdApply52 -testFwdApply52c = testIn "testFwdApply52c" fwd52c fwdApply52 -testFwdApply52d = testIn "testFwdApply52d" fwd52d fwdApply52 -testFwdApply52e = testIn "testFwdApply52e" fwd52e fwdApply52 -testFwdApply52f = testIn "testFwdApply52f" fwd52f fwdApply52 - -test5 = TestList - [ testRuleName51 - , testFwdLength52 - , testFwdApply52a - , testFwdApply52b - , testFwdApply52c - , testFwdApply52d - , testFwdApply52e - , testFwdApply52f - ] - --- Simple entailment test --- Simple entailment provides entailment check only, no forward or --- backward chaining. For that use instance- and subgraph- rules. - -scope6 = Namespace "scope6" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope6" - -graph6 = makeRDFGraphFromN3String graph6str -graph6str = prefix2 ++ - "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 scope5 "subgraph6" - -rule6 = makeRdfSimpleEntailmentRule name6 - -simple6a = makeRDFGraphFromN3String simple6astr -simple6astr = prefix2 ++ - "_:Gr3 rel:son pers:Ro4 ; \n" ++ - " rel:daughter pers:Rh4 . \n" - -simple6b = makeRDFGraphFromN3String simple6bstr -simple6bstr = prefix2 ++ - "_:Si3 rel:son pers:Ol4 ; \n" ++ - " rel:son pers:Lo4 . \n" - -simple6c = makeRDFGraphFromN3String simple6cstr -simple6cstr = prefix2 ++ - "_:Si3 rel:son _:Ol4 ; \n" ++ - " rel:son _:Lo4 . \n" - -simple6d = makeRDFGraphFromN3String simple6dstr -simple6dstr = prefix2 ++ - "_:Si3 rel:son _:Ol4 ; \n" ++ - " rel:daughter _:Lo4 . \n" - -simple6e = makeRDFGraphFromN3String simple6estr -simple6estr = prefix2 ++ - "_:Si3 rel:daughter _:Ol4 ; \n" ++ - " rel:mother _:Lo4 . \n" - -testRuleName61 = testEq "testRuleName61" name6 (ruleName rule6) -testSimple62 = test "testSimple62" (checkInference rule6 [graph6] simple6a) -testSimple63 = test "testSimple63" (checkInference rule6 [graph6] simple6b) -testSimple64 = test "testSimple64" (checkInference rule6 [graph6] simple6c) -testSimple65 = test "testSimple65" (checkInference rule6 [graph6] simple6d) -testSimple66 = test "testSimple66" (not $ checkInference rule6 [graph6] simple6e) -testFwd67 = test "testFwd64" (null $ fwdApply rule6 [graph6]) -testBwd68 = test "testBwd65" (null $ bwdApply rule6 graph6) - -test6 = TestList - [ testRuleName61 - , testSimple62 - , testSimple63 - , testSimple64 - , testSimple65 - , testSimple66 - , testFwd67 - , testBwd68 - ] - --- 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" - "http://id.ninebynine.org/wip/2003/rdfprooftest/scope7" - -graph7 = makeRDFGraphFromN3String graph7str -graph7str = prefix2 ++ - "pers:Ro4 rel:uncle pers:La3 ; \n" ++ - " rel:uncle pers:Si3 . \n" ++ - "pers:Rh4 rel:uncle pers:La3 ; \n" ++ - " rel:uncle pers:Si3 . \n" - -query71 = makeRDFGraphFromN3String query71str -query71str = prefix2 ++ - "?a rel:uncle ?c . \n" - -result71 = makeRDFGraphFromN3String result71str -result71str = prefix2 ++ - "?a rel:father ?b . \n" ++ - "?b rel:brother ?c . \n" - -result71a = makeRDFGraphFromN3String result71astr -result71astr = prefix2 ++ - "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 = makeN3ClosureAllocatorRule scope7 "rul71" - query71str result71str varBindingId mod71 - -mod71 = makeNodeAllocTo (Var "b") (Var "a") - -var71 = rdfQueryFind query71 graph7 -testVar71 = testEq "testVar71" 4 (length var71) -var71a = vbmApply (mod71 (allLabels labelIsVar graph7)) var71 -testVar71a = testEq "testVar71a" 4 (length var71a) -var71_1 = head var71a -map71a = Just (Var "#a") -map71b = Just (Var "#b") -map71c = Just (Var "#c") -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")) -sub71a = rdfQuerySubs var71a result71 -testSub71a = testEq "testVar71a" 4 (length sub71a) - -fwd71 = fwdApply rul71 [graph7] -testFwd71 = testEq "testResult71" 1 (length fwd71) -testFwd71a = testIn "testResult71a" result71a fwd71 - -test7 = TestList - [ testVar71, testVar71a - -- , testVar71_1a, testVar71_1b, testVar71_1c - , testSub71a - , testFwd71 - , testFwd71a - ] - --- Full test suite, main program, and useful expressions for interactive use - -allTests = TestList - [ test1 - , test2 - , test3 - , test4 - , test5 - , test6 - , test7 - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFProofTest.hs,v $ --- $Author: graham $ --- $Revision: 1.21 $ --- $Log: RDFProofTest.hs,v $ --- Revision 1.21 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.20 2003/12/20 12:53:40 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.19 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.18 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.17 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.16 2003/10/24 21:05:09 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.15 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.14 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.13 2003/09/30 20:02:39 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.12 2003/09/30 16:39:41 graham --- Refactor proof code to use new ruleset logic. --- Moved some support code from RDFProofCheck to RDFRuleset. --- --- Revision 1.11 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.10 2003/07/02 22:39:36 graham --- Subgraph entailment and Graph closure instance entailment rules --- now tested. RDF forward chaining revised to combine output graphs, --- to preserve blank node relationships. --- --- Revision 1.9 2003/07/02 21:27:30 graham --- Graph closure with instance rule tested. --- About to change ProofTest for graph forward chaining to return --- a single result graph. --- --- Revision 1.8 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.7 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.6 2003/06/25 10:18:55 graham --- Added variable binding filter test case for forward and backward chaining. --- --- Revision 1.5 2003/06/25 09:52:25 graham --- Replaced Rule class with algebraic data type --- --- Revision 1.4 2003/06/19 19:49:07 graham --- RDFProofCheck compiles, but test fails --- --- Revision 1.3 2003/06/18 18:40:08 graham --- Basic proof backchaining tests OK. --- Next: add filtering on variable bindings. --- --- Revision 1.2 2003/06/18 01:29:29 graham --- Fixed up some problems with backward chaining queries. --- Query test cases still to complete. --- Proof incomplete. --- --- Revision 1.1 2003/06/13 21:43:47 graham --- Add proof test module. --- Many tests pass, backward chaining still problem. --- Need to add proof-checker test cases. --- diff --git a/Swish/HaskellRDF/RDFQuery.hs b/Swish/HaskellRDF/RDFQuery.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFQuery.hs +++ /dev/null @@ -1,737 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFQuery.hs,v 1.32 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFQuery --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines functions for querying an RDF graph to obtain --- a set of variable substitutions, and to apply a set of variable --- substitutions to a query pattern to obtain a new graph. --- --- It also defines a few primitive graph access functions. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFQuery - ( rdfQueryFind, rdfQueryFilter - , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify - , rdfQueryInstance - , rdfQuerySubs, rdfQueryBackSubs - , rdfQuerySubsAll - , rdfQuerySubsBlank, rdfQueryBackSubsBlank - , rdfFindArcs, rdfSubjEq, rdfPredEq, rdfObjEq - , rdfFindPredVal, rdfFindPredInt, rdfFindValSubj - , rdfFindList - -- debug - , rdfQuerySubs2 ) -where - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingFilter - ) - -import Swish.HaskellRDF.RDFGraph - ( Arc(..), LDGraph(..) - , arcSubj, arcPred, arcObj - , RDFLabel(..) - , isDatatyped, isBlank, isQueryVar - , getLiteralText, makeBlank - , RDFTriple - , RDFGraph, emptyRDFGraph - , allLabels, remapLabels - , res_rdf_first - , res_rdf_rest - , res_rdf_nil - ) - -import Swish.HaskellRDF.MapXsdInteger - ( mapXsdInteger - ) - -import Swish.HaskellRDF.Datatype - ( DatatypeMap(..) - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , VarBindingFilter(..) - ) - -import Swish.HaskellRDF.Vocabulary - ( xsd_integer, xsd_nonneg_integer - ) - -import Swish.HaskellUtils.FunctorM - ( FunctorM(..) ) - -import Swish.HaskellUtils.ListHelpers - ( listProduct, allp, anyp ) - -import Control.Monad.State - ( State(..), modify ) - -import Data.Maybe - ( catMaybes, isJust, fromJust ) - ------------------------------------------------------------- --- Primitive RDF graph queries ------------------------------------------------------------- - --- |Basic graph-query function. --- A very basic form of graph query, a query graph and --- a target graph, and returns a list of 'RDFVarBinding' --- values, each of which corresponds to a set of variable --- bindings that make the query graph a subgraph of the --- target graph, or [] if the query cannot be matched. --- --- 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 -> RDFGraph -> [RDFVarBinding] -rdfQueryFind qg = - rdfQueryPrim1 matchQueryVariable nullRDFVarBinding (getArcs qg) - --- 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 = - catMaybes $ map (getBinding nodeq qa) $ getArcs tg - --- |RDF query filter. This function applies a supplied query binding --- filter to the result from a call of 'rdfQueryFind'. --- --- If none of the query bindings found satisfy the filter, a null --- list is returned (which is what 'rdfQueryFind' returns if the --- query cannot be satisfied). --- --- (Because of lazy evaluation, this should be as efficient as --- applying the filter as the search proceeds. I started to build --- the filter logic into the query function itself, with consequent --- increase in complexity, until I remembered lazy evaluation lets --- me keep things separate.) --- -rdfQueryFilter :: - RDFVarBindingFilter -> [RDFVarBinding] -> [RDFVarBinding] -rdfQueryFilter qbf qbs = filter (vbfTest qbf) qbs - ------------------------------------------------------------- --- Backward-chaining RDF graph queries ------------------------------------------------------------- - --- |Reverse graph-query function. --- Similar to rdfQueryFind, but with different success criteria. --- The query graph is matched against the supplied graph, --- but not every triple of the query is required to be matched. --- Rather, every triple of the target graph must be matched, --- and substitutions for just the variables thus bound are --- returned. In effect, these are subsitutions in the query --- that entail the target graph (where rdfQueryFind returns --- substitutions that are entailed by the target graph). --- --- Multiple substitutions may be used together, so the result --- returned is a list of lists of query bindings. Each inner --- list contains several variable bindings that must all be applied --- separately to the closure antecendents to obtain a collection of --- expressions that together are antecedent to the supplied --- conclusion. A null list of bindings returned means the --- conclusion can be inferred without any antecedents. --- --- Note: in back-chaining, the conditions required to prove each --- target triple are derived independently, using the inference rule --- for each such triple, so there are no requirements to check --- consistency with previously determined variable bindings, as --- there are when doing forward chaining. A result of this is that --- there may be redundant triples generated by the back-chaining --- process. Any process using back-chaining should deal with the --- results returned accordingly. --- --- An empty outer list is returned if no combination of --- substitutions can infer the supplied target. --- -rdfQueryBack :: RDFGraph -> RDFGraph -> [[RDFVarBinding]] -rdfQueryBack qg tg = - rdfQueryBack1 matchQueryVariable [] (getArcs qg) (getArcs tg) - -rdfQueryBack1 :: - NodeQuery RDFLabel -> [RDFVarBinding] -> [Arc RDFLabel] -> [Arc RDFLabel] - -> [[RDFVarBinding]] -rdfQueryBack1 _ initv _ [] = [initv] -rdfQueryBack1 nodeq initv qas (ta:tas) = concat - [ rdfQueryBack1 nodeq (nv:initv) qas tas - | nv <- rdfQueryBack2 nodeq qas ta ] - --- Match a query against a single graph term, and return any new sets of --- variable bindings thus defined. Each member of the result is an --- alternative possible set of variable bindings. An empty list returned --- means no match. --- -rdfQueryBack2 :: - NodeQuery RDFLabel -> [Arc RDFLabel] -> Arc RDFLabel - -> [RDFVarBinding] -rdfQueryBack2 nodeq qas ta = - [ fromJust b | qa <- qas, let b = getBinding nodeq qa ta, isJust b ] - --- |RDF back-chaining query filter. This function applies a supplied --- query binding filter to the result from a call of 'rdfQueryBack'. --- --- Each inner list contains bindings that must all be used to satisfy --- the backchain query, so if any query binding does not satisfy the --- filter, the entire corresponding row is removed -rdfQueryBackFilter :: - RDFVarBindingFilter -> [[RDFVarBinding]] -> [[RDFVarBinding]] -rdfQueryBackFilter qbf qbss = filter (and . map (vbfTest qbf)) qbss - --- |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 qbss = concatMap (rdfQueryBackModify1 qbm) qbss - --- Auxiliary back-chaining query variable binding modifier function: --- for a supplied list of variable bindings, all of which must be used --- together when backchaining: --- (a) make each list member into a singleton list --- (b) apply the binding modifier to each such list, which may result --- in a list with zero, one or more elements. --- (c) return the listProduct of these, each member of which is --- an alternative list of variable bindings, where the members of --- each alternative must be used together. --- -rdfQueryBackModify1 :: - VarBindingModify a b -> [VarBinding a b] -> [[VarBinding a b]] -rdfQueryBackModify1 qbm qbs = listProduct $ map ((vbmApply qbm) . (:[])) qbs - ------------------------------------------------------------- --- Simple entailment graph query ------------------------------------------------------------- - --- |Simple entailment (instance) graph query. --- This function queries a graph to find instances of the --- query graph in the target graph. It is very similar --- to the normal forward chaining query 'rdfQueryFind', --- except that blank nodes rather than query variable nodes --- in the query graph are matched against nodes in the target --- graph. Neither graph should contain query variables. --- --- An "instance" is defined by the RDF semantics specification, --- per , and is obtained by replacing --- blank nodes with URIs, literals or other blank nodes. RDF --- "simple entailment" can be determined in terms of instances. --- This function looks for a subgraph of the target graph that --- is an instance of the query graph, which is a necessary and --- sufficient condition for RDF entailment (see the Interpolation --- Lemma in RDF Semantics, section 1.2). --- --- It is anticipated that this query function can be used in --- conjunction with backward chaining to determine when the --- search for sufficient antecendents to determine some goal --- has been concluded. -rdfQueryInstance :: RDFGraph -> RDFGraph -> [RDFVarBinding] -rdfQueryInstance qg = - rdfQueryPrim1 matchQueryBnode nullRDFVarBinding (getArcs qg) - ------------------------------------------------------------- --- Primitive RDF graph query support functions ------------------------------------------------------------- - --- |Type of query node testing function. Return value is: --- - Nothing if no match --- - Just True if match with new variable binding --- - Just False if match with new variable binding -type NodeQuery a = a -> a -> Maybe Bool - --- Extract query binding from matching a single query triple with a --- target triple, returning: --- - Nothing if the query is not matched --- - Just nullVarBinding if there are no new variable bindings --- - Just binding is a new query binding for this match -getBinding :: - NodeQuery RDFLabel -> Arc RDFLabel -> Arc RDFLabel - -> Maybe RDFVarBinding -getBinding nodeq (Arc s1 p1 o1) (Arc s2 p2 o2) = - makeBinding [(s1,s2),(p1,p2),(o1,o2)] [] - where - makeBinding [] bs = Just $ makeVarBinding bs - makeBinding (vr@(v,r):bvrs) bs = - case nodeq v r of - Nothing -> Nothing - Just False -> makeBinding bvrs bs - Just True -> makeBinding bvrs (vr:bs) - --- Match variable node against target node, returning --- Nothing if they do not match, Just True if a variable --- node is matched (thereby creating a new variable binding) --- or Just False if a non-blank node is matched. -matchQueryVariable :: NodeQuery RDFLabel -matchQueryVariable (Var _) _ = Just True -matchQueryVariable q t - | q == t = Just False - | otherwise = Nothing - --- Match blank query node against target node, returning --- Nothing if they do not match, Just True if a blank node --- is matched (thereby creating a new equivalence) or --- Just False if a non-blank node is matched. -matchQueryBnode :: NodeQuery RDFLabel -matchQueryBnode (Blank _) _ = Just True -matchQueryBnode q t - | q == t = Just False - | otherwise = Nothing - ------------------------------------------------------------- --- Substitute results from RDF query back into a graph ------------------------------------------------------------- - --- |Graph substitution function. --- Uses the supplied variable bindings to substitute variables in --- a supplied graph, returning a list of result graphs corresponding --- to each set of variable bindings applied to the input graph. --- This function is used for formward chaining substitutions, and --- returns only those result graphs for which all query variables --- are bound. -rdfQuerySubs :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] -rdfQuerySubs vars gr = - map fst $ filter (null . snd) $ rdfQuerySubsAll vars gr - --- |Graph back-substitution function. --- Uses the supplied variable bindings from 'rdfQueryBack' to perform --- a series of variable substitutions in a supplied graph, returning --- a list of lists of result graphs corresponding to each set of variable --- bindings applied to the input graphs. --- --- The outer list of the result contains alternative antecedent lists --- that satisfy the query goal. Each inner list contains graphs that --- must all be inferred to satisfy the query goal. -rdfQueryBackSubs :: - [[RDFVarBinding]] -> RDFGraph -> [[(RDFGraph,[RDFLabel])]] -rdfQueryBackSubs varss gr = [ rdfQuerySubsAll v gr | v <- varss ] - --- |Graph substitution function. --- This function performs the substitutions and returns a list of --- result graphs each paired with a list unbound variables in each. -rdfQuerySubsAll :: [RDFVarBinding] -> RDFGraph -> [(RDFGraph,[RDFLabel])] -rdfQuerySubsAll vars gr = [ rdfQuerySubs2 v gr | v <- vars ] - --- |Graph substitution function. --- This function performs each of the substitutions in 'vars', and --- replaces any nodes corresponding to unbound query variables --- with new blank nodes. -rdfQuerySubsBlank :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] -rdfQuerySubsBlank vars gr = - [ remapLabels vs bs makeBlank g - | v <- vars - , let (g,vs) = rdfQuerySubs2 v gr - , let bs = allLabels isBlank g - ] - --- |Graph back-substitution function, replacing variables with bnodes. --- Uses the supplied variable bindings from 'rdfQueryBack' to perform --- a series of variable substitutions in a supplied graph, returning --- a list of lists of result graphs corresponding to each set of variable --- bindings applied to the input graphs. --- --- The outer list of the result contains alternative antecedent lists --- that satisfy the query goal. Each inner list contains graphs that --- must all be inferred to satisfy the query goal. -rdfQueryBackSubsBlank :: [[RDFVarBinding]] -> RDFGraph -> [[RDFGraph]] -rdfQueryBackSubsBlank varss gr = [ rdfQuerySubsBlank v gr | v <- varss ] - --- This function applies a substitution for a single set of variable --- bindings, returning the result and a list of unbound variables. --- It uses a state transformer monad to collect the list of --- unbound variables. --- --- Adding an empty graph forces elimination of duplicate arcs. -rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph,[RDFLabel]) -rdfQuerySubs2 varb gr = (add emptyRDFGraph g,vs) - where - (g,vs) = runState ( fmapM (mapNode varb) gr ) [] - --- Auxiliary monad function for rdfQuerySubs2. --- This returns a state transformer Monad which in turn returns the --- substituted node value based on the supplied query variable bindings. --- The monad state is a list of labels which accumulates all those --- variables seen for which no substitution was available. -mapNode :: RDFVarBinding -> RDFLabel -> State [RDFLabel] RDFLabel -mapNode varb lab = - case vbMap varb lab of - Just v -> return v - Nothing -> - if isQueryVar lab then - do { modify (addVar lab) - ; return lab - } - else - return lab - --- Add variable to list of variables, if not already there -addVar :: RDFLabel -> [RDFLabel] -> [RDFLabel] -addVar var vars = if var `elem` vars then vars else var:vars - ------------------------------------------------------------- --- Simple lightweight query primitives ------------------------------------------------------------- --- --- [[[TODO: modify above code to use these for all graph queries]]] - --- |rdfFindArcs is the main function here: it takes 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: --- --- (a) find all statements with given subject: --- rdfQuerySimple (rdfSubjEq s) --- (b) find all statements with given property: --- rdfQuerySimple (rdfPredEq p) --- (c) find all statements with given object: --- rdfQuerySimple (rdfObjEq o) --- (d) find all statements matching conjunction of these conditions: --- rdfQuerySimple (allp [...]) --- (e) find all statements matching disjunction of these conditions: --- rdfQuerySimple (anyp [...]) --- (See ListHelpers for allp, anyp.) --- --- Custom predicates can also be used. --- -rdfFindArcs :: (RDFTriple -> Bool) -> RDFGraph -> [RDFTriple] -rdfFindArcs p = filter p . getArcs - --- |Test if statement has given subject -rdfSubjEq :: RDFLabel -> RDFTriple -> Bool -rdfSubjEq s = (s==) . arcSubj - --- |Test if statement has given predicate -rdfPredEq :: RDFLabel -> RDFTriple -> Bool -rdfPredEq p = (p==) . arcPred - --- |Test if statement has given object -rdfObjEq :: RDFLabel -> RDFTriple -> Bool -rdfObjEq o = (o==) . arcObj - -{- --- |Find statements with given subject -rdfFindSubj :: RDFLabel -> RDFGraph -> [RDFTriple] -rdfFindSubj s = rdfFindArcs (rdfSubjEq s) - --- |Find statements with given predicate -rdfFindPred :: RDFLabel -> RDFGraph -> [RDFTriple] -rdfFindPred p = rdfFindArcs (rdfPredEq p) --} - --- |Find values of given predicate for a given subject -rdfFindPredVal :: RDFLabel -> RDFLabel -> 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 -> RDFLabel -> RDFGraph -> [Integer] -rdfFindPredInt s p = catMaybes . map getint . filter isint . pvs - where - pvs = rdfFindPredVal s p - isint = anyp - [ isDatatyped xsd_integer - , isDatatyped xsd_nonneg_integer - ] - getint = mapL2V mapXsdInteger . getLiteralText - --- |Find all subjects that have a of given value for for a given predicate -rdfFindValSubj :: RDFLabel -> RDFLabel -> 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 some arbitrary value is returned. --- -rdfFindList :: RDFGraph -> RDFLabel -> [RDFLabel] -rdfFindList gr hd = findhead $ rdfFindList gr findrest - where - findhead = headOr (const []) $ - map (:) (rdfFindPredVal hd res_rdf_first gr) - findrest = headOr res_rdf_nil (rdfFindPredVal hd res_rdf_rest gr) - {- - findhead = headOr (const []) - [ (ob:) | Arc _ sb ob <- subgr, sb == res_rdf_first ] - findrest = headOr res_rdf_nil - [ ob | Arc _ sb ob <- subgr, sb == res_rdf_rest ] - 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFQuery.hs,v $ --- $Author: graham $ --- $Revision: 1.32 $ --- $Log: RDFQuery.hs,v $ --- Revision 1.32 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.31 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.30 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.29 2003/11/14 16:04:43 graham --- Add primitive query to get integer values from a graph. --- --- Revision 1.28 2003/11/14 16:01:30 graham --- Separate RDFVarBinding from module RDFQuery. --- --- Revision 1.27 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.26 2003/10/16 16:01:48 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.25 2003/10/15 16:40:52 graham --- Reworked RDFQuery to use new query binding framework. --- (Note: still uses VarBindingFilter rather than VarBindingModify. --- The intent is to incorproate the VarBindingModify logic into RDFProof, --- displaying the existing use of BindingFilter.) --- --- Revision 1.24 2003/10/09 17:16:13 graham --- Added test cases to exercise features of rules used to capture --- RDF semantics. Also added proof test case using XML literal. --- --- Revision 1.23 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.22 2003/10/01 00:38:00 graham --- Correct error in previous commit. --- --- Revision 1.21 2003/10/01 00:36:25 graham --- Added RDFGraph method to test for container membership property label. --- Added RDFQuery filter function to select container membership properties. --- --- Revision 1.20 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.19 2003/09/30 16:39:41 graham --- Refactor proof code to use new ruleset logic. --- Moved some support code from RDFProofCheck to RDFRuleset. --- --- Revision 1.18 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.17 2003/07/03 20:31:07 graham --- Add initial draft of datatype framework. --- --- Revision 1.16 2003/07/02 22:39:36 graham --- Subgraph entailment and Graph closure instance entailment rules --- now tested. RDF forward chaining revised to combine output graphs, --- to preserve blank node relationships. --- --- Revision 1.15 2003/07/02 21:27:30 graham --- Graph closure with instance rule tested. --- About to change ProofTest for graph forward chaining to return --- a single result graph. --- --- Revision 1.14 2003/07/02 13:51:14 graham --- Intermediate save: partially coded RDFS rules. --- --- Revision 1.13 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.12 2003/06/26 15:37:23 graham --- Added rdfQueryInstance, and tests, all works. --- --- Revision 1.11 2003/06/25 09:52:25 graham --- Replaced Rule class with algebraic data type --- --- Revision 1.10 2003/06/19 19:49:07 graham --- RDFProofCheck compiles, but test fails --- --- Revision 1.9 2003/06/19 00:26:29 graham --- Query binding filter methods tested. --- --- Revision 1.8 2003/06/18 23:37:53 graham --- Added query binding filter methods. Not yet tested. --- --- Revision 1.7 2003/06/18 14:59:27 graham --- Augmented query variable binding structure. --- RDFQuery tests OK. --- --- Revision 1.6 2003/06/18 01:29:29 graham --- Fixed up some problems with backward chaining queries. --- Query test cases still to complete. --- Proof incomplete. --- --- Revision 1.5 2003/06/17 17:53:08 graham --- Added backward chaining query primitive. --- --- Revision 1.4 2003/06/17 16:29:20 graham --- Eliminate redundant Maybe in return type of rdfQueryPrim. --- (A null list suffices for the Nothing case.) --- --- Revision 1.3 2003/06/17 15:59:09 graham --- Update to use revised version of remapNodes, which accepts a --- node-mapping function rather than just a Boolean to control conversion --- of query variable nodes to blank --- nodes. --- --- Revision 1.2 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.1 2003/06/12 00:49:06 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- diff --git a/Swish/HaskellRDF/RDFQueryTest.hs b/Swish/HaskellRDF/RDFQueryTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFQueryTest.hs +++ /dev/null @@ -1,1711 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFQueryTest.hs,v 1.23 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFQueryTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + multi-parameter classes --- --- 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. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.RDFQueryTest where - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryFind, rdfQueryFilter - , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify - , rdfQueryInstance - , rdfQuerySubs, rdfQueryBackSubs - , rdfQuerySubsAll - , rdfQuerySubsBlank, rdfQueryBackSubsBlank - , rdfFindArcs, rdfSubjEq, rdfPredEq, rdfObjEq, rdfFindPredVal - , rdfFindValSubj, rdfFindPredVal, rdfFindPredInt, rdfFindList - -- debug - , rdfQuerySubs2 - ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingModify, RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.HaskellRDF.RDFGraph - ( Arc(..), arcSubj - , RDFGraph, RDFLabel(..) - , isLiteral, isBlank, isQueryVar, makeBlank - , setArcs, getArcs, addArc, add, delete, extract, labels, merge - , allLabels, remapLabels - , mapnode, maplist - , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..), nullVarBinding - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , vbmCompatibility, vbmCompose - , findCompositions, findComposition - , VarBindingFilter(..) - , makeVarFilterModify - , makeVarTestFilter, makeVarCompareFilter - , varBindingId, varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , makeNamespaceQName - , ScopedName(..) - , getQName - , makeScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceXSD - , namespaceLang, langName - , swishName - , rdf_type, rdf_XMLLiteral - , xsd_boolean, xsd_integer - ) - -import Swish.HaskellRDF.N3Parser - ( ParseResult(..), parseN3fromString ) - -import Swish.HaskellUtils.QName - ( QName(..) ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(Error,Result) ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - -import Data.Maybe - ( isJust, fromJust ) - ------------------------------------------------------------- --- misc helpers ------------------------------------------------------------- - -newtype Set a = Set [a] deriving Show -instance (Eq a) => Eq (Set a) where - Set v1 == Set v2 = v1 `equiv` v2 - -test :: String -> Bool -> Test -test lab tst = TestCase $ assertBool lab tst - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab e a = TestCase $ assertEqual lab e a - -testLs :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testLs lab e a = TestCase $ assertEqual lab (Set e) (Set a) - -testGr :: String -> String -> [RDFGraph] -> Test -testGr lab e a = TestCase $ assertBool lab (eg `elem` a) - where eg = graphFromString e - -graphFromString :: String -> RDFGraph -graphFromString str = case parseN3fromString str of - Result gr -> gr - Error msg -> error msg - --- Compare lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - ------------------------------------------------------------- --- test1: simple query qith URI, literal and blank nodes. ------------------------------------------------------------- - -prefix1 = - "@prefix ex: . \n" ++ - " \n" - -graph1 = graphFromString graph1str -graph1str = prefix1 ++ - "ex:s1 ex:p ex:o1 . \n" ++ - "ex:s2 ex:p \"lit1\" . \n" ++ - "[ ex:p ex:o3 ] . \n" - -query11 = graphFromString query11str -query11str = prefix1 ++ - "?s ex:p ?o . \n" - -result11 = graphFromString result11str -result11str = prefix1 ++ - "?s ex:r ?o . \n" - -result11a = prefix1 ++ - "ex:s1 ex:r ex:o1 . \n" - -result11b = prefix1 ++ - "ex:s2 ex:r \"lit1\" . \n" - -result11c = prefix1 ++ - "[ ex:r ex:o3 ] . \n" - -var11 = rdfQueryFind query11 graph1 -testQuery11 = test "testQuery11" (not $ null var11) -res11 = rdfQuerySubs var11 result11 -testResult11 = testEq "testResult11" 3 (length res11) -testResult11a = testGr "testResult11a" result11a res11 -testResult11b = testGr "testResult11b" result11b res11 -testResult11c = testGr "testResult11c" result11c res11 - -test1 = TestList - [ testQuery11, testResult11 - , testResult11a, testResult11b, testResult11c - ] - ------------------------------------------------------------- --- test2: a range of more complex queries based on a --- single relationship graph. ------------------------------------------------------------- - -prefix2 = - "@prefix pers: . \n" ++ - "@prefix rel: . \n" ++ - " \n" - -graph2 = graphFromString graph2str -graph2str = prefix2 ++ - "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 = graphFromString query21str -query21str = prefix2 ++ - "?a rel:wife ?b . \n" - -result21 = graphFromString result21str -result21str = prefix2 ++ - "?b rel:husband ?a . \n" - -result21a = prefix2 ++ - "pers:Do1 rel:husband pers:St1 . \n" - -result21b = prefix2 ++ - "pers:Ma2 rel:husband pers:Pa2 . \n" - -result21c = prefix2 ++ - "pers:Ri2 rel:husband pers:Br2 . \n" - -result21d = prefix2 ++ - "pers:Ma3 rel:husband pers:Gr3 . \n" - -result21e = prefix2 ++ - "pers:Jo3 rel:husband pers:Si3 . \n" - -result21f = prefix2 ++ - "pers:Su3 rel:husband pers:Al3 . \n" - -var21 = rdfQueryFind query21 graph2 -testQuery21 = test "testQuery21" (not $ null var21) -res21 = rdfQuerySubs var21 result21 -testResult21 = testEq "testResult21" 6 (length res21) -testResult21a = testGr "testResult21a" result21a res21 -testResult21b = testGr "testResult21b" result21b res21 -testResult21c = testGr "testResult21c" result21c res21 -testResult21d = testGr "testResult21d" result21d res21 -testResult21e = testGr "testResult21e" result21e res21 -testResult21f = testGr "testResult21f" result21f res21 - -query22 = graphFromString query22str -query22str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?b rel:son ?c . \n" - -result22 = graphFromString result22str -result22str = prefix2 ++ - "?a rel:grandparent ?c . \n" - -result22a = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Ro4 . \n" - -result22b = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Ol4 . \n" - -result22c = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Lo4 . \n" - -result22d = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Ha4 . \n" - -result22e = prefix2 ++ - "pers:Pa2 rel:grandparent pers:El4 . \n" - -var22 = rdfQueryFind query22 graph2 -testQuery22 = test "testQuery22" (not $ null var22) -res22 = rdfQuerySubs var22 result22 -testResult22 = testEq "testResult22" 5 (length res22) -testResult22a = testGr "testResult22a" result22a res22 -testResult22b = testGr "testResult22b" result22b res22 -testResult22c = testGr "testResult22c" result22c res22 -testResult22d = testGr "testResult22d" result22d res22 -testResult22e = testGr "testResult22e" result22e res22 - -query23 = graphFromString query23str -query23str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result23 = graphFromString result23str -result23str = prefix2 ++ - "?b rel:brother ?c . \n" - -result23a = prefix2 ++ - "pers:Gr3 rel:brother pers:Gr3 . \n" - -result23b = prefix2 ++ - "pers:Gr3 rel:brother pers:La3 . \n" - -result23c = prefix2 ++ - "pers:Gr3 rel:brother pers:Si3 . \n" - -result23d = prefix2 ++ - "pers:Gr3 rel:brother pers:Al3 . \n" - -result23e = prefix2 ++ - "pers:La3 rel:brother pers:Gr3 . \n" - -result23f = prefix2 ++ - "pers:La3 rel:brother pers:La3 . \n" - -result23g = prefix2 ++ - "pers:La3 rel:brother pers:Si3 . \n" - -result23h = prefix2 ++ - "pers:La3 rel:brother pers:Al3 . \n" - -result23i = prefix2 ++ - "pers:Si3 rel:brother pers:Gr3 . \n" - -result23j = prefix2 ++ - "pers:Si3 rel:brother pers:La3 . \n" - -result23k = prefix2 ++ - "pers:Si3 rel:brother pers:Si3 . \n" - -result23l = prefix2 ++ - "pers:Si3 rel:brother pers:Al3 . \n" - -result23m = prefix2 ++ - "pers:Al3 rel:brother pers:Gr3 . \n" - -result23n = prefix2 ++ - "pers:Al3 rel:brother pers:La3 . \n" - -result23o = prefix2 ++ - "pers:Al3 rel:brother pers:Si3 . \n" - -result23p = prefix2 ++ - "pers:Al3 rel:brother pers:Al3 . \n" - -result23q = prefix2 ++ - "pers:Wi3 rel:brother pers:Wi3 . \n" - -result23r = prefix2 ++ - "pers:Ro4 rel:brother pers:Ro4 . \n" - -result23s = prefix2 ++ - "pers:Ol4 rel:brother pers:Lo4 . \n" - -result23t = prefix2 ++ - "pers:Ol4 rel:brother pers:Ol4 . \n" - -result23u = prefix2 ++ - "pers:Lo4 rel:brother pers:Lo4 . \n" - -result23v = prefix2 ++ - "pers:Lo4 rel:brother pers:Ol4 . \n" - -result23w = prefix2 ++ - "pers:Ha4 rel:brother pers:El4 . \n" - -result23x = prefix2 ++ - "pers:Ha4 rel:brother pers:Ha4 . \n" - -result23y = prefix2 ++ - "pers:El4 rel:brother pers:El4 . \n" - -result23z = prefix2 ++ - "pers:El4 rel:brother pers:Ha4 . \n" - -var23 = rdfQueryFind query23 graph2 -testQuery23 = test "testQuery23" (not $ null var23) -res23 = rdfQuerySubs var23 result23 -testResult23 = testEq "testResult23" 26 (length res23) -testResult23a = testGr "testResult23a" result23a res23 -testResult23b = testGr "testResult23b" result23b res23 -testResult23c = testGr "testResult23c" result23c res23 -testResult23d = testGr "testResult23d" result23d res23 -testResult23e = testGr "testResult23e" result23e res23 -testResult23f = testGr "testResult23f" result23f res23 -testResult23g = testGr "testResult23g" result23g res23 -testResult23h = testGr "testResult23h" result23h res23 -testResult23i = testGr "testResult23i" result23i res23 -testResult23j = testGr "testResult23j" result23j res23 -testResult23k = testGr "testResult23k" result23k res23 -testResult23l = testGr "testResult23l" result23l res23 -testResult23m = testGr "testResult23m" result23m res23 -testResult23n = testGr "testResult23n" result23n res23 -testResult23o = testGr "testResult23o" result23o res23 -testResult23p = testGr "testResult23p" result23p res23 -testResult23q = testGr "testResult23q" result23q res23 -testResult23r = testGr "testResult23r" result23r res23 -testResult23s = testGr "testResult23s" result23s res23 -testResult23t = testGr "testResult23t" result23t res23 -testResult23u = testGr "testResult23u" result23u res23 -testResult23v = testGr "testResult23v" result23v res23 -testResult23w = testGr "testResult23w" result23w res23 -testResult23x = testGr "testResult23x" result23x res23 -testResult23y = testGr "testResult23y" result23y res23 -testResult23z = testGr "testResult23z" result23z res23 - --- apply filtering to result: -filter23 = varFilterNE (Var "b") (Var "c") :: RDFVarBindingFilter -var23F = rdfQueryFilter filter23 var23 -res23F = rdfQuerySubs var23F result23 -testResult23F = testEq "testResult23" 16 (length res23F) -testResult23bF = testGr "testResult23b" result23b res23F -testResult23cF = testGr "testResult23c" result23c res23F -testResult23dF = testGr "testResult23d" result23d res23F -testResult23eF = testGr "testResult23e" result23e res23F -testResult23gF = testGr "testResult23g" result23g res23F -testResult23hF = testGr "testResult23h" result23h res23F -testResult23iF = testGr "testResult23i" result23i res23F -testResult23jF = testGr "testResult23j" result23j res23F -testResult23lF = testGr "testResult23l" result23l res23F -testResult23mF = testGr "testResult23m" result23m res23F -testResult23nF = testGr "testResult23n" result23n res23F -testResult23oF = testGr "testResult23o" result23o res23F -testResult23sF = testGr "testResult23s" result23s res23F -testResult23vF = testGr "testResult23v" result23v res23F -testResult23wF = testGr "testResult23w" result23w res23F -testResult23zF = testGr "testResult23z" result23z res23F - - -query24 = graphFromString query24str -query24str = prefix2 ++ - "?a rel:daughter ?b . \n" ++ - "?a rel:daughter ?c . \n" - -result24 = graphFromString result24str -result24str = prefix2 ++ - "?b rel:sister ?c . \n" - -result24a = prefix2 ++ - "pers:Ma2 rel:sister pers:Ma2 . \n" - -result24b = prefix2 ++ - "pers:Ma2 rel:sister pers:An2 . \n" - -result24c = prefix2 ++ - "pers:An2 rel:sister pers:Ma2 . \n" - -result24d = prefix2 ++ - "pers:An2 rel:sister pers:An2 . \n" - -result24e = prefix2 ++ - "pers:Ma3 rel:sister pers:Ma3 . \n" - -result24f = prefix2 ++ - "pers:Rh4 rel:sister pers:Rh4 . \n" - -var24 = rdfQueryFind query24 graph2 -testQuery24 = test "testQuery24" (not $ null var24) -res24 = rdfQuerySubs var24 result24 -testResult24 = testEq "testResult24" 6 (length res24) -testResult24a = testGr "testResult24a" result24a res24 -testResult24b = testGr "testResult24b" result24b res24 -testResult24c = testGr "testResult24c" result24c res24 -testResult24d = testGr "testResult24d" result24d res24 -testResult24e = testGr "testResult24e" result24e res24 -testResult24f = testGr "testResult24f" result24f res24 - - -query25 = graphFromString query25str -query25str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?a rel:daughter ?c . \n" - -result25 = graphFromString result25str -result25str = prefix2 ++ - "?b rel:sister ?c . \n" ++ - "?c rel:brother ?b . \n" - -result25a = prefix2 ++ - "pers:Wi3 rel:sister pers:Ma3 . \n" ++ - "pers:Ma3 rel:brother pers:Wi3 . \n" - -result25b = prefix2 ++ - "pers:Ro4 rel:sister pers:Rh4 . \n" ++ - "pers:Rh4 rel:brother pers:Ro4 . \n" - -var25 = rdfQueryFind query25 graph2 -testQuery25 = test "testQuery25" (not $ null var25) -res25 = rdfQuerySubs var25 result25 -testResult25 = testEq "testResult25" 2 (length res25) -testResult25a = testGr "testResult25a" result25a res25 -testResult25b = testGr "testResult25b" result25b res25 - -test2 = TestList - [ testQuery21, testResult21 - , testResult21a, testResult21b, testResult21c - , testResult21d, testResult21e, testResult21f - , testQuery22, testResult22 - , testResult22a, testResult22b, testResult22c - , testResult22d, testResult22e - , testQuery23, testResult23 - , testResult23a, testResult23b, testResult23c - , testResult23d, testResult23e, testResult23f - , testResult23g, testResult23h, testResult23i - , testResult23j, testResult23k, testResult23l - , testResult23m, testResult23n, testResult23o - , testResult23p, testResult23q, testResult23r - , testResult23s, testResult23t, testResult23u - , testResult23v, testResult23w, testResult23x - , testResult23y, testResult23z - , testResult23F - , testResult23bF, testResult23cF - , testResult23dF, testResult23eF - , testResult23gF, testResult23hF, testResult23iF - , testResult23jF, testResult23lF - , testResult23mF, testResult23nF, testResult23oF - , testResult23sF - , testResult23vF, testResult23wF - , testResult23zF - , testQuery24, testResult24 - , testResult24a, testResult24b, testResult24c - , testResult24d, testResult24e, testResult24f - ] - ------------------------------------------------------------- --- test handling of unsubstituted variables, and --- rdfQuerySubsAll, rdfQuerySubsBlank ------------------------------------------------------------- - -graph3 = graphFromString graph3str -graph3str = prefix2 ++ - "pers:Pa2 rel:grandparent pers:Ro4 . \n" ++ - "pers:Pa2 rel:grandparent pers:Ol4 . \n" - -query31 = graphFromString query31str -query31str = prefix2 ++ - "?a rel:grandparent ?c . \n" - -result31 = graphFromString result31str -result31str = prefix2 ++ - "?a rel:son ?b . \n" ++ - "?b rel:son ?c . \n" - -result31a = prefix2 ++ - "pers:Pa2 rel:son ?b . \n" ++ - "?b rel:son pers:Ro4 . \n" - -result31b = prefix2 ++ - "pers:Pa2 rel:son ?b . \n" ++ - "?b rel:son pers:Ol4 . \n" - -var31 = rdfQueryFind query31 graph3 -testQuery31 = test "testQuery31" (not $ null var31) -res31pairs = rdfQuerySubsAll var31 result31 -(res31,res31v) = unzip res31pairs -testUnsubs31 = testEq "testUnsubs31" 2 (length res31v) -testUnsubs31a = testEq "testUnsubs31a" [(Var "b")] (head res31v) -testUnsubs31b = testEq "testUnsubs31a" [(Var "b")] (head . tail $ res31v) -testResult31 = testEq "testResult31" 2 (length res31) -testResult31a = testGr "testResult31a" result31a res31 -testResult31b = testGr "testResult31b" result31b res31 - -query32 = graphFromString query32str -query32str = prefix2 ++ - "?a rel:grandparent ?c . \n" - -result32 = graphFromString result32str -result32str = prefix2 ++ - "?a rel:wife _:b . \n" ++ - "?d rel:any _:b0 . \n" ++ - "?a rel:son ?b . \n" ++ - "?b rel:son ?c . \n" - -result32a = 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 = 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 = rdfQuerySubsBlank var31 result32 -testResult32 = testEq "testResult32" 2 (length res32) -testResult32a = testGr "testResult32a" result32a res32 -testResult32b = testGr "testResult32b" result32b res32 - -res33 = rdfQuerySubs var31 result32 -testResult33 = testEq "testResult33" 0 (length res33) - -test3 = TestList - [ testQuery31 - , testUnsubs31, testUnsubs31a, testUnsubs31b - , testResult31, testResult31a, testResult31b - , testResult32, testResult32a, testResult32b - , testResult33 - ] - --- 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 = - "@prefix pers: . \n" ++ - "@prefix rel: . \n" ++ - " \n" - -graph41 = graphFromString graph41str -graph41str = prefix4 ++ - "pers:St1 rel:wife pers:Do1 . \n" - -query41 = graphFromString query41str -query41str = prefix4 ++ - "?a rel:wife ?b . \n" - -result41 = graphFromString result41str -result41str = prefix4 ++ - "?b rel:husband ?a . \n" - -result41a = prefix4 ++ - "pers:Do1 rel:husband pers:St1 . \n" - -var41 = rdfQueryBack query41 graph41 -testQuery41 = test "testQuery41" (not $ null var41) -testQuery41a = testEq "testQuery41a" 1 (length var41) -res41 = rdfQueryBackSubs var41 result41 -testResult41 = testEq "testResult41" 1 (length res41) -testResult41a = testGr "testResult41a" result41a (fst $ unzip $ head res41) -testUnbound41a = testLs "testUnbound41a" [] (snd $ head $ head res41) - -graph42 = graphFromString graph42str -graph42str = prefix4 ++ - "pers:Pa2 rel:grandparent pers:Ro4 . \n" - -query42 = graphFromString query42str -query42str = prefix4 ++ - "?a rel:grandparent ?c . \n" - -result42 = graphFromString result42str -result42str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?b rel:son ?c . \n" - -result42a = prefix4 ++ - "pers:Pa2 rel:son ?b . \n" ++ - "?b rel:son pers:Ro4 . \n" - -var42 = rdfQueryBack query42 graph42 -testQuery42 = test "testQuery42" (not $ null var42) -testQuery42a = testEq "testQuery42a" 1 (length var42) -res42 = rdfQueryBackSubs var42 result42 -testResult42 = testEq "testResult42" 1 (length res42) -testResult42a = testGr "testResult42a" result42a (fst $ unzip $ head res42) -testUnbound42a = testLs "testUnbound42a" [(Var "b")] (snd $ head $ head res42) - - -graph43 = graphFromString graph43str -graph43str = prefix4 ++ - "pers:Gr3 rel:brother pers:La3 . \n" - -query43 = graphFromString query43str -query43str = prefix4 ++ - "?b rel:brother ?c . \n" - -result43 = graphFromString result43str -result43str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result43a = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:son pers:La3 . \n" - -var43 = rdfQueryBack query43 graph43 -testQuery43 = test "testQuery43" (not $ null var43) -testQuery43a = testEq "testQuery43a" 1 (length var43) -res43 = rdfQueryBackSubs var43 result43 -testResult43 = testEq "testResult43" 1 (length res43) -testResult43a = testGr "testResult43a" result43a (fst $ unzip $ head res43) -testUnbound43a = testLs "testUnbound43a" [(Var "a")] (snd $ head $ head res43) - - -graph44 = graphFromString graph44str -graph44str = prefix4 ++ - "pers:Pa2 rel:grandson pers:Ro4 . \n" - -query44 = graphFromString query44str -query44str = prefix4 ++ - "?a rel:grandson ?b . \n" ++ - "?c rel:grandson ?d . \n" - -result44 = graphFromString result44str -result44str = prefix4 ++ - "?a rel:son ?m . \n" ++ - "?m rel:son ?b . \n" ++ - "?c rel:daughter ?n . \n" ++ - "?n rel:son ?d . \n" - -result44a = prefix4 ++ - "pers:Pa2 rel:son ?m . \n" ++ - "?m rel:son pers:Ro4 . \n" ++ - "?c rel:daughter ?n . \n" ++ - "?n rel:son ?d . \n" -unbound44a = [(Var "m"),(Var "c"),(Var "n"),(Var "d")] - -result44b = prefix4 ++ - "?a rel:son ?m . \n" ++ - "?m rel:son ?b . \n" ++ - "pers:Pa2 rel:daughter ?n . \n" ++ - "?n rel:son pers:Ro4 . \n" -unbound44b = [(Var "a"),(Var "m"),(Var "b"),(Var "n")] - -var44 = rdfQueryBack query44 graph44 -testQuery44 = test "testQuery44" (not $ null var44) -testQuery44a = testEq "testQuery44a" 2 (length var44) -res44 = rdfQueryBackSubs var44 result44 -testResult44 = testEq "testResult44" 2 (length res44) -[res44_1,res44_2] = res44 -testResult44a = testGr "testResult44a" result44a (fst $ unzip res44_2) -testUnbound44a = testLs "testUnbound44a" unbound44a (snd $ head res44_2) -testResult44b = testGr "testResult44b" result44b (fst $ unzip res44_1) -testUnbound44b = testLs "testUnbound44b" unbound44b (snd $ head res44_1) - --- 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 = graphFromString graph45str -graph45str = prefix4 ++ - "pers:Rh4 rel:brother pers:Ro4 . \n" ++ - "pers:Ma3 rel:brother pers:Wi3 . \n" - -query45 = graphFromString query45str -query45str = prefix4 ++ - "?b rel:brother ?c . \n" - -result45 = graphFromString result45str -result45str = prefix4 ++ - "?a rel:daughter ?b . \n" ++ - "?a rel:son ?c . \n" - -result45a1 = prefix4 ++ - "?a rel:daughter pers:Rh4 . \n" ++ - "?a rel:son pers:Ro4 . \n" -unbound45a1 = [(Var "a")] - -result45a2 = prefix4 ++ - "?a rel:daughter pers:Ma3 . \n" ++ - "?a rel:son pers:Wi3 . \n" -unbound45a2 = [(Var "a")] - -var45 = rdfQueryBack query45 graph45 -testQuery45 = test "testQuery45" (not $ null var45) -testQuery45a = testEq "testQuery45a" 1 (length var45) -res45 = rdfQueryBackSubs var45 result45 -testResult45 = testEq "testResult45" 1 (length res45) -[res45_1] = res45 -testResult45_1 = testEq "testResult45_1" 2 (length res45_1) -[res45_11,res45_12] = res45_1 -testResult45a1 = testGr "testResult45a1" result45a1 [fst res45_11] -testUnbound45a1 = testLs "testUnbound45a1" unbound45a1 (snd res45_11) -testResult45a2 = testGr "testResult45a2" result45a2 [fst res45_12] -testUnbound45a2 = testLs "testUnbound45a2" unbound45a2 (snd res45_12) - --- 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 = graphFromString graph46str -graph46str = prefix4 ++ - "pers:Gr3 rel:stepbrother pers:St3 . \n" - -query46 = graphFromString query46str -query46str = prefix4 ++ - "?b rel:stepbrother ?c . \n" ++ - "?c rel:stepbrother ?b . \n" - -result46 = graphFromString result46str -result46str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:stepson ?c . \n" - -result46a = prefix4 ++ - "?a rel:son pers:St3 . \n" ++ - "?a rel:stepson pers:Gr3 . \n" -unbound46a = [(Var "a")] - -result46b = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:stepson pers:St3 . \n" -unbound46b = [(Var "a")] - -var46 = rdfQueryBack query46 graph46 -testQuery46 = test "testQuery46" (not $ null var46) -testQuery46a = testEq "testQuery46a" 2 (length var46) -res46 = rdfQueryBackSubs var46 result46 -testResult46 = testEq "testResult46" 2 (length res46) -[res46_1,res46_2] = res46 -testResult46_1 = testEq "testResult46_1" 1 (length res46_1) -testResult46_2 = testEq "testResult46_2" 1 (length res46_2) -[res46_11] = res46_1 -[res46_21] = res46_2 -testResult46a = testGr "testResult46a" result46a [fst res46_11] -testUnbound46a = testLs "testUnbound46a" unbound46a (snd res46_11) -testResult46b = testGr "testResult46b" result46b [fst res46_21] -testUnbound46b = testLs "testUnbound46b" unbound46b (snd res46_21) - - --- 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 = graphFromString graph47str -graph47str = prefix4 ++ - "pers:Gr3 rel:stepbrother pers:St3 . \n" ++ - "pers:St3 rel:stepbrother pers:Gr3 . \n" - -query47 = graphFromString query47str -query47str = prefix4 ++ - "?b rel:stepbrother ?c . \n" ++ - "?c rel:stepbrother ?b . \n" - -result47 = graphFromString result47str -result47str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:stepson ?c . \n" - -result47a1 = prefix4 ++ - "?a rel:son pers:St3 . \n" ++ - "?a rel:stepson pers:Gr3 . \n" -unbound47a1 = [(Var "a")] - -result47a2 = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:stepson pers:St3 . \n" -unbound47a2 = [(Var "a")] - -result47b1 = prefix4 ++ - "?a rel:stepson pers:St3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound47b1 = [(Var "a")] - -result47b2 = prefix4 ++ - "?a rel:stepson pers:St3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound47b2 = [(Var "a")] - -result47c1 = prefix4 ++ - "?a rel:son pers:St3 . \n" ++ - "?a rel:stepson pers:Gr3 . \n" -unbound47c1 = [(Var "a")] - -result47c2 = prefix4 ++ - "?a rel:son pers:St3 . \n" ++ - "?a rel:stepson pers:Gr3 . \n" -unbound47c2 = [(Var "a")] - -result47d1 = prefix4 ++ - "?a rel:stepson pers:St3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound47d1 = [(Var "a")] - -result47d2 = prefix4 ++ - "?a rel:son pers:St3 . \n" ++ - "?a rel:stepson pers:Gr3 . \n" -unbound47d2 = [(Var "a")] - -var47 = rdfQueryBack query47 graph47 -testQuery47 = test "testQuery47" (not $ null var47) -testQuery47a = testEq "testQuery47a" 4 (length var47) -res47 = rdfQueryBackSubs var47 result47 -testResult47 = testEq "testResult47" 4 (length res47) -[res47_1,res47_2,res47_3,res47_4] = res47 -testResult47_1 = testEq "testResult47_1" 2 (length res47_1) -testResult47_2 = testEq "testResult47_2" 2 (length res47_2) -testResult47_3 = testEq "testResult47_3" 2 (length res47_3) -testResult47_4 = testEq "testResult47_4" 2 (length res47_4) -[res47_11,res47_12] = res47_1 -[res47_21,res47_22] = res47_2 -[res47_31,res47_32] = res47_3 -[res47_41,res47_42] = res47_4 -testResult47a1 = testGr "testResult47a1" result47a1 [fst res47_11] -testUnbound47a1 = testLs "testUnbound47a1" unbound47a1 (snd res47_11) -testResult47a2 = testGr "testResult47a2" result47a2 [fst res47_12] -testUnbound47a2 = testLs "testUnbound47a2" unbound47a2 (snd res47_12) -testResult47b1 = testGr "testResult47b1" result47b1 [fst res47_21] -testUnbound47b1 = testLs "testUnbound47b1" unbound47b1 (snd res47_21) -testResult47b2 = testGr "testResult47b2" result47b2 [fst res47_22] -testUnbound47b2 = testLs "testUnbound47b2" unbound47b2 (snd res47_22) -testResult47c1 = testGr "testResult47c1" result47c1 [fst res47_31] -testUnbound47c1 = testLs "testUnbound47c1" unbound47c1 (snd res47_31) -testResult47c2 = testGr "testResult47c2" result47c2 [fst res47_32] -testUnbound47c2 = testLs "testUnbound47c2" unbound47c2 (snd res47_32) -testResult47d1 = testGr "testResult47d1" result47d1 [fst res47_41] -testUnbound47d1 = testLs "testUnbound47d1" unbound47d1 (snd res47_41) -testResult47d2 = testGr "testResult47d2" result47d2 [fst res47_42] -testUnbound47d2 = testLs "testUnbound47d2" unbound47d2 (snd res47_42) - - --- 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 = graphFromString graph48str -graph48str = prefix4 ++ - "pers:Gr3 rel:brother pers:La3 . \n" - -query48 = graphFromString query48str -query48str = prefix4 ++ - "?b rel:brother ?c . \n" ++ - "?c rel:brother ?b . \n" - -result48 = graphFromString result48str -result48str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result48a = prefix4 ++ - "?a rel:son pers:La3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound48a = [(Var "a")] - -result48b = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:son pers:La3 . \n" -unbound48b = [(Var "a")] - -var48 = rdfQueryBack query48 graph48 -testQuery48 = test "testQuery48" (not $ null var48) -testQuery48a = testEq "testQuery48a" 2 (length var48) -res48 = rdfQueryBackSubs var48 result48 -testResult48 = testEq "testResult48" 2 (length res48) -[res48_1,res48_2] = res48 -testResult48_1 = testEq "testResult48_1" 1 (length res48_1) -testResult48_2 = testEq "testResult48_2" 1 (length res48_2) -[res48_11] = res48_1 -[res48_21] = res48_2 -testResult48a = testGr "testResult48a" result48a [fst res48_11] -testUnbound48a = testLs "testUnbound48a" unbound48a (snd res48_11) -testResult48b = testGr "testResult48b" result48b [fst res48_21] -testUnbound48b = testLs "testUnbound48b" unbound48b (snd res48_21) - - --- test49: goal not satisfiable by rule --- --- (?a foo ?b, ?b foo ?a) => (?a bar ?a) --- --- (a bar b) cannot be deduced directly - -graph49 = graphFromString graph49str -graph49str = prefix4 ++ - "pers:Gr3 rel:foo pers:La3 . \n" - -query49 = graphFromString query49str -query49str = prefix4 ++ - "?a rel:bar ?a . \n" - -result49 = graphFromString result49str -result49str = prefix4 ++ - "?a rel:foo ?b . \n" ++ - "?b rel:foo ?a . \n" - -var49 = rdfQueryBack query49 graph49 -testQuery49 = test "testQuery49" (null var49) -testQuery49a = testEq "testQuery49a" 0 (length var49) -res49 = rdfQueryBackSubs var49 result49 -testResult49 = testEq "testResult49" 0 (length res49) - --- 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 = graphFromString graph50str -graph50str = prefix4 ++ - "pers:Gr3 rel:brother pers:Gr3 . \n" - -query50 = graphFromString query50str -query50str = prefix4 ++ - "?b rel:brother ?c . \n" ++ - "?c rel:brother ?b . \n" - -result50 = graphFromString result50str -result50str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result50a = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound50a = [(Var "a")] - -result50b = prefix4 ++ - "?a rel:son pers:Gr3 . \n" ++ - "?a rel:son pers:Gr3 . \n" -unbound50b = [(Var "a")] - -var50 = rdfQueryBack query50 graph50 -testQuery50 = test "testQuery50" (not $ null var50) -testQuery50a = testEq "testQuery50a" 2 (length var50) -res50 = rdfQueryBackSubs var50 result50 -testResult50 = testEq "testResult50" 2 (length res50) -[res50_1,res50_2] = res50 -testResult50_1 = testEq "testResult50_1" 1 (length res50_1) -testResult50_2 = testEq "testResult50_2" 1 (length res50_2) -[res50_11] = res50_1 -[res50_21] = res50_2 -testResult50a = testGr "testResult50a" result50a [fst res50_11] -testUnbound50a = testLs "testUnbound50a" unbound50a (snd res50_11) -testResult50b = testGr "testResult50b" result50b [fst res50_21] -testUnbound50b = testLs "testUnbound50b" unbound50b (snd res50_21) - -filter50 = varFilterNE (Var "b") (Var "c") :: RDFVarBindingFilter -var50F = rdfQueryBackFilter filter50 var50 -res50F = rdfQueryBackSubs var50F result50 -testResult50F = testEq "testResult50F" 0 (length res50F) - - --- Backward substitution query test suite - -test4 = TestList - [ testQuery41, testQuery41a, testResult41 - , testResult41a, testUnbound41a - , testQuery42, testQuery42a, testResult42 - , testResult42a, testUnbound42a - , testQuery43, testQuery43a, testResult43 - , testResult43a, testUnbound43a - , testQuery44, testQuery44a, testResult44 - , testResult44a, testUnbound44a - , testResult44b, testUnbound44b - , testQuery45, testQuery45a, testResult45 - , testResult45_1 - , testResult45a1, testUnbound45a1 - , testResult45a2, testUnbound45a2 - , testQuery46, testQuery46a, testResult46 - , testResult46_1, testResult46_2 - , testResult46a, testUnbound46a - , testResult46b, testUnbound46b - , testQuery47, testQuery47a, testResult47 - , testResult47_1, testResult47_2, testResult47_3, testResult47_4 - , testResult47a1, testUnbound47a1 - , testResult47a2, testUnbound47a2 - , testResult47b1, testUnbound47b1 - , testResult47b2, testUnbound47b2 - , testResult47c1, testUnbound47c1 - , testResult47c2, testUnbound47c2 - , testResult47d1, testUnbound47d1 - , testResult47d2, testUnbound47d2 - , testQuery48, testQuery48a, testResult48 - , testResult48_1, testResult48_2 - , testResult48a, testUnbound48a - , testResult48b, testUnbound48b - , testQuery49, testQuery49a, testResult49 - , testQuery50, testQuery50a, testResult50 - , testResult50_1, testResult50_2 - , testResult50a, testUnbound50a - , testResult50b, testUnbound50b - , testResult50F - ] - ------------------------------------------------------------- --- 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 = graphFromString graph61str -graph61str = prefix4 ++ - "pers:Gr3 rel:brother pers:La3 . \n" ++ - "pers:Gr3 rel:brother pers:Si3 . \n" - -query61 = graphFromString query61str -query61str = prefix4 ++ - "?b rel:brother ?c . \n" - -result61 = graphFromString result61str -result61str = prefix4 ++ - "?a rel:son ?b . \n" ++ - "?a rel:son ?c . \n" - -result61a = prefix4 ++ - "_: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 = prefix4 ++ - "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 = rdfQueryBack query61 graph61 -testQuery61 = test "testQuery61" (not $ null var61) -testQuery61a = testEq "testQuery61a" 1 (length var61) -res61 = rdfQueryBackSubsBlank var61 result61 -testResult61 = testEq "testResult61" 1 (length res61) -[[res61a1,res61a2]] = res61 -res61a = merge res61a1 res61a2 -testResult61a = testGr "testResult61a" result61a [res61a] --- 2. Instance query against 'graph2' -var62 = rdfQueryInstance res61a graph2 -testQuery62 = test "testQuery62" (not $ null var62) -testQuery62a = testEq "testQuery62a" 1 (length var62) --- 3. Substitute into instance query graph -res63 = rdfQuerySubs var62 res61a -testQuery63 = test "testQuery63" (not $ null res63) -testQuery63a = testEq "testQuery63a" 1 (length res63) -[res63a] = res63 -testResult63a = testGr "testResult63a" result63a [res63a] --- 4. Repeat instance query against 'graph2' --- Query bindings should be null. -var64 = rdfQueryInstance res63a graph2 -testQuery64 = test "testQuery64" (not $ null var64) -testQuery64a = testEq "testQuery64a" 1 (length var64) -[var64a] = var64 -testQuery64b = test "testQuery64b" (null $ vbEnum var64a) - -test6 = TestList - [ testQuery61, testQuery61a, testResult61, testResult61a - , testQuery62, testQuery62a - , testQuery63, testQuery63a, testResult63a - , testQuery64, testQuery64a, testQuery64b - ] - ------------------------------------------------------------- --- 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 --} - -baseex = "http://example.org/" -baserdf = nsURI namespaceRDF -q_dattyp = (makeScopedName "" baseex "datatype") - -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 = Res (makeScopedName "" baseex "s") -u_o = Res (makeScopedName "" baseex "o") -u_p = Res (makeScopedName "" baseex "p") -u_p1 = Res (makeScopedName "" baseex "p1") -u_p2a = Res (makeScopedName "" baseex "p2a") -u_p2b = Res (makeScopedName "" baseex "p2b") -u_m1 = Res (makeScopedName "" baserdf "_1") -u_m2 = Res (makeScopedName "" baserdf "_2") -u_rt = Res rdf_type -u_xt = Res rdf_XMLLiteral -u_dt = Res q_dattyp -l_1 = Lit "l1" Nothing -l_2 = Lit "l2" (Just $ langName "fr") -l_3 = Lit "l3" (Just q_dattyp) -l_4 = Lit "l4" (Just q_dattyp) -- was: (Lang "fr") -l_5 = Lit "l5" (Just rdf_XMLLiteral) -b_1 = Blank "1" -b_2 = Blank "2" -b_3 = Blank "3" -b_l1 = Blank "l1" -b_l2 = Blank "l2" - -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 = [ 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 - ] - -testBackMod01 = testEq "testBackMod01" vbss01 $ - rdfQueryBackModify varBindingId vbss01 - -testBackMod02 = testEq "testBackMod02" [vbss01a,vbss01b,vbss01c,vbss01d] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingUriRef v_a) - vbss01 - -testBackMod03 = testEq "testBackMod03" [vbss01f,vbss01i] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingBlank v_a) - vbss01 - -testBackMod04 = testEq "testBackMod04" vbss01 $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingUriRef v_b) - vbss01 - -testBackMod05 = testEq "testBackMod05" - [vbss01c,vbss01d,vbss01e,vbss01f,vbss01h,vbss01i] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingLiteral v_c) - vbss01 - -testBackMod06 = testEq "testBackMod06" [vbss01d] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingUntypedLiteral v_c) - vbss01 - -testBackMod07 = testEq "testBackMod07" [vbss01e,vbss01f,vbss01h,vbss01i] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingTypedLiteral v_c) - vbss01 - -testBackMod08 = testEq "testBackMod08" [vbss01f] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingXMLLiteral v_c) - vbss01 - -testBackMod09 = testEq "testBackMod09" [vbss01g] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingMemberProp v_b) - vbss01 - -testBackMod10 = testEq "testBackMod10" [vbss01h] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingDatatyped v_x v_c) - vbss01 - -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 = [ vbss02a - , vbss02b - , vbss02c - , vbss02d - ] - -testBackMod20 = testEq "testBackMod20" vbss02 $ - rdfQueryBackModify varBindingId vbss02 - -testBackMod21 = testEq "testBackMod21" [vbss02d] $ - rdfQueryBackModify - (makeVarFilterModify $ rdfVarBindingUriRef v_a) - vbss02 - --- Variable binding modifier that adds new bindings, if certain --- others are present. -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 = 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) ] - ] - ] - -testBackMod22 = testEq "testBackMod22" vbss02dy $ - rdfQueryBackModify vbm22 vbss02 - - --- simplified version of above for debugging -- - -vbss03a = [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] - , makeVarBinding [ (v_b,b_l1) ] - ] - -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 = [ vbss03a - , vbss03b - ] - -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) ] - ] - ] - -testBackMod30 = testEq "testBackMod30" vbss03by $ - rdfQueryBackModify vbm22 vbss03 - -test7 = TestList - [ testBackMod01, testBackMod02, testBackMod03, testBackMod04 - , testBackMod05, testBackMod06, testBackMod07, testBackMod08 - , testBackMod09, testBackMod10 - , testBackMod20, testBackMod21, testBackMod22 - , testBackMod30 - ] - ------------------------------------------------------------- --- Test simple value and list queries ------------------------------------------------------------- - -namespacetest = - Namespace "test" "urn:test:" -namespacelist = - Namespace "list" "urn:list:" - -qntest loc = ScopedName namespacetest loc -qnlist loc = ScopedName namespacelist loc - -prefixlist = - "@prefix rdf : <" ++ nsURI namespaceRDF ++ "> . \n" ++ - "@prefix xsd : <" ++ nsURI namespaceXSD ++ "> . \n" ++ - "@prefix test : <" ++ nsURI namespacetest ++ "> . \n" ++ - "@prefix list : <" ++ nsURI namespacelist ++ "> . \n" ++ - " \n" - -graphlist = graphFromString 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_rdf_type 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 = TestList - [ test1 - , test2 - , test3 - , test4 - , test6 - , test7 - , test8 - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - -shres32 = TestCase $ assertString (show res32) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFQueryTest.hs,v $ --- $Author: graham $ --- $Revision: 1.23 $ --- $Log: RDFQueryTest.hs,v $ --- Revision 1.23 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.22 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.21 2003/12/20 12:53:40 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.20 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.19 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.18 2003/11/24 15:46:03 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.17 2003/11/14 16:04:43 graham --- Add primitive query to get integer values from a graph. --- --- Revision 1.16 2003/11/14 16:01:30 graham --- Separate RDFVarBinding from module RDFQuery. --- --- Revision 1.15 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.14 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.13 2003/10/15 16:40:52 graham --- Reworked RDFQuery to use new query binding framework. --- (Note: still uses VarBindingFilter rather than VarBindingModify. --- The intent is to incorproate the VarBindingModify logic into RDFProof, --- displaying the existing use of BindingFilter.) --- --- Revision 1.12 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.11 2003/07/02 22:39:36 graham --- Subgraph entailment and Graph closure instance entailment rules --- now tested. RDF forward chaining revised to combine output graphs, --- to preserve blank node relationships. --- --- Revision 1.10 2003/06/26 15:37:23 graham --- Added rdfQueryInstance, and tests, all works. --- --- Revision 1.9 2003/06/19 00:26:29 graham --- Query binding filter methods tested. --- --- Revision 1.8 2003/06/18 14:59:27 graham --- Augmented query variable binding structure. --- RDFQuery tests OK. --- --- Revision 1.7 2003/06/18 13:47:33 graham --- Backchaining query tests complete. --- --- Revision 1.6 2003/06/18 01:29:29 graham --- Fixed up some problems with backward chaining queries. --- Query test cases still to complete. --- Proof incomplete. --- --- Revision 1.5 2003/06/17 17:53:08 graham --- Added backward chaining query primitive. --- --- Revision 1.4 2003/06/17 16:29:20 graham --- Eliminate redundant Maybe in return type of rdfQueryPrim. --- (A null list suffices for the Nothing case.) --- --- Revision 1.3 2003/06/17 15:59:09 graham --- Update to use revised version of remapNodes, which accepts a --- node-mapping function rather than just a Boolean to control conversion --- of query variable nodes to blank --- nodes. --- --- Revision 1.2 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.1 2003/06/12 00:49:06 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- diff --git a/Swish/HaskellRDF/RDFRuleset.hs b/Swish/HaskellRDF/RDFRuleset.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFRuleset.hs +++ /dev/null @@ -1,621 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFRuleset.hs,v 1.20 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFRuleset --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines some datatypes and functions that are --- used to define rules and rulesets over RDF graphs --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleMap - , RDFClosure, RDFRuleset, RDFRulesetMap - , nullRDFFormula - , GraphClosure(..), makeGraphClosureRule - , makeRDFGraphFromN3String - , makeRDFFormula - , makeRDFClosureRule - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeN3ClosureModifyRule - , makeN3ClosureAllocatorRule - , makeNodeAllocTo - -- for debugging - , graphClosureFwdApply, graphClosureBwdApply - ) -where - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryFind - , rdfQueryBack, rdfQueryBackModify - , rdfQuerySubs - , rdfQuerySubsBlank - ) - -import Swish.HaskellRDF.RDFGraph - ( Label (..), RDFLabel(..), RDFGraph - , makeBlank, newNodes - , merge, allLabels - , toRDFGraph, emptyRDFGraph ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding, RDFVarBindingModify ) - -import Swish.HaskellRDF.N3Parser - ( parseN3fromString ) - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..), RulesetMap - ) - -import Swish.HaskellRDF.Rule - ( Formula(..), Rule(..), RuleMap - , fwdCheckInference - , nullScope - ) - -import Swish.HaskellRDF.VarBinding - ( makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , vbmCompose - , varBindingId - ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) ) - -import Swish.HaskellRDF.Vocabulary - ( swishName ) - -{- -import Swish.HaskellRDF.Proof - ( Proof(..), Step(..) ) --} - -import Swish.HaskellRDF.GraphClass - ( Label(..), Arc(..), LDGraph(..) ) - -import Swish.HaskellUtils.ListHelpers - ( equiv, flist ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(..) ) - -import Data.List - ( nub ) - - ------------------------------------------------------------- --- Datatypes for RDF ruleset ------------------------------------------------------------- - -type RDFFormula = Formula RDFGraph - -type RDFRule = Rule RDFGraph - -type RDFRuleMap = RuleMap RDFGraph - -type RDFClosure = GraphClosure RDFLabel - -type RDFRuleset = Ruleset RDFGraph - -type RDFRulesetMap = RulesetMap RDFGraph - ------------------------------------------------------------- --- Declare null RDF formula ------------------------------------------------------------- - -nullRDFFormula :: Formula RDFGraph -nullRDFFormula = Formula - { formName = ScopedName nullScope "nullRDFGraph" - , formExpr = emptyRDFGraph - } - ------------------------------------------------------------- --- Datatype for graph closure rule ------------------------------------------------------------- - --- |Datatype for constructing a graph closure rule -data GraphClosure lb = GraphClosure - { nameGraphRule :: ScopedName -- ^ Name of rule for proof display - , ruleAnt :: [Arc lb] -- ^ Antecedent triples pattern - -- (may include variable nodes) - , ruleCon :: [Arc lb] -- ^ Consequent triples pattern - -- (may include variable nodes) - , ruleModify :: VarBindingModify lb lb - -- ^ Structure that defines additional - -- constraints and/or variable - -- bindings based on other matched - -- query variables. Matching the - -- antecedents. Use 'varBindingId' if - -- no additional variable constraints - -- or bindings are added beyond those - -- arising from graph queries. - } - -instance (Label lb) => Eq (GraphClosure lb) where - c1 == c2 = (nameGraphRule c1 == nameGraphRule c2) && - (ruleAnt c1) `equiv` (ruleAnt c2) && - (ruleCon c1) `equiv` (ruleCon c2) - -instance (Label lb) => Show (GraphClosure lb) where - show c = "GraphClosure "++show (nameGraphRule c) - ------------------------------------------------------------- --- Define inference rule based on RDF graph closure rule ------------------------------------------------------------- - --- |Define a value of type Rule based on an RDFClosure value. -makeGraphClosureRule :: GraphClosure RDFLabel -> Rule RDFGraph -makeGraphClosureRule grc = newrule - where - newrule = Rule - { ruleName = nameGraphRule grc - , fwdApply = graphClosureFwdApply grc - , bwdApply = graphClosureBwdApply grc - , checkInference = fwdCheckInference newrule - } - --- Forward chaining function based on RDF graph closure description --- --- Note: antecedents here are presumed to share bnodes. --- -graphClosureFwdApply :: GraphClosure RDFLabel -> [RDFGraph] -> [RDFGraph] -graphClosureFwdApply grc grs = - let gr = if null grs then emptyRDFGraph else foldl1 add grs - vars = queryFind (ruleAnt grc) gr - varm = vbmApply (ruleModify grc) vars - cons = querySubs varm (ruleCon grc) - in - {- - seq cons $ - seq (trace "\ngraphClosureFwdApply") $ - seq (traceShow "\nvars: " vars) $ - seq (traceShow "\nvarm: " varm) $ - seq (traceShow "\ncons: " cons) $ - seq (trace "\n") $ - -} - -- Return null list or single result graph that is the union - -- (not merge) of individual results: - if null cons then [] else [foldl1 add cons] - -- cons {- don't merge results -} - --- Backward chaining function based on RDF graph closure description -graphClosureBwdApply :: GraphClosure RDFLabel -> RDFGraph -> [[RDFGraph]] -graphClosureBwdApply grc gr = - let vars = rdfQueryBackModify (ruleModify grc) $ - queryBack (ruleCon grc) gr - -- This next function eliminates duplicate variable bindings. - -- It is strictly redundant, but comparing variable - -- bindings is much cheaper than comparing graphs. - -- I don't know if many duplicate graphs will be result - -- of exact duplicate variable bindings, so this may be - -- not very effective. - varn = map nub vars - in - -- The 'nub ante' below eliminates duplicate antecedent graphs, - -- based on graph matching, which tests for equivalence under - -- bnode renaming, with a view to reducing redundant arcs in - -- the merged antecedent graph, hence less to prove in - -- subsequent back-chaining steps. - -- - -- Each antecedent is reduced to a single RDF graph, when - -- bwdApply specifies a list of expressions corresponding to - -- each antecedent. - [ [foldl1 merge (nub ante)] - | vs <- varn - , let ante = querySubsBlank vs (ruleAnt grc) ] - ------------------------------------------------------------- --- RDF graph query and substitution support functions ------------------------------------------------------------- - -queryFind :: [Arc RDFLabel] -> RDFGraph -> [RDFVarBinding] -queryFind qas tg = rdfQueryFind (toRDFGraph qas) tg - -queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] -queryBack qas tg = rdfQueryBack (toRDFGraph qas) tg - -querySubs :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] -querySubs vars qas = - {- - seq (trace "\nquerySubs") $ - seq (traceShow "\nvars: " vars) - seq (traceShow "\narcs: " qas) - seq (trace "\n") $ - -} - rdfQuerySubs vars (toRDFGraph qas) - -querySubsBlank :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] -querySubsBlank vars qas = rdfQuerySubsBlank vars (toRDFGraph qas) - ------------------------------------------------------------- --- Method for creating an RDF formula value from N3 text ------------------------------------------------------------- - --- |Helper function to parse a string containing Notation3 --- and return the corresponding RDFGraph value. -makeRDFGraphFromN3String :: String -> RDFGraph -makeRDFGraphFromN3String str = case parseN3fromString str of - Error msg -> error msg - Result gr -> gr - --- |Create an RDF formula given: --- a namespace, a local name and a Notation 3 string that --- is parsed to yield an RDF graph value. -makeRDFFormula :: - Namespace -> String -> String -> RDFFormula -makeRDFFormula scope local gr = Formula - { formName = ScopedName scope local - , formExpr = makeRDFGraphFromN3String 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. --- --- sname is a scoped name for the new rule. --- antgrs is a list of 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?]]]) --- congr is an RDFGraph containing that is the consequent graph. --- vmod 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' --- -makeRDFClosureRule :: - ScopedName -> [RDFGraph] -> RDFGraph -> RDFVarBindingModify - -> RDFRule -makeRDFClosureRule sname antgrs congr vmod = makeGraphClosureRule - GraphClosure - { nameGraphRule = sname - , ruleAnt = concatMap getArcs antgrs - , ruleCon = getArcs congr - , ruleModify = vmod - } - ------------------------------------------------------------- --- Methods to create an RDF closure rule from N3 input ------------------------------------------------------------- --- --- These functions are used internally by Swish to construct --- rules from textual descriptions. - --- |Constructs an RDF graph closure rule. That is, a rule that --- given some set of antecedent statements returns new statements --- that may be added to the graph. This is the basis for --- implementation of most of the inference rules given in the --- RDF formal semantics document. --- --- scope is a namespace to which the rule is allocated --- local is a local name for the rule in the given namespace --- ant is a string containing the Notation3 representation --- of the antecedent graph. (Note: multiple antecedents --- can be handled by combining multiple graphs.) --- con is a string containing the Notation3 representation --- of the consequent graph. --- vmod 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' --- -makeN3ClosureRule :: - Namespace -> String - -> String -> String -> RDFVarBindingModify - -> RDFRule -makeN3ClosureRule scope local ant con vmod = - makeRDFClosureRule (ScopedName scope local) [antgr] congr vmod - where - antgr = makeRDFGraphFromN3String ant - congr = makeRDFGraphFromN3String con - --- |Construct a simple RDF graph closure rule without --- additional node allocations or variable binding constraints. --- -makeN3ClosureSimpleRule :: - Namespace -> String -> String -> String -> 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. --- --- scope is a namespace to which the rule is allocated --- local is a local name for the rule in the given namespace --- ant is a string containing the Notation3 representation --- of the antecedent graph. (Note: multiple antecedents --- can be handled by combining multiple graphs.) --- con is a string containing the Notation3 representation --- of the consequent graph. --- vflt is a variable binding modifier value that may impose --- additional conditions on the variable bindings that --- can be used for this inference rule. --- 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. --- vmod is a variable binding modifier that is applied to the --- variable bindings obtained, typically to create some --- additional variable bindings. This is applied before --- the filter rule 'vflt'. --- -makeN3ClosureModifyRule :: - Namespace -> String - -> String -> String -> RDFVarBindingModify -> RDFVarBindingModify - -> RDFRule -makeN3ClosureModifyRule scope local ant con vflt vmod = - makeN3ClosureRule scope local ant con modc - where - modc = case vbmCompose vmod vflt of - Just x -> x - Nothing -> varBindingId -{- - 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. --- --- scope is a namespace tom which the rule is allocated --- local is a local name for the rule in the given namespace --- ant is a string containing the Notation3 representation --- of the antecedent graph. (Note: multiple antecedents --- can be handled by combining multiple graphs.) --- con is a string containing the Notation3 representation --- of the consequent graph. --- vflt is a variable binding modifier value that may impose --- additional conditions on the variable bindings that --- can be used for this inference rule. --- aloc is a 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 (above). This allows any node allocation --- function to avoid allocating any blank nodes that --- are already used in the antecedent graph. --- (See function makeNodeAllocTo). --- -makeN3ClosureAllocatorRule :: - Namespace -> String - -> String -> String - -> RDFVarBindingModify -> ( [RDFLabel] -> RDFVarBindingModify ) - -> RDFRule -makeN3ClosureAllocatorRule scope local ant con vflt aloc = - makeRDFClosureRule (ScopedName scope local) [antgr] congr modc - where - antgr = makeRDFGraphFromN3String ant - congr = makeRDFGraphFromN3String con - vmod = aloc (allLabels labelIsVar antgr) - modc = case vbmCompose vmod vflt of - Just x -> x - Nothing -> varBindingId - - ------------------------------------------------------------- --- Query binding modifier for "allocated to" logic ------------------------------------------------------------- - --- |This function defines a variable binding mofifier 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. --- --- 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. --- -makeNodeAllocTo :: - RDFLabel -> RDFLabel - -> [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 vbind = applyVarBinding vbind - 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFRuleset.hs,v $ --- $Author: graham $ --- $Revision: 1.20 $ --- $Log: RDFRuleset.hs,v $ --- Revision 1.20 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. --- --- Revision 1.19 2003/12/20 12:53:40 graham --- Fix up code to compile and test with GHC 5.04.3 --- --- Revision 1.18 2003/12/20 12:00:14 graham --- Introduced new TraceHelpers module for Hugs-2003 compatibility. --- --- Revision 1.17 2003/12/19 21:01:25 graham --- Change Debug.Trace import (from Hugs.Trace) --- --- Revision 1.16 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.15 2003/12/16 07:05:37 graham --- Working on updated RDFProofContext --- --- Revision 1.14 2003/12/11 19:10:29 graham --- Forward chaining now adds antecedent graphs rather than merging them, --- so that --- bnodes carried over from the original input are not separated. --- Future developments should provide controlled scoping for bnodes, --- to avoid --- errors this may cause. --- --- Revision 1.13 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.12 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.11 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.10 2003/11/25 23:02:17 graham --- Reworked datatype variable modifier logic. --- Limited range of test cases so far all pass. --- --- Revision 1.9 2003/11/14 21:48:35 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.8 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.7 2003/11/06 17:58:33 graham --- About to rework Datatype to better support class-based reasoning. --- --- Revision 1.6 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.5 2003/10/09 17:16:13 graham --- Added test cases to exercise features of rules used to capture --- RDF semantics. Also added proof test case using XML literal. --- --- Revision 1.4 2003/10/09 13:58:59 graham --- Sync with CVS. Preparing to eliminate QueryBindingFilter in favour --- of using just QueryBindingModifier. --- --- Revision 1.3 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.2 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.1 2003/09/30 16:38:19 graham --- Add Ruleset and RDFRuleset modules to provide proof context elements --- diff --git a/Swish/HaskellRDF/RDFRulesetTest.hs b/Swish/HaskellRDF/RDFRulesetTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFRulesetTest.hs +++ /dev/null @@ -1,470 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFRulesetTest.hs,v 1.12 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFRulesetTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for ruleset data. --- --- Note that the proof-related methods defined in RDFRuleset are tested --- by RDFProofTest and/or RDFProofCheck. --- -{--------+---------+---------+---------+---------+---------+---------+---------} - --- WNH RIP OUTmodule Swish.HaskellRDF.RDFRulesetTest where - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFClosure, RDFRuleset - , nullRDFFormula - , GraphClosure(..), makeGraphClosureRule - , makeRDFGraphFromN3String - , makeRDFFormula - , makeN3ClosureAllocatorRule - , makeN3ClosureRule - , makeN3ClosureSimpleRule - , makeNodeAllocTo - -- for debugging - , graphClosureFwdApply, graphClosureBwdApply - ) - -import Swish.HaskellRDF.RDFQuery - ( rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding - , RDFVarBindingModify - , RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) - -import Swish.HaskellRDF.RDFGraph - ( Label (..), RDFLabel(..), RDFGraph - , setArcs, getArcs, addArc, add, delete, extract, labels, merge - , allLabels, allNodes, remapLabels, remapLabelList - , toRDFGraph, emptyRDFGraph - , Label (..), Arc(..), arc, arcSubj, arcPred, arcObj, Selector - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..), nullVarBinding - , makeVarBinding - , vbmCompatibility, vbmCompose - , makeVarFilterModify - ) - -import Swish.HaskellRDF.Ruleset - ( Ruleset(..) - , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules - , getRulesetAxiom, getRulesetRule - , getContextAxiom, getContextRule, getMaybeContextRule ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) - , fwdCheckInference - , showsFormula, showsFormulae, showsWidth ) - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - , makeScopedName - ) - -import Swish.HaskellRDF.Vocabulary - ( namespaceRDF - , namespaceRDFO - , namespaceOWL - , scopeRDF - ) - -import Swish.HaskellUtils.QName - ( QName(..) ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Data.List - ( nub, sort ) - -import Data.Maybe - ( isJust, fromJust ) - ------------------------------------------------------------- --- Test case helpers ------------------------------------------------------------- - -test :: String -> Bool -> Test -test lab bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testVal :: (Eq a, Show a) => String -> a -> a -> Test -testVal lab a1 a2 = - TestCase ( assertEqual ("testVal:"++lab) a1 a2 ) - -testEq :: (Eq a, Show a) => String -> Bool -> a -> a -> Test -testEq lab eq a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) eq (a1==a2) ) - -testEqual :: (Eq a, Show a) => String -> a -> a -> Test -testEqual lab a1 a2 = - TestCase ( assertEqual ("testEq:"++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) ) - -testStringEq :: String -> String -> String -> Test -testStringEq lab s1 s2 = - TestCase ( assertEqual ("testStringEq:"++lab) s1 s2 ) - -testSameNamespace :: String -> Namespace -> Namespace -> Test -testSameNamespace lab n1 n2 = - TestCase ( assertBool ("testSameNamespace:"++lab) ((p1==p2)&&(u1==u2)) ) - where - p1 = nsPrefix n1 - p2 = nsPrefix n2 - u1 = nsURI n1 - u2 = nsURI n2 - -testScopedNameEq :: String -> Bool -> ScopedName -> ScopedName -> Test -testScopedNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testScopedNameEq:"++lab) eq (n1==n2) ) - -{- -testQNameEq :: String -> Bool -> QName -> QName -> Test -testQNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testQNameEq:"++lab) eq (n1==n2) ) --} - -testSameAxioms :: String -> [RDFFormula] -> [RDFFormula] -> Test -testSameAxioms lab as1 as2 = - TestCase ( assertBool ("testSameAxioms:"++lab) sameas ) - where - sameas = (sort as1) == (sort as2) - -testSameRules :: String -> [RDFRule] -> [RDFRule] -> Test -testSameRules lab rs1 rs2 = - TestCase ( assertBool ("testSameRules:"++lab) samers ) - where - samers = (sort rs1) == (sort rs2) - ------------------------------------------------------------- --- Common values ------------------------------------------------------------- - -pref_rdf = nsURI namespaceRDF -pref_op = nsURI namespaceRDFO -pref_owl = nsURI namespaceOWL - ------------------------------------------------------------- --- 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 "r1" "http://id.ninebynine.org/wip/2003/rulesettest/r1" - --- Common prefix declarations for graph expressions -pref = - "@prefix rdf: . \n" ++ - "@prefix rdfs: . \n" ++ - "@prefix ex: . \n" ++ - " \n" - -a11 = makeRDFFormula rn1 "a11" (pref++"ex:R1 rdf:type ex:C1 .") -a12 = makeRDFFormula rn1 "a12" (pref++"ex:R2 rdf:type ex:C2 .") - -r11 = makeN3ClosureSimpleRule rn1 "r11" - ( pref++"?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) - ( pref++"?r1 ex:P1 ?r2 ." ) - -r12 = makeN3ClosureSimpleRule rn1 "r12" - ( pref++"?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) - ( pref++"?r2 ex:P2 ?r1 ." ) - --- Basic formula and rule comparison tests --- (tests support code added in module Proof.hs) - -testCmpAX01 = testEq "testCmpAX01" True a11 a11 -testCmpAX02 = testEq "testCmpAX02" False a11 a12 -testCmpAX03 = testLe "testCmpAX03" True a11 a11 -testCmpAX04 = testLe "testCmpAX04" True a11 a12 -testCmpAX05 = testLe "testCmpAX05" False a12 a11 - -testFormulaSuite = TestList - [ testCmpAX01, testCmpAX02, testCmpAX03, testCmpAX04, testCmpAX05 - ] - -testCmpRU01 = testEq "testCmpRU01" True r11 r11 -testCmpRU02 = testEq "testCmpRU02" False r11 r12 -testCmpRU03 = testLe "testCmpRU03" True r11 r11 -testCmpRU04 = testLe "testCmpRU04" True r11 r12 -testCmpRU05 = testLe "testCmpRU05" False r12 r11 - -testRuleSuite = TestList - [ testCmpRU01, testCmpRU02, testCmpRU03, testCmpRU04, testCmpRU05 - ] - --- Test simple ruleset construction and access - -a1s = [ a11, a12 ] - -r1s = [ r11, r12 ] - -r1 = makeRuleset rn1 a1s r1s - -testNS01 = testSameNamespace "testNS01" rn1 (getRulesetNamespace r1) -testAX01 = testSameAxioms "testAX01" a1s (getRulesetAxioms r1) -testRU01 = testSameRules "testRU01" r1s (getRulesetRules r1) - -testGeta11 = testEqual "testGeta11" (Just a11) $ - getRulesetAxiom (ScopedName rn1 "a11") r1 -testGeta12 = testEqual "testGeta11" (Just a12) $ - getRulesetAxiom (ScopedName rn1 "a12") r1 -testGetr11 = testEqual "testGetr11" (Just r11) $ - getRulesetRule (ScopedName rn1 "r11") r1 -testGetr12 = testEqual "testGetr12" (Just r12) $ - getRulesetRule (ScopedName rn1 "r12") r1 -testGetnone = testEqual "testGetnone" Nothing $ - getRulesetRule (ScopedName rn1 "none") r1 - -testRulesetSuite = TestList - [ testNS01, testAX01, testRU01 - , testGeta11, testGeta12 - , testGetr11, testGetr12 - , testGetnone - ] - ------------------------------------------------------------- --- Component tests for RDF proof context ------------------------------------------------------------- - -prefix = - "@prefix rdf: . \n" ++ - "@prefix rdfs: . \n" ++ - "@prefix ex: . \n" ++ - " \n" - -scopeex = Namespace "ex" "http://id.ninebynine.org/wip/2003/RDFProofCheck#" - -makeFormula :: Namespace -> String -> String -> RDFFormula -makeFormula scope local gr = - makeRDFFormula scope local (prefix++gr) - -allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify -allocateTo bv av = makeNodeAllocTo (vn bv) (vn av) - where - vn ('?':n) = Var n - -isXMLLit ('?':x) = rdfVarBindingXMLLiteral (Var x) - -queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] -queryBack qas tg = rdfQueryBack (toRDFGraph qas) tg - --- Backward chaining rdf:r2 - -rdfr2ant = makeRDFGraphFromN3String "?x ?a ?l . " -rdfr2con = makeRDFGraphFromN3String "?x ?a ?b . ?b rdf:type rdf:XMLLiteral ." -rdfr2modv = (allocateTo "?b" "?l") (allLabels labelIsVar rdfr2ant) -rdfr2modc = vbmCompose (makeVarFilterModify $ isXMLLit "?l") rdfr2modv - -testRDF01 = test "testRDF01" $ isJust rdfr2modc - -rdfr2grc = GraphClosure - { nameGraphRule = ScopedName scopeRDF "r2" - , ruleAnt = getArcs rdfr2ant - , ruleCon = getArcs rdfr2con - , ruleModify = fromJust rdfr2modc - } - -rdfr2rul = Rule - { ruleName = nameGraphRule rdfr2grc - , fwdApply = graphClosureFwdApply rdfr2grc - , bwdApply = graphClosureBwdApply rdfr2grc - , checkInference = fwdCheckInference rdfr2rul - } - -con03 = formExpr $ makeFormula scopeex "con03" $ - "ex:s ex:p1 _:l1 ; ex:p2a _:l2; ex:p2b _:l2 ." ++ - "_:l1 rdf:type rdf:XMLLiteral ." ++ - "_:l2 rdf:type rdf:XMLLiteral ." - -v_a = Var "a" -v_b = Var "b" -v_x = Var "x" -u_s = Res (makeScopedName "" "http://example.org/" "s") -u_p1 = Res (makeScopedName "" "http://example.org/" "p1") -u_p2a = Res (makeScopedName "" "http://example.org/" "p2a") -u_p2b = Res (makeScopedName "" "http://example.org/" "p2b") -u_rt = Res (makeScopedName "" pref_rdf "type") -u_rx = Res (makeScopedName "" pref_rdf "XMLLiteral") -b_l1 = Blank "l1" -b_l2 = Blank "l2" - -rdfr2v1 = queryBack (ruleCon rdfr2grc) con03 -rdfr2b1 = [ [ 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) ] - ] - , [ 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_rx) ] - , makeVarBinding [ (v_b,b_l2) ] - ] - , [ 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_rx) ] - ] - , [ 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_rx) ] - , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] - ] - ] - -rdfr2v2 = rdfQueryBackModify (ruleModify rdfr2grc) rdfr2v1 -rdfr2v3 = map nub rdfr2v2 - -testRDF02 = testVal "testRDF02" rdfr2b1 rdfr2v1 -testRDF03 = testVal "testRDF03" [] rdfr2v2 -testRDF04 = testVal "testRDF04" [] rdfr2v3 - -testRDF09 = testEq "testRDF09" True [] $ bwdApply rdfr2rul con03 - -testRDFSuite = TestList - [ testRDF01, testRDF02, testRDF03, testRDF04 - , testRDF09 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testFormulaSuite - , testRuleSuite - , testRulesetSuite - , testRDFSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFRulesetTest.hs,v $ --- $Author: graham $ --- $Revision: 1.12 $ --- $Log: RDFRulesetTest.hs,v $ --- Revision 1.12 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.11 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.10 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.9 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.8 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.7 2003/11/24 15:46:04 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.6 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.5 2003/10/22 16:18:37 graham --- Move common namespace definitions into Namespace module --- (May later move these into separate modules.) --- --- Revision 1.4 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.3 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.2 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.1 2003/09/30 16:38:19 graham --- Add Ruleset and RDFRuleset modules to provide proof context elements --- diff --git a/Swish/HaskellRDF/RDFVarBinding.hs b/Swish/HaskellRDF/RDFVarBinding.hs deleted file mode 100644 --- a/Swish/HaskellRDF/RDFVarBinding.hs +++ /dev/null @@ -1,211 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: RDFVarBinding.hs,v 1.4 2003/12/18 18:27:47 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : RDFVarBinding --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module instantiates the VarBinding types and methods for use --- with RDF graph labels. --- --- See module RDFQueryTest for test cases. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.RDFVarBinding - ( RDFVarBinding, nullRDFVarBinding - , RDFVarBindingModify, RDFOpenVarBindingModify, RDFOpenVarBindingModifyMap - , RDFVarBindingFilter - , rdfVarBindingUriRef, rdfVarBindingBlank - , rdfVarBindingLiteral - , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral - , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped - , rdfVarBindingMemberProp - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFLabel(..) - , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral - , isDatatyped, isMemberProp, isUri, isBlank, isQueryVar - ) - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..), nullVarBinding - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..), OpenVarBindingModify - , vbmCompatibility, vbmCompose - , findCompositions, findComposition - , VarBindingFilter(..) - , makeVarFilterModify - , makeVarTestFilter, makeVarCompareFilter - , varBindingId, varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE - ) - -import Swish.HaskellRDF.Vocabulary - ( swishName ) - -import Swish.HaskellUtils.LookupMap - ( LookupMap(..) ) - ------------------------------------------------------------- --- Types for RDF query variable bindings and modifiers ------------------------------------------------------------- - --- |RDFVarBinding is the specific type type of a variable --- binding value used with RDF graph queries, returned by --- 'RDFVarBindingFind' and used by 'RDFVarBindingSubs' -type RDFVarBinding = VarBinding RDFLabel RDFLabel - --- |nullRDFVarBinding: 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 --- --- RDFOpenVarBindingModify = [RDFLabel] -> RDFVarBindingModify --- -type RDFOpenVarBindingModify = OpenVarBindingModify RDFLabel RDFLabel - --- |Define type for lookup map of open query binding modifiers -type RDFOpenVarBindingModifyMap = LookupMap RDFOpenVarBindingModify - --- |RDFVarBindingFilter is a function type that tests to see if --- a query binding satisfies some criterion, and is used to --- create a variable binding modifier that simply filers --- given variable bindings. --- --- Queries often want to apply some kind of filter or condition --- to the variable bindings that are processed. In inference rules, --- it sometimes seems desirable to stipulate additional conditions on --- the things that are matched. --- --- This function type is used to perform such tests. --- A number of simple implementations are included below. --- -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 --- --- dvar a variable bound to the required datatype. --- lvar a variable bound to the literal node to be tested. --- -rdfVarBindingDatatyped :: RDFLabel -> RDFLabel -> 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) - dqnam = case dtype of { (Res dqnam) -> dqnam } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/RDFVarBinding.hs,v $ --- $Author: graham $ --- $Revision: 1.4 $ --- $Log: RDFVarBinding.hs,v $ --- Revision 1.4 2003/12/18 18:27:47 graham --- Datatyped literal inferences all working --- (except equivalent literals with different datatypes) --- --- Revision 1.3 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.2 2003/12/08 17:29:19 graham --- Moved OpenVarBinding type definitions from -Datatype to -VarBinding modules. --- --- Revision 1.1 2003/11/14 16:01:30 graham --- Separate RDFVarBinding from module RDFQuery. --- diff --git a/Swish/HaskellRDF/Rule.hs b/Swish/HaskellRDF/Rule.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Rule.hs +++ /dev/null @@ -1,265 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- --- $Id: Rule.hs,v 1.8 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Rule --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- 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.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..), RuleMap - , nullScope, nullFormula, nullRule - , fwdCheckInference, bwdCheckInference - , showsFormula, showsFormulae, showsWidth - ) -where - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - ) - -import Swish.HaskellUtils.ShowM - ( ShowM(..), showm ) - -import Swish.HaskellUtils.ListHelpers - ( subset ) - -{- in Prelude???? -import List - ( union, intersect ) - -import Maybe - ( isJust, fromJust ) --} - ------------------------------------------------------------- --- Expressions ------------------------------------------------------------- - --- |Expression is a type class for values over which proofs --- may be constructed. -class (Eq ex) => Expression ex where - -- |Is expression true in all interpretations? - -- If so, then its truth is assumed without justification. - isValid :: ex -> Bool - ------------------------------------------------------------- --- Formula: a named expression ------------------------------------------------------------- - --- |A Formula is a named expression. -data Formula ex = Formula - { formName :: ScopedName -- ^ Name used for formula in proof chain - , formExpr :: ex -- ^ Named formula value - } deriving Show - --- |Define equality of formulae as equality of formula names -instance Eq (Formula ex) where - f1 == f2 = formName f1 == formName f2 - --- |Define ordering of formulae based on formula names -instance Ord (Formula ex) where - f1 <= f2 = formName f1 <= formName f2 - -instance LookupEntryClass (Formula ex) ScopedName (Formula ex) - where - newEntry (_,form) = form - keyVal form = (formName form, form) - -nullScope :: Namespace -nullScope = Namespace "null" "http://id.ninebynine.org/2003/Ruleset/null" - -nullFormula :: Formula ex -nullFormula = Formula - { formName = ScopedName nullScope "nullFormula" - , formExpr = error "Null formula" - } - --- testf1 = Formula "f1" ('f',1) --- testf2 = Formula "f2" ('f',2) - --- |showsFormulae --- Return a displayable form of a list of labelled formulae -showsFormulae :: (ShowM ex) => String -> [Formula ex] -> String -> 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 - --- |showsFormula --- Create a displayable form of a labelled formula -showsFormula :: (ShowM ex) => String -> Formula ex -> ShowS -showsFormula newline f = - showsWidth 16 ("["++show (formName f)++"] ") . - showms (newline++(replicate 16 ' ')) (formExpr f) - ------------------------------------------------------------- --- Rule ------------------------------------------------------------- - --- |Rule is a data type for inference rules that can be used --- to construct a step in a proof. -data Rule ex = Rule - -- |Name of rule, for use when displaying a proof - { ruleName :: ScopedName - -- |Forward application of a rule, takes a list of - -- expressions and returns a list (possibly empty) - -- of forward applications of the rule to combinations - -- of the antecedent expressions. - -- Note that all of the results returned can be assumed to - -- be (simultaneously) true, given the antecedents provided. - , fwdApply :: [ex] -> [ex] - -- |Backward application of a rule, takes an expression - -- and returns a list of alternative antecedents, each of - -- which is a list of expressions that jointly yield the - -- given consequence through application of the inference - -- rule. An empty list is returned if no antecedents - -- will allow the consequence to be inferred. - , bwdApply :: ex -> [[ex]] - -- |Inference check. Takes a list of antecedent expressions - -- and a consequent expression, returning True if the - -- consequence can be obtained from the antecedents by - -- application of the rule. When the antecedents and - -- consequent are both given, this is generally more efficient - -- that using either forward or backward chaining. - -- Also, a particular rule may not fully support either - -- forward or backward chaining, but all rules are required - -- to fully support this function. - -- - -- A default implementation based on forward chaining is - -- given below. - , checkInference :: [ex] -> ex -> Bool - } - --- |Define equality of rules as equality of rule names -instance Eq (Rule ex) where - r1 == r2 = ruleName r1 == ruleName r2 - --- |Define ordering of rules based on rule names -instance Ord (Rule ex) where - r1 <= r2 = ruleName r1 <= ruleName r2 - -instance Show (Rule ex) where - show rl = "Rule "++show (ruleName rl) - -instance LookupEntryClass (Rule ex) ScopedName (Rule ex) - where - newEntry (_,rule) = rule - keyVal rule = (ruleName rule, rule) - -type RuleMap ex = LookupMap (Rule ex) - -fwdCheckInference :: (Eq ex) => Rule ex -> [ex] -> ex -> Bool -fwdCheckInference rule ante cons = - (cons `elem` fwdApply rule ante) - -bwdCheckInference :: (Eq ex) => Rule ex -> [ex] -> ex -> Bool -bwdCheckInference rule ante cons = any checkAnts (bwdApply rule cons) - where - checkAnts = all (`elem` ante) - -nullRule :: Rule ex -nullRule = Rule - { ruleName = ScopedName nullScope "nullRule" - , fwdApply = \ _ -> [] - , bwdApply = \ _ -> [] - , checkInference = \ _ _ -> False - } - ------------------------------------------------------------- --- Shows formatting support functions ------------------------------------------------------------ - --- |Show a string left justified in a field of at least the specified --- number of characters width. -showsWidth :: Int -> String -> ShowS -showsWidth wid str more = str++replicate pad ' '++more - where - pad = wid - length str - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Rule.hs,v $ --- $Author: graham $ --- $Revision: 1.8 $ --- $Log: Rule.hs,v $ --- Revision 1.8 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.7 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.6 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.5 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.4 2003/11/06 17:58:33 graham --- About to rework Datatype to better support class-based reasoning. --- --- Revision 1.3 2003/10/24 21:05:09 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.2 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.1 2003/09/30 20:00:46 graham --- Add module Rule as common dependency for Proof and Ruleset --- diff --git a/Swish/HaskellRDF/Ruleset.hs b/Swish/HaskellRDF/Ruleset.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Ruleset.hs +++ /dev/null @@ -1,190 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- $Id: Ruleset.hs,v 1.9 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Ruleset --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- 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.HaskellRDF.Ruleset - ( Ruleset(..), RulesetMap - , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules - , getRulesetAxiom, getRulesetRule - , getContextAxiom, getMaybeContextAxiom - , getContextRule, getMaybeContextRule - ) -where - -import Swish.HaskellUtils.Namespace - ( Namespace(..) - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - , matchName ) - -import Swish.HaskellRDF.Rule - ( Expression(..), Formula(..), Rule(..) - , fwdCheckInference - , showsFormula, showsFormulae, showsWidth - ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , mapFindMaybe - ) - -import Data.Maybe - ( Maybe(..), isJust, fromJust, fromMaybe, listToMaybe, mapMaybe ) - ------------------------------------------------------------- --- Ruleset, having namespace, axioms and rules ------------------------------------------------------------- - -data Ruleset ex = Ruleset - { rsNamespace :: Namespace - , rsAxioms :: [Formula ex] - , rsRules :: [Rule ex] - } - -instance Eq (Ruleset ex) where - r1 == r2 = rsNamespace r1 == rsNamespace r2 - -instance LookupEntryClass (Ruleset ex) Namespace (Ruleset ex) - where - keyVal r@(Ruleset k _ _) = (k,r) - newEntry (_,r) = r - -type RulesetMap ex = LookupMap (Ruleset ex) - -makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex -makeRuleset nsp fms rls = Ruleset - { rsNamespace = nsp - , rsAxioms = fms - , rsRules = rls - } - -getRulesetNamespace :: Ruleset ex -> Namespace -getRulesetNamespace = rsNamespace - -getRulesetAxioms :: Ruleset ex -> [Formula ex] -getRulesetAxioms = rsAxioms - -getRulesetRules :: Ruleset ex -> [Rule ex] -getRulesetRules = rsRules - ------------------------------------------------------------- --- Find a named axiom or rule in a ruleset or proof context ------------------------------------------------------------- - -getRulesetAxiom :: ScopedName -> Ruleset ex -> Maybe (Formula ex) -getRulesetAxiom nam rset = - mapFindMaybe nam (LookupMap (getRulesetAxioms rset)) - -- listToMaybe $ filter ( (matchName nam) . formName ) $ getRulesetAxioms rset - -getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) -getRulesetRule nam rset = - mapFindMaybe nam (LookupMap (getRulesetRules rset)) - -- listToMaybe $ filter ( (matchName nam) . ruleName ) $ getRulesetRules rset - -getContextAxiom :: ScopedName -> Formula ex -> [Ruleset ex] -> Formula ex -getContextAxiom nam def rsets = fromMaybe def (getMaybeContextAxiom nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetAxiom nam) rsets - -} - -getMaybeContextAxiom :: ScopedName -> [Ruleset ex] -> Maybe (Formula ex) -getMaybeContextAxiom nam rsets = - listToMaybe $ mapMaybe (getRulesetAxiom nam) rsets - -getContextRule :: ScopedName -> Rule ex -> [Ruleset ex] -> Rule ex -getContextRule nam def rsets = fromMaybe def (getMaybeContextRule nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetRule nam) rsets - -} - -getMaybeContextRule :: ScopedName -> [Ruleset ex] -> Maybe (Rule ex) -getMaybeContextRule nam rsets = - listToMaybe $ mapMaybe (getRulesetRule nam) rsets - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Ruleset.hs,v $ --- $Author: graham $ --- $Revision: 1.9 $ --- $Log: Ruleset.hs,v $ --- Revision 1.9 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.8 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.7 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.6 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.5 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.4 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.3 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.2 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.1 2003/09/30 16:38:19 graham --- Add Ruleset and RDFRuleset modules to provide proof context elements --- diff --git a/Swish/HaskellRDF/Sort/AdaptiveHeapSort.lhs b/Swish/HaskellRDF/Sort/AdaptiveHeapSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/AdaptiveHeapSort.lhs +++ /dev/null @@ -1,37 +0,0 @@ -%-------------------------------= -------------------------------------------- -\section{Adaptive heap sort} -%-------------------------------= -------------------------------------------- - -%include CartesianTree.lhs - -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - -\subsection{Adaptive heap sort} -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - - -%align - -> module Swish.HaskellRDF.Sort.AdaptiveHeapSort -> where -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.CartesianTree (BinTree(..), cartesianTree) -> import Swish.HaskellRDF.Sort.HeapSort (Heap(..), leaf, insertBy) -> import Swish.HaskellRDF.Sort.BraunHeap (siftBy, joinBy) - -%align 33 - -> adaptiveHeapSort :: (Ord a) => [a] -> [a] -> adaptiveHeapSort = adaptiveHeapSortBy (<=) - -> adaptiveHeapSortBy (<=) as = unheap (leaf (cartesianTree as)) -> where -> -> Leaf <== _ = True -> Node _ a _ <== Node _ b _ = a <= b -> Node _ _ _ <== _ = False - -> unheap Empty = [] -> unheap (Bin t hl hr) = case t of -> Node Leaf a Leaf -> a : unheap (joinBy (<==) hl hr) -> Node l a Leaf -> a : unheap (siftBy (<==) l hl hr) -> Node Leaf a r -> a : unheap (siftBy (<==) r hl hr) -> Node l a r -> a : unheap (insertBy (<==) r $ siftBy (<==) l hl hr) diff --git a/Swish/HaskellRDF/Sort/BraunHeap.lhs b/Swish/HaskellRDF/Sort/BraunHeap.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/BraunHeap.lhs +++ /dev/null @@ -1,91 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Braun heaps} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.BraunHeap -> where -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.ListLib (prefold) -> import Swish.HaskellRDF.Sort.HeapSort (Heap(..), leaf, insertBy) - -%align 33 - -%-------------------------------= -------------------------------------------- -\section{Top-down heap sort} -%-------------------------------= -------------------------------------------- - -Here is a variant of heap sort due to Paulson \cite[p. 160]{Pau96ML} -which follows the original more closely. Recall that imperative -implementations of heap sort use an implicit representation of binary -heaps ie the binary tree is embedded in an array. For a functional -explanation we step backward and represent an array by a binary tree. -The original heap sort uses left-complete trees. We use Braun -trees~\cite[p. 154]{Pau96ML} instead. However, every implementation of -functional arrays would do. We could generalize the following to an -array-based implementation of priority queues. - -The construction of the heap works as before. The second phase mimics -the imperative version: the smallest element (ie the leftmost) is -replaced by an arbitrary element (usually the rightmost) which is -sifted down the heap. Here we replace the root (ie the leftmost) by the -leftmost leaf (ie an element in the rear part of the array). Both -|splitLeft| and |sift| employ the fact that their arguments are Braun -trees. - -> unHeapBy :: Rel a -> Heap a -> [a] -> unHeapBy (<=) Empty = [] -> unHeapBy (<=) (Bin a l r) = a : unHeapBy (<=) (joinBy (<=) l r) -> -> joinBy :: Rel a -> Heap a -> Heap a -> Heap a -> joinBy (<=) l r = case splitLeft l of -> Null -> Empty -> Pair a l' -> siftBy (<=) a r l' -> -> splitLeft :: Heap a -> OptPair a (Heap a) -> splitLeft Empty = Null -> splitLeft (Bin a l r) = case splitLeft l of -> Null -> Pair a Empty -- |r == Empty| -> Pair b l' -> Pair b (Bin a r l') - -The recursion scheme is dual to that of |insert|: the element is always -deleted into the left subtree (which is possibly bigger). Additionally, -the left and the right branch are interchanged (in case both subtrees -have the same size). - -> siftBy :: Rel a -> a -> Heap a -> Heap a -> Heap a -> siftBy (<=) = sift -> where -> sift a Empty r = leaf a -- |r == Empty| -> sift a l@(Bin b _ _) Empty -- |l == leaf b| -> | a <= b = Bin a l Empty -> | otherwise = Bin b (leaf a) Empty -> sift a l@(Bin a1 l1 r1) r@(Bin a2 l2 r2) -> | a <= a1 && a <= a2 = Bin a l r -> | a1 <= a2 = Bin a1 (sift a l1 r1) r -> | otherwise = Bin a2 l (sift a l2 r2) - -We do not use the |sift| function defined in |HeapSort| because |sift| -on Braun trees is slightly simpler. Note, however, that |sift| makes a -redundant comparison if |a2 < a <= a1|. - -> braunSort :: (Ord a) => [a] -> [a] -> braunSort = braunSortBy (<=) -> -> braunSortBy :: Rel a -> [a] -> [a] -> braunSortBy (<=) = unHeapBy (<=) . foldr (insertBy (<=)) Empty - -%-------------------------------= -------------------------------------------- -\section{Bottom-up heap sort} -%-------------------------------= -------------------------------------------- - -The bottom-up variant is straightforward and a true transliteration of -Williams' heap sort apart from the fact that we use Braun trees instead -of left-complete trees. - -> bottomUpBraunSort :: (Ord a) => [a] -> [a] -> bottomUpBraunSort = bottomUpBraunSortBy (<=) -> -> bottomUpBraunSortBy :: Rel a -> [a] -> [a] -> bottomUpBraunSortBy (<=) = unHeapBy (<=) . prefold (siftBy (<=)) Empty diff --git a/Swish/HaskellRDF/Sort/CartesianTree.lhs b/Swish/HaskellRDF/Sort/CartesianTree.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/CartesianTree.lhs +++ /dev/null @@ -1,48 +0,0 @@ -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - -\subsection{Cartesian trees} -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - - -%align - -> module Swish.HaskellRDF.Sort.CartesianTree -> where - -%align 33 - -> data BinTree a = Leaf -> | Node (BinTree a) a (BinTree a) -> deriving (Show) - -Constructing a cartesian tree in linear time. - -> data Spine a = Nil -> | Cons a (BinTree a) (Spine a) - -> up :: BinTree a -> Spine a -> BinTree a -> up l Nil = l -> up l (Cons a r s) = up (Node l a r) s - -> cartesianTree :: (Ord a) => [a] -> BinTree a -> cartesianTree = cartesianTreeBy (<=) -> -> cartesianTreeBy (<=) = up Leaf . foldr (\a s -> cons a Leaf s) Nil -> where cons a t Nil = Cons a t Nil -> cons a t s@(Cons a' t' s') -> | a <= a' = cons a (Node t a' t') s' -> | otherwise = Cons a t s - -|cartesianTree [5, 8, 2, 3, 7, 4, 10, 0]| - -\NB The obvious approaches (top-down and bottom-up) both lead to -$\Theta(n\log n)$ algorithms. For curiosity here is the top-down -variant of |meld|. - -> meld :: (Ord a) => BinTree a -> BinTree a -> BinTree a -> meld Leaf u = u -> meld t Leaf = t -> meld t@(Node l a r) u@(Node l' a' r') -> | a <= a' = Node l a (meld r u) -> | otherwise = Node (meld t l') a' r' - -Note that the relative order of elements is preserved. The bottom-up -variants of cartesian trees are called \technical{pagodas}. diff --git a/Swish/HaskellRDF/Sort/DigitalSort.lhs b/Swish/HaskellRDF/Sort/DigitalSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/DigitalSort.lhs +++ /dev/null @@ -1,51 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Digital sorting} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.DigitalSort -> where -> import Data.Array -> import Data.Bits -> import Data.Int - -%align 33 - -> bucketSort :: (Ix b) => (b, b) -> (a -> b) -> [a] -> [a] -> bucketSort bs key as = [ a | b <- elems buckets, a <- reverse b ] -> where buckets = distribute bs [ (key a, a) | a <- as ] -> -> distribute :: (Ix a) => (a, a) -> [(a, b)] -> Array a [b] -> distribute = accumArray (flip (:)) [] -> -> radixSort :: (Ix b) => (b, b) -> [a -> b] -> [a] -> [a] -> radixSort bs keys x = foldr (bucketSort bs) x keys - -|keys| must satisfy the following property: let $a \leq_i b -\Longleftrightarrow |key|_i\;a \leq |key|_i\;b$ and $a(R\fatsemi S)b -\Longleftrightarrow aRb \vee (a=b \wedge aSb)$, then $(\leq) -\Longleftrightarrow (\leq_1)\fatsemi\ldots\fatsemi(\leq_n)$. - -\NB |Word| should be used instead of |Int| since the sign bit is -ignored. - -> int32Keys' :: [Int32 -> Bool] -> int32Keys' = [ \i -> testBit i k | k <- [s - 1, s - 2 .. 0] ] -> where s = bitSize (0 :: Int32) -> -> int32RadixSort' :: [Int32] -> [Int32] -> int32RadixSort' = radixSort (False, True) int32Keys' - -|shiftR| does not work properly, that's why |32 - 24| instead of |24| -is used below. - -> int32Keys :: [Int32 -> Int32] -> int32Keys = [ \i -> shiftR i (32 - 24) .&. 255 -> , \i -> shiftR i (32 - 16) .&. 255 -> , \i -> shiftR i (32 - 8) .&. 255 -> , \i -> i .&. 255 ] -> -> int32RadixSort :: [Int32] -> [Int32] -> int32RadixSort = radixSort (0, 255) int32Keys -> diff --git a/Swish/HaskellRDF/Sort/FingerSearchtree.lhs b/Swish/HaskellRDF/Sort/FingerSearchtree.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/FingerSearchtree.lhs +++ /dev/null @@ -1,125 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Finger search trees} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.FingerSearchtree -> where -> import Swish.HaskellRDF.Sort.LibBase - -%align 33 - -This is work in progress \ldots - -> data Empty a = E -> -> data Pennant tree a = Top a (tree a) -> -> data Node23 tree23 a = N2 (tree23 a) a (tree23 a) -> | N3 (tree23 a) a (tree23 a) a (tree23 a) - -> data FingerTree23 tree23 a = Nil -> | One (Pennant tree23 a) (FingerTree23 (Node23 tree23) a) -> | Two (Pennant (Node23 tree23) a) (FingerTree23 (Node23 tree23) a) -> -> type Bag a = FingerTree23 Empty a - -> incr :: Pennant tree23 a -> FingerTree23 tree23 a -> FingerTree23 tree23 a -> incr p Nil = One p Nil -> incr (Top a1 t1) (One (Top a2 t2) ds) = Two (Top a1 (N2 t1 a2 t2)) ds -> incr (Top a1 t1) (Two (Top a2 (N2 t2 a3 t3)) ds) -> = Two (Top a1 (N3 t1 a2 t2 a3 t3)) ds -> incr (Top a1 t1) (Two (Top a2 (N3 t2 a3 t3 a4 t4)) ds) -> = Two (Top a1 (N2 t1 a2 t2)) (incr (Top a3 (N2 t3 a4 t4)) ds) - -> data Grown tree23 a = U (tree23 a) -> | G (tree23 a) a (tree23 a) -> -> class Ins tree23 where -> ins :: (Ord a) => a -> tree23 a -> Grown tree23 a - -> instance Ins Empty where -> ins a E = G E a E -> -> instance (Ins tree23) => Ins (Node23 tree23) where -> ins a (N2 t1 a1 t2) -> | a <= a1 = node2l (ins a t1) a1 t2 -> | otherwise = node2r t1 a1 (ins a t2) -> ins a (N3 t1 a1 t2 a2 t3) -> | a <= a1 = node3l (ins a t1) a1 t2 a2 t3 -> | a <= a2 = node3m t1 a1 (ins a t2) a2 t3 -> | otherwise = node3r t1 a1 t2 a2 (ins a t3) - -> node2l :: Grown tree23 a -> a -> tree23 a -> Grown (Node23 tree23) a -> node2l (U t1) a1 t2 = U (N2 t1 a1 t2) -> node2l (G t1 a1 t2) a2 t3 = U (N3 t1 a1 t2 a2 t3) - -> node2r t1 a1 (U t2) = U (N2 t1 a1 t2) -> node2r t1 a1 (G t2 a2 t3) = U (N3 t1 a1 t2 a2 t3) - -> node3l (U t1) a1 t2 a2 t3 = U (N3 t1 a1 t2 a2 t3) -> node3l (G t1 a1 t2)a2 t3 a3 t4= G (N2 t1 a1 t2) a2 (N2 t3 a3 t4) - -> node3m t1 a1 (U t2) a2 t3 = U (N3 t1 a1 t2 a2 t3) -> node3m t1 a1 (G t2 a2 t3)a3 t4= G (N2 t1 a1 t2) a2 (N2 t3 a3 t4) -> -> node3r t1 a1 t2 a2 (U t3) = U (N3 t1 a1 t2 a2 t3) -> node3r t1 a1 t2 a2(G t3 a3 t4)= G (N2 t1 a1 t2) a2 (N2 t3 a3 t4) - -> insert' :: (Ord a, Ins tree23) => a -> FingerTree23 tree23 a -> Maybe (FingerTree23 tree23 a) -> insert' a Nil = Nothing -> insert' a (One p@(Top a1 t1) ds) -> | a <= a1 = Nothing -> | otherwise = case insert' a ds of -> Nothing -> Just (one a1 (ins a t1) ds) -> Just ds' -> Just (One p ds') -> insert' a (Two p@(Top a1 t1) ds) -> | a <= a1 = Nothing -> | otherwise = case insert' a ds of -> Nothing -> Just (two a1 (ins a t1) ds) -> Just ds' -> Just (Two p ds') - -> one :: a -> Grown tree23 a -> FingerTree23 (Node23 tree23) a -> FingerTree23 tree23 a -> one a1 (U t1) t2 = One (Top a1 t1) t2 -> one a1 (G t1 a2 t2) t3 = Two (Top a1 (N2 t1 a2 t2)) t3 -> -> two :: a -> Grown (Node23 tree23) a -> FingerTree23 (Node23 tree23) a -> FingerTree23 tree23 a -> two a1 (U t1) t2 = Two (Top a1 t1) t2 -> two a1 (G t1 a2 t2) t3 = Two (Top a1 t1) (incr (Top a2 t2) t3) - -> insert :: (Ord a) => a -> Bag a -> Bag a -> insert a t = case insert' a t of -> Nothing -> incr (Top a E) t -> Just t' -> t' - -> class Inord tree23 where -> inord :: tree23 a -> Sequ a -> -> instance Inord Empty where -> inord E = empty -> -> instance (Inord tree23) => Inord (Node23 tree23) where -> inord (N2 t1 a1 t2) = inord t1 . single a1 . inord t2 -> inord (N3 t1 a1 t2 a2 t3) = inord t1 . single a1 . inord t2 -> . single a2 . inord t3 -> -> instance (Inord tree23) => Inord (Pennant tree23) where -> inord (Top a t) = single a . inord t - -> inorder' :: (Inord tree23) => FingerTree23 tree23 a -> Sequ a -> inorder' Nil = empty -> inorder' (One p ds) = inord p . inorder' ds -> inorder' (Two p ds) = inord p . inorder' ds -> -> inorder :: Bag a -> [a] -> inorder b = inorder' b [] - -> fingerTreeSort :: (Ord a) => [a] -> [a] -> fingerTreeSort = inorder . foldr insert Nil - -> type Sequ a = [a] -> [a] -> -> empty = \x -> x -> -> single a = \x -> a : x diff --git a/Swish/HaskellRDF/Sort/Force.lhs b/Swish/HaskellRDF/Sort/Force.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/Force.lhs +++ /dev/null @@ -1,27 +0,0 @@ -%-------------------------------= -------------------------------------------- -\section{Hyper-strict evaluation} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.Force -> where - -%align 33 - -Vollst"andige Auswertung. - -> class Force a where -> force :: a -> () -> -> force a = a `seq` () - -> instance Force Bool -> instance Force Char -> instance Force Int -> instance Force Integer -> instance Force Double -> -> instance (Force a) => Force [a] where -> force [] = () -> force (a : as) = force a `seq` force as diff --git a/Swish/HaskellRDF/Sort/HeapSort.lhs b/Swish/HaskellRDF/Sort/HeapSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/HeapSort.lhs +++ /dev/null @@ -1,140 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Heap sort} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.HeapSort -> where -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.ListLib -> import Swish.HaskellRDF.Sort.MergeSort (mergeBy) - -%align 33 - -%-------------------------------= -------------------------------------------- -\section{Top-down heap sort} -%-------------------------------= -------------------------------------------- - -It appears that the functional variant of heap sort has been invented -several times. See, for instance, \cite[p.~155]{HinFun92} or -\cite[p.~20]{Bir96Fun}. - -Heap sort is based on binary heap ordered trees. - -> data Heap a = Empty -> | Bin a (Heap a) (Heap a) -> -> leaf :: a -> Heap a -> leaf a = Bin a Empty Empty - -The top-down variant works by repeatedly inserting elements into an -empty initial tree. - -> insertBy :: Rel a -> a -> Heap a -> Heap a -> insertBy (<=) a Empty = leaf a -> insertBy (<=) a (Bin b l r) -> | a <= b = Bin a (insertBy (<=) b r) l -> | otherwise = Bin b (insertBy (<=) a r) l - -Repeated |insert|'s constructs a so-called Braun tree (|size r <= size -l <= size r+1| holds for each |Bin l a r|). This guarantees a worst -case running time of $O(n\log n)$ for |heapSort|. The recursion scheme -is typical for Braun trees: the element is always inserted into the -right subtree (which is possibly smaller). Additionally, the left and -the right branch are interchanged (in case both subtrees have the same -size). This implies, however, that |heapSort| is not stable. - -> unHeapBy :: Rel a -> Heap a -> [a] -> unHeapBy (<=) Empty = [] -> unHeapBy (<=) (Bin a l r) = a : mergeBy (<=) (unHeapBy (<=) l) -> (unHeapBy (<=) r) -> -> heapSort :: (Ord a) => [a] -> [a] -> heapSort = heapSortBy (<=) -> -> heapSortBy :: Rel a -> [a] -> [a] -> heapSortBy (<=) = unHeapBy (<=) . foldr (insertBy (<=)) Empty - - -The function |unheap| resorts to |merge| which probably not in the -spirit of the original heap sort by Williams (see also -\cite[p.~21]{Bir96Fun} where |meld| is called combine). Instead we can -combine the two subheaps into one. - -> unHeap :: (Ord a) => Heap a -> [a] -> unHeap Empty = [] -> unHeap (Bin a l r) = a : unHeap (meld l r) -> -> meld :: (Ord a) => Heap a -> Heap a -> Heap a -> meld Empty t' = t' -> meld t@(Bin _ _ _) Empty = t -> meld t@(Bin a l r) t'@(Bin a' l' r') -> | a <= a' = Bin a (meld l r) t' -> | otherwise = Bin a' t (meld l' r') - -This variant of |unHeap| also clarifies the relationship to merge -sort. First note that |meld| is closely related to |merge|. We have -% -\begin{eqnarray*} - |toOrdList (meld t u)| - & = & |merge (toOrdList t) (toOrdList u)| \enskip. -\end{eqnarray*} -% -Thus - -> heapSort' :: (Ord a) => [a] -> [a] -> heapSort' = unHeap . gfoldm Empty leaf meld - -is structurally equivalent to |mergeSort| (ie it performs the same -comparisons during the sorting process). In essence, this shows that it -is unlikely that heap sort is faster than merge sort. As a final remark -note that |heapSort'| is stable and lazy. - -%-------------------------------= -------------------------------------------- -\section{Bottom-up heap sort} -%-------------------------------= -------------------------------------------- - -It is well known that a heap can be constructed in linear time. We -have already seen a simple method, namely |gfoldm empty leaf meld|! -The classical solution employs a function termed |sift|. Functionally -speaking, |sift| is a smart constructor for binary heaps, ie it -combines an element and two heaps into a single heap. -{\setlength{\lwidth}{\lwidth + 1cm} - -> siftBy :: Rel a -> a -> Heap a -> Heap a -> Heap a -> siftBy (<=) = sift -> where -> sift a Empty Empty = leaf a -> sift a Empty r@(Bin _ _ _) = siftr a Empty r -> sift a l@(Bin _ _ _) Empty = siftl a l Empty -> sift a l@(Bin b _ _) r@(Bin c _ _) -> | b <= c = siftl a l r -> | otherwise = siftr a l r -> -> siftl a Empty r = error "siftl" -> siftl a l@(Bin b ll lr) r -> | a <= b = Bin a l r -> | otherwise = Bin b (sift a ll lr) r -> -> siftr a l Empty = error "siftr" -> siftr a l r@(Bin b rl rr) -> | a <= b = Bin a l r -> | otherwise = Bin b l (sift a rl rr) - -Note that |sift| does not change the structure of the subheaps. We -could be more reluctant and replace |siftr| by |siftl|. Unfortunately, -|sift| is not stable, ie the relative order of elements is not -preserved.} - -> bottomUpHeapSort :: (Ord a) => [a] -> [a] -> bottomUpHeapSort = bottomUpHeapSortBy (<=) -> -> bottomUpHeapSortBy :: Rel a -> [a] -> [a] -> bottomUpHeapSortBy (<=) = unHeapBy (<=) . prefold (siftBy (<=)) Empty - -To see what |prefold| does, consider the call |prefold Bin Empty as|. -The result is a Braun tree the preorder traversal of which yields -|as|. An alternative algorithm which constructs a tree whose -\technical{level-order} traversal is equal to the original sequence is -given in \cite[p.~22]{Bir96Fun}. diff --git a/Swish/HaskellRDF/Sort/LibBase.lhs b/Swish/HaskellRDF/Sort/LibBase.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/LibBase.lhs +++ /dev/null @@ -1,24 +0,0 @@ -%-------------------------------= -------------------------------------------- -\section{Base functions and types} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.LibBase -> where - -%align 33 - -> type Rel a = a -> a -> Bool - -> data OptPair a b = Null -> | Pair a b - -> ordered :: (Ord a) => [a] -> Bool -> ordered = orderedBy (<=) - -> orderedBy :: Rel a -> [a] -> Bool -> orderedBy (<=) [] = True -> orderedBy (<=) (a : as) = ordered a as -> where ordered a1 [] = True -> ordered a1 (a2 : as) = a1 <= a2 && ordered a2 as diff --git a/Swish/HaskellRDF/Sort/ListLib.lhs b/Swish/HaskellRDF/Sort/ListLib.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/ListLib.lhs +++ /dev/null @@ -1,119 +0,0 @@ -%-------------------------------= -------------------------------------------- -\section{List library} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.ListLib -> where - -%align 33 - -> simple :: [a] -> Bool -> simple [] = True -> simple [a] = True -> simple (a1 : a2 : as) = False - -> halve :: [a] -> ([a], [a]) -> halve as = splitAt (length as `div` 2) as - -> repSplit :: [Int] -> [a] -> [[a]] -> repSplit ns [] = [] -> repSplit [] xs = [xs] -> repSplit (n : ns) xs = ys : repSplit ns zs -> where (ys, zs) = splitAt n xs - -> copy :: [a] -> [a] -> copy = concat . repeat - -> interleave :: [a] -> [a] -> [a] -> interleave [] y = y -> interleave (a:x) y = a : interleave y x - -> uninterleave :: [a] -> ([a], [a]) -> uninterleave [] = ([], []) -> uninterleave [a] = ([a], []) -> uninterleave (a1 : a2 : as) = (a1 : odds, a2 : evens) -> where (odds, evens) = uninterleave as - -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - -\subsection{folds} -%- - - - - - - - - - - - - - - -= - - - - - - - - - - - - - - - - - - - - - - - -Here is yet another colleague of |foldr| and |foldl|: |foldm| -constructs a balanced expression tree. - -> foldm :: (a -> a -> a) -> a -> [a] -> a -> foldm (*) e [] = e -> foldm (*) e x = fst (rec (length x) x) -> where rec 1 (a:x) = (a, x) -> rec n x = (a * b, z) -> where m = n `div` 2 -> (a, y) = rec (n - m) x -> (b, z) = rec m y - -> gfoldm :: a -> (b -> a) -> (a -> a -> a) -> [b] -> a -> gfoldm e f (*) [] = e -> gfoldm e f (*) x = fst (rec (length x) x) -> where rec 1 (a:x) = (f a, x) -> rec n x = (a * b, z) -> where m = n `div` 2 -> (a, y) = rec (n - m) x -> (b, z) = rec m y - -Jon's |treefold|. In a sense |foldm| works top-down and |treefold| -works bottom-up. - -> treefold :: (a -> a -> a) -> a -> [a] -> a -> treefold (*) e [] = e -> treefold (*) e [a] = a -> treefold (*) e (a:b:x) = treefold (*) e (a * b : pairfold (*) x) - -> pairfold :: (a -> a -> a) -> [a] -> [a] -> pairfold (*) (a:b:x) = a * b : pairfold (*) x -> pairfold (*) x = x -- here |x| will have fewer than two - -Note that |foldm| and |treefold| construct different trees: |foldm| -returns a Braun tree while |treefold| returns a tree of the form -\[ - |t1 * (t2 * (.. (tn-1 * tn) ..))| -\] -where the |ti|'s are complete binary trees in decreasing size. The size -of the trees corresponds to the binary decomposition of the input -length. - -"`Inverse"' Funktion zum Preorder-Durchlauf. - -> prefold :: (a -> b -> b -> b) -> b -> [a] -> b -> prefold f e as = fst (rec (length as) as) -> where rec 0 as = (e, as) -> rec (n + 1) [] = error "rec" -> rec (n + 1) (a : as)= (f a l r, as2) -> where m = n `div` 2 -> (l, as1) = rec (n - m) as -> (r, as2) = rec m as1 - -> perms :: [a] -> [[a]] -> perms [] = [ [] ] -> perms (a:x) = [ z | y <- perms x, z <- insertions a y ] -> -> insertions :: a -> [a] -> [[a]] -> insertions a [] = [ [a] ] -> insertions a x@(b:y) = (a:x) : [ b:z | z <- insertions a y ] - -> spaces :: Int -> [Char] -> spaces n = replicate (max n 0) ' ' - -> cjustify, ljustify, rjustify :: Int -> String -> String -> cjustify = cjustifyWith ' ' -> ljustify n s = s ++ spaces (n - length s) -> rjustify n s = spaces (n - length s) ++ s - -> indent :: Int -> String -> String -> indent n s = spaces n ++ s - -> cjustifyWith :: a -> Int -> [a] -> [a] -> cjustifyWith c n s = replicate l c ++ s ++ replicate r c -> where m = n - length s -> l = m `div` 2 -> r = m - l diff --git a/Swish/HaskellRDF/Sort/MargeSort.lhs b/Swish/HaskellRDF/Sort/MargeSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/MargeSort.lhs +++ /dev/null @@ -1,576 +0,0 @@ -%if codeOnly - -> module Swish.HaskellRDF.Sort.MargeSort (margeSort, naturalMargeSort) -> where -> import Swish.HaskellRDF.Sort.MergeSort (upDownRunsBy) -> -> data OptPair a b = NoPair | Pair a b -> -> data Empty a = E -> -> data Node23 tree a = N2 (tree a) a (tree a) -> | N3 (tree a) a (tree a) a (tree a) -> -> type FST1 = FingerSearchTree1 -> -> type OS = OrdSequence -> -> data Grown tree a = U (tree a) -> | G (tree a) a (tree a) - -%endif -%format Cons (a) (t) = a "\triangleleft " t -%format Snoc (t) (a) = t "\triangleright " a -%-------------------------------= -------------------------------------------- -\section{Double-ended Finger Search Trees} -\label{sec:fstvariations} -%-------------------------------= -------------------------------------------- - -\Todo{Min-Max-Heaps}. The datatype |FST| implements one-sided ordered -sequences. In order to support operations on both ends --- |snoc = -addMax| and |rear = splitMax| in addition to |cons = AddMin| and |front -= splitMin| --- we must base finger search trees on the symmetric spine -view of 2-3 trees. Here are the necessary type definitions. -%align 9 -%{ -%format S2 = Simple2 -%format S3 = Simple3 -%format C = Composite - -> data FingerSearchTree1 tree a -> = S2 a -> | S3 a (tree a) a -> | C (Digit Front tree a) -> (FingerSearchTree1 (Node23 tree) a) -> (Digit Rear tree a) -> -> data Digit pennant tree a -> = One (pennant tree a) -> | Two (pennant (Node23 tree) a) - -%} -%align 33 - -> data Front tree a = Cons a (tree a) -> -> data Rear tree a = Snoc (tree a) a -> -> data OrdSequence a = Nil | Id (FingerSearchTree1 Empty a) - -Two points are worth mentioning. First of all, |FST1| is not capable of -representing the empty sequence. For that reason we have introduced the -wrapper datatype |OS| (see also Section~\ref{sec:external}). Second, we -use different types of pennants for the digits on the left and for -those on the right spine view. The types have been chosen so that the -order of elements within an expression reflects the order of elements -within the sequence represented. - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -\subsection{Deque operations} -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - - -The deque operations, |cons|, |incr|, |splitMin|, |zero| and their -colleagues |snoc|, |rcni|, |splitMax|, |eroz|, can be easily adapted to -the new design. Here, we show the modified versions of |cons| and -|incr| only. -%{ -%format One = O -%format Two = T -%align 41 - -> cons :: a -> OrdSequence a -> OrdSequence a -> cons a Nil = Id (S2 a) -> cons a (Id s) = Id (incr a E s) -> -> incr :: a -> t a -> FST1 t a -> FST1 t a -> incr a1 t1 (S2 a2) = S3 a1 t1 a2 -> incr a1 t1 (S3 a2 t2 a3) = C (One (Cons a1 t1)) (S2 a2) (One (Snoc t2 a3)) -> incr a1 t1 (C (One (Cons a2 t2)) m r) = C (Two (Cons a1 (N2 t1 a2 t2))) m r -> incr a1 t1 (C (Two (Cons a2 (N2 t2 a3 t3))) m r) -> = {-"\enskip\,"-} C (Two (Cons a1 (N3 t1 a2 t2 a3 t3))) m r -> incr a1 t1 (C (Two (Cons a2 (N3 t2 a3 t3 a4 t4))) m r) -> = {-"\enskip\,"-} C (Two (Cons a1 (N2 t1 a2 t2))) (incr a3 (N2 t3 a4 t4) m) r - -It is instructive to relate the equations to the rebalancing operations -on 2-3 trees. The first equation corresponds to an expansion of a -2-node to a 3-node, the second equation realizes a split of a 3-node -into two 2-nodes. -%if codeOnly - -> s4 :: a -> t a -> a -> t a -> a -> FST1 t a -> s4 a1 t1 a2 t2 a3 = C (One (Cons a1 t1)) (S2 a2) (One (Snoc t2 a3)) -> -> snoc :: OrdSequence a -> a -> OrdSequence a -> snoc Nil a = Id (S2 a) -> snoc (Id s) a = Id (rcni s E a) -> -> rcni :: FST1 t a -> t a -> a -> FST1 t a -> rcni (S2 a1) t1 a2 = S3 a1 t1 a2 -> rcni (S3 a1 t1 a2) t2 a3 = s4 a1 t1 a2 t2 a3 -> rcni (C f m (One (Snoc t1 a1))) t2 a2 = C f m (Two (Snoc (N2 t1 a1 t2) a2)) -> rcni (C f m (Two (Snoc (N2 t1 a1 t2) a2))) t3 a3 -> = {-"\enskip\,"-} C f m (Two (Snoc (N3 t1 a1 t2 a2 t3) a3)) -> rcni (C f m (Two (Snoc (N3 t1 a1 t2 a2 t3) a3))) t4 a4 -> = {-"\enskip\,"-} C f (rcni m (N2 t1 a1 t2) a2) (Two (Snoc (N2 t3 a3 t4) a4)) - -> zero' :: FST1 (Node23 t) a -> Digit Rear t a -> FST1 t a -> zero' (S2 a1) (One (Snoc t1 a2)) = S3 a1 t1 a2 -> zero' (S2 a1) (Two (Snoc (N2 t1 a2 t2) a3)) -> = s4 a1 t1 a2 t2 a3 -> zero' (S2 a1) (Two (Snoc (N3 t1 a2 t2 a3 t3) a4)) -> = C (One (Cons a1 t1)) (S2 a2) (Two (Snoc (N2 t2 a3 t3) a4)) -> zero' (S3 a1 t1 a2) d = C (Two (Cons a1 t1)) (S2 a2) d -> zero' (C (One p) m r) d = C (Two p) (zero' m r) d -> zero' (C (Two (Cons a1 (N2 t1 a2 t2))) m r) d -> = C (Two (Cons a1 t1)) (C (One (Cons a2 t2)) m r) d -> zero' (C (Two (Cons a1 (N3 t1 a2 t2 a3 t3))) m r) d -> = C (Two (Cons a1 t1)) (C (Two (Cons a2 (N2 t2 a3 t3))) m r) d -> -> splitMin :: OrdSequence a -> OptPair a (OrdSequence a) -> splitMin Nil = NoPair -> splitMin (Id (S2 a1)) = Pair a1 Nil -> splitMin (Id (S3 a1 E a2)) = Pair a1 (Id (S2 a2)) -> splitMin (Id (C (One (Cons a1 E)) m r)) -> = Pair a1 (Id (zero' m r)) -> splitMin (Id (C (Two (Cons a1 (N2 E a2 E))) m r)) -> = Pair a1 (Id (C (One (Cons a2 E)) m r)) -> splitMin (Id (C (Two (Cons a1 (N3 E a2 E a3 E))) m r)) -> = Pair a1 (Id (C (Two (Cons a2 (N2 E a3 E))) m r)) - -> eroz :: Digit Front t a -> FST1 (Node23 t) a -> FST1 t a -> eroz (One (Cons a1 t1)) (S2 a2) = S3 a1 t1 a2 -> eroz (Two (Cons a1 (N2 t1 a2 t2))) (S2 a3) -> = s4 a1 t1 a2 t2 a3 -> eroz (Two (Cons a1 (N3 t1 a2 t2 a3 t3))) (S2 a4) -> = C (Two (Cons a1 (N2 t1 a2 t2))) (S2 a3) (One (Snoc t3 a4)) -> eroz d (S3 a1 t1 a2) = C d (S2 a1) (Two (Snoc t1 a2)) -> eroz d (C f m (One p)) = C d (eroz f m) (Two p) -> eroz d (C f m (Two (Snoc (N2 t1 a1 t2) a2))) -> = C d (C f m (One (Snoc t1 a1))) (Two (Snoc t2 a2)) -> eroz d (C f m (Two (Snoc (N3 t1 a1 t2 a2 t3) a3))) -> = C d (C f m (Two (Snoc (N2 t1 a1 t2) a2))) (Two (Snoc t3 a3)) - -%endif -%} -%align 33 - -\smallskip -\noindent\textbf{Remark.} \Todo{Pattern abstractions} - -< D1 a1 t1 = One (Cons a1 t1) -< D2 a1 t1 a2 t2 = Two (Cons a1 (N2 t1 a2 t2)) -< D3 a1 t1 a2 t2 a3 t3 = Two (Cons a1 (N3 t1 a2 t2 a3 t3)) - -blub\hfill$\Box$ - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -\subsection{Bag operations} -\label{sec:bag} -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - - -\Todo{Worte zu |insert| und |delete|}. To adapt |member| we must first -symmetrize the auxiliary datatype |Loc|. -%format fun = "(\star)" -%format `fun` = "\star " - -> data Loc a = Lt | Eq a | Gt -> -> between :: a -> Loc a -> a -> a -> between a1 Lt a3 = a1 -> between a1 (Eq a2) a3 = a2 -> between a1 Gt a3 = a3 - -%format fun (f) (a) = f "\star " a -The function |between| generalizes the operator |after| of -Section~\ref{sec:search}. Depending on the value of the second -argument the search is continued to the left or to the right. - -%format min' = min -%format max' = max -%subst code a = "\begin{array}{@{}lcl}'n" a "'n\end{array}" -\[ -\begin{array}{c@@{\qquad}c} - -> min' (One (Cons m t)) = m -> min' (Two (Cons m t)) = m -> -> max' (One (Snoc t m)) = m -> max' (Two (Snoc t m)) = m - -& - -> memf a (One (Cons m t)) = mem a t -> memf a (Two (Cons m t)) = mem a t -> -> memr a (One (Snoc t m)) = mem a t -> memr a (Two (Snoc t m)) = mem a t - -\end{array} -\] -%subst code a = "\[\begin{array}{@{}lcl}'n\hspace{\lwidth}&\hspace{\cwidth}&\\[-10pt]'n" a "'n\end{array}\]" -The function |member'| implements a quasi-parallel search along the two -spines. If $d_1$ is the distance from the smallest element and $d_2$ -the distance from the largest element, then |member| runs in -$\Theta(\min\{d_1, d_2\})$. - -> member' :: (Ord a, Mem t) => a -> FST1 t a -> Loc Bool -> member' a (S2 a1) -> | a < a1 = Lt -> | a > a1 = Gt -> | otherwise = Eq True -> member' a (S3 a1 t1 a2) -> | a < a1 = Lt -> | a > a2 = Gt -> | otherwise = Eq (mem a t1) -> member' a (C f m r) -> | a < min' f = Lt -> | a > max' r = Gt -> | otherwise = Eq (between (memf a f) (member' a m) (memr a r)) -> -> member :: (Ord a) => a -> OrdSequence a -> Bool -> member a Nil = False -> member a (Id s) = between False (member' a s) False - - -The adaptive sorting algorithm described in Section~\ref{sec:insert} -has the irritating property that the worst case is a list in descending -order which is arguably almost sorted. In a sense this is due to the -measure |Inv| which yields the largest value for lists in descreasing -order. If we represent ordered sequences with 2-3 trees under the -symmetric spine view we obtain a sorting algorithm which is optimal -with respect to $\widehat{|Inv|}$ given by -\[ - \widehat{|Inv|}(x) = \min\{|Inv|(x), |Inv|(|reverse x|)\} \enskip. -\] -The new worst-case is an interleaving of an ascending and a descending -list: -\[ - 1, 2n, 2, 2n-1, 3, 2n-2, \ldots, n-2, n+1, n-1, n \enskip. -\] - -%if codeOnly - -> fun :: (a -> b) -> Loc a -> Loc b -> f `fun` Lt = Lt -> f `fun` (Eq a) = Eq (f a) -> f `fun` Gt = Gt - -> class Mem tree where -> mem :: (Ord a) => a -> tree a -> Bool -> -> instance Mem Empty where -> mem a E = False -> -> instance (Mem tree) => Mem (Node23 tree) where -> mem a (N2 t1 a1 t2) -> | a < a1 = mem a t1 -> | a == a1 = True -> | otherwise = mem a t2 -> mem a (N3 t1 a1 t2 a2 t3) -> | a < a1 = mem a t1 -> | a == a1 = True -> | a < a2 = mem a t2 -> | a == a2 = True -> | otherwise = mem a t3 - -> type Sequ a = [a] -> [a] -> -> empty = \x -> x -> -> unit a = \x -> a : x - -> class Inorder tree where -> inorder :: tree a -> Sequ a -> -> instance Inorder Empty where -> inorder E = empty -> -> instance (Inorder tree) => Inorder (Node23 tree) where -> inorder (N2 t1 a1 t2) = inorder t1 . unit a1 . inorder t2 -> inorder(N3 t1 a1 t2 a2 t3)= inorder t1 . unit a1 . inorder t2 . unit a2 . inorder t3 -> -> inord (One p) = inorder p -> inord (Two p) = inorder p -> -> instance (Inorder tree) => Inorder (Front tree) where -> inorder (Cons a t) = unit a . inorder t -> -> instance (Inorder tree) => Inorder (Rear tree) where -> inorder (Snoc t a) = inorder t . unit a - -> toList' :: (Inorder tree) => FingerSearchTree1 tree a -> Sequ a -> toList' (S2 a1) = unit a1 -> toList' (S3 a1 t1 a2) = unit a1 . inorder t1 . unit a2 -> toList' (C f m r) = inord f . toList' m . inord r - -> toList :: OrdSequence a -> [a] -> toList Nil = [] -> toList (Id s) = toList' s [] - -%endif - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -\subsection{Concatenation} -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - - -%include Pic8.lhs - -> (<>) :: OrdSequence a -> OrdSequence a -> OrdSequence a -> Nil <> s2 = s2 -> s1 <> Nil = s1 -> Id s1 <> Id s2 = Id (app s1 (U E) s2) - -$a3 = (a+1)1$ - -%align 49 - -> norm (Two (Cons a1 (N3 t1 a2 t2 a3 t3))) m = (One (Cons a1 t1), incr a2 (N2 t2 a3 t3) m) -> norm f m = (f, m) - -%align 41 - -> app :: FST1 t a -> Grown t a -> FST1 t a -> FST1 t a -> app (S2 a1) (U t1) x = incr a1 t1 x -> app (S2 a1) (G t1 a2 t2) x = incr a1 t1 (incr a2 t2 x) -> app x (U t1) (S2 a1) = rcni x t1 a1 -> app x (G t1 a1 t2) (S2 a2) = rcni (rcni x t1 a1) t2 a2 -> app (S3 a1 t1 a2) (U t2) x = incr a1 t1 (incr a2 t2 x) -> app (S3 a1 t1 a2) (G t2 a3 t3) x = incr a1 t1 (incr a2 t2 (incr a3 t3 x)) -> app x (U t1) (S3 a1 t2 a2) = rcni (rcni x t1 a1) t2 a2 -> app x (G t1 a1 t2) (S3 a2 t3 a3) = rcni (rcni (rcni x t1 a1) t2 a2) t3 a3 -> app (C f1 m1 r1) t (C f2 m2 r2) = C f1 (app m1' (join r1' t f2') m2') r2 -> where (m1', r1') = mron m1 r1 -> (f2', m2') = norm f2 m2 - -%align 33 - -< join :: Digit Rear t a -> Grown t a -> Digit Front t a -> Grown (Node23 t) a -< join (One (Snoc t1 a1)) (U t2) (One (Cons a2 t3)) -< = U (N3 t1 a1 t2 a2 t3) -< join (One (Snoc t1 a1)) (G t2 a2 t3) (One (Cons a3 t4)) -< = G (N2 t1 a1 t2) a2 (N2 t3 a3 t4) -< {-"\ldots"-} -< join (Two (Snoc (N2 t1 a1 t2) a2)) (G t3 a3 t4) (Two (Cons a4 (N2 t5 a5 t6))) -< = G (N3 t1 a1 t2 a2 t3) a3 (N3 t4 a4 t5 a5 t6) - -%if codeOnly - - -> mron m (Two (Snoc (N3 t1 a1 t2 a2 t3) a3)) = (rcni m (N2 t1 a1 t2) a2, One (Snoc t3 a3)) -> mron m r = (m, r) -> -> join :: Digit Rear t a -> Grown t a -> Digit Front t a -> Grown (Node23 t) a -> join (One (Snoc t1 a1)) (U t2) (One (Cons a2 t3)) -> = U (N3 t1 a1 t2 a2 t3) -> join (One (Snoc t1 a1)) (G t2 a2 t3) (One (Cons a3 t4)) -> = G (N2 t1 a1 t2) a2 (N2 t3 a3 t4) -> join (One (Snoc t1 a1)) (U t2) (Two (Cons a2 t3)) -> = G (N2 t1 a1 t2) a2 t3 -> join (One (Snoc t1 a1)) (G t2 a2 t3) (Two (Cons a3 t4)) -> = G (N3 t1 a1 t2 a2 t3) a3 t4 -> join (Two (Snoc t1 a1)) (U t2) (One (Cons a2 t3)) -> = G t1 a1 (N2 t2 a2 t3) -> join (Two (Snoc t1 a1)) (G t2 a2 t3) (One (Cons a3 t4)) -> = G t1 a1 (N3 t2 a2 t3 a3 t4) -> join (Two (Snoc (N2 t1 a1 t2) a2)) (U t3) (Two (Cons a3 t4)) -> = G (N3 t1 a1 t2 a2 t3) a3 t4 -> join (Two (Snoc (N2 t1 a1 t2) a2)) (G t3 a3 t4) (Two (Cons a4 (N2 t5 a5 t6))) -> = G (N3 t1 a1 t2 a2 t3) a3 (N3 t4 a4 t5 a5 t6) - -%endif - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -\subsection{Splitting} -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - - -> part :: (Ord a) => a -> FST1 t a -> Loc (FST1 t a, t a, FST1 t a) -> part a (S2 a1) -> | a <= a1 = Lt -> | otherwise = Gt -> part a (S3 a1 t1 a2) -> | a <= a1 = Lt -> | a >= a2 = Gt -> | otherwise = Eq (S2 a1, t1, S2 a2) -> part a (C f m r) -> | a <= min' f = Lt -> | a >= max' r = Gt -> | otherwise = Eq (between (cutf f) (cutm `fun` part a m) (cutr r)) -> where -> cutm (m1, t, m2) = split a f m1 t m2 r -> cutf (One (Cons a1 t1)) = (S2 a1, t1, zero' m r) -> cutf (Two (Cons a1 t1)) = lsplit a a1 t1 m r -> cutr (One (Snoc t1 a1)) = (eroz f m, t1, S2 a1) -> cutr (Two (Snoc t1 a1)) = rsplit a f m t1 a1 - -> split a f m1 (N2 t1 a1 t2) m2 r -> | a <= a1 = (eroz f m1, t1, C (One (Cons a1 t2)) m2 r) -> | otherwise = (C f m1 (One (Snoc t1 a1)), t2, zero' m2 r) -> split a f m1 (N3 t1 a1 t2 a2 t3) m2 r -> | a <= a1 = (eroz f m1, t1, C (Two (Cons a1 (N2 t2 a2 t3))) m2 r) -> | a <= a2 = (C f m1 (One (Snoc t1 a1)), t2, C (One (Cons a2 t3)) m2 r) -> | otherwise = (C f m1 (Two (Snoc (N2 t1 a1 t2) a2)), t3, zero' m2 r) - -%if codeOnly - -> lsplit a a1 (N2 t1 a2 t2) m2 r -> | a <= a2 = (S2 a1, t1, C (One (Cons a2 t2)) m2 r) -> | otherwise = (zero' (S2 a1) (One (Snoc t1 a2)), t2, zero' m2 r) -> lsplit a a1 (N3 t1 a2 t2 a3 t3) m2 r -> | a <= a2 = (S2 a1, t1, C (Two (Cons a2 (N2 t2 a3 t3))) m2 r) -> | a <= a3 = (zero' (S2 a1) (One (Snoc t1 a2)), t2, C (One (Cons a3 t3)) m2 r) -> | otherwise = (zero' (S2 a1) (Two (Snoc (N2 t1 a2 t2) a3)), t3, zero' m2 r) - -> rsplit a f m1 (N2 t1 a1 t2) a2 -> | a <= a1 = (eroz f m1, t1, eroz (One (Cons a1 t2)) (S2 a2)) -> | otherwise = (C f m1 (One (Snoc t1 a1)), t2, S2 a2) -> rsplit a f m1 (N3 t1 a1 t2 a2 t3) a3 -> | a <= a1 = (eroz f m1, t1, eroz (Two (Cons a1 (N2 t2 a2 t3))) (S2 a3)) -> | a <= a2 = (C f m1 (One (Snoc t1 a1)), t2, eroz (One (Cons a2 t3)) (S2 a3)) -> | otherwise = (C f m1 (Two (Snoc (N2 t1 a1 t2) a2)), t3, S2 a3) - -%endif - -> partition :: (Ord a) => a -> OS a -> (OS a, OS a) -> partition a Nil = (Nil, Nil) -> partition a (Id t) = between (Nil, Id t) (wrap `fun` part a t) (Id t, Nil) -> where wrap (t1, E, t2) = (Id t1, Id t2) - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -\subsection{Margesort} -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - - -Nicht stabil! - -> merge :: (Ord a) => OS a -> OS a -> OS a -> merge x y = case splitMin y of -> NoPair -> x -> Pair a y' -> x1 <> cons a (merge y' x2) -> where (x1, x2) = partition a x - -> margeSort :: (Ord a) => [a] -> [a] -> margeSort = toList . foldm merge Nil . map single -> -> single :: a -> OrdSequence a -> single a = Id (S2 a) - -> naturalMargeSort :: (Ord a) => [a] -> [a] -> naturalMargeSort = toList . foldm merge Nil . map fromList . upDownRunsBy (<=) - -Wenn es viele gleiche Elemente gibt ... NAJA lineare Suche statt bin"arer - -> merge2 :: (Ord a) => OS a -> OS a -> OS a -> merge2 x y = case splitMin y of -> NoPair -> x -> Pair a y' -> (x1 <> x3) <> cons a (merge2 y' x4) -> where (x1, x2) = partition a x -> (x3, x4) = splitWhile (== a) x2 - -> splitWhile p s = case splitMin s of -> NoPair -> (Nil, Nil) -> Pair a s' -> | p a -> (cons a s1, s2) -> | otherwise -> (Nil, s) -> where (s1, s2) = splitWhile p s' - -% - - - - - - - - - - - - - - - = - - - - - - - - - - - - - - - - - - - - - - - -%if codeOnly - -and [ x == toList (fromList x) | n <- [0 .. 500], let x = [1 .. n] ] - -and [ x ++ y == toList (fromList x <> fromList y) | m <- [0 .. 100], n <- [0 .. 100], let x = [1 .. m], let y = [1 .. n] ] - -[ (m, n) | m <- [0 .. 100], n <- [0 .. 100], let x = [1 .. m], let y = [m `div` 2 .. n + m `div` 2], meld x y /= toList (fromList x `merge` fromList y) ] - -ordered (margeSort $ take 1500 $ random2Ints 2432 234) - -and [ ordered (margeSort $ take n $ random2Ints 2432 234) | n <- [0 .. 1500] ] - -> fromList [] = Nil -> fromList as = Id (fromList1 as) -> -> fromList1 [a] = S2 a -> fromList1 (a : as) = incr a E (fromList1 as) - -> foldm :: (a -> a -> a) -> a -> [a] -> a -> foldm (*) e [] = e -> foldm (*) e x = fst (rec (length x) x) -> where rec 1 (a:x) = (a, x) -> rec n x = (a * b, z) -> where m = n `div` 2 -> (a, y) = rec (n - m) x -> (b, z) = rec m y - -> random2Ints :: Int -> Int -> [Int] -> random2Ints s1 s2 -> | s1 < 1 || s1 > 2147483562 = error "random2Ints: Bad first seed." -> | s2 < 1 || s2 > 2147483398 = error "random2Ints: Bad second seed." -> | otherwise = rands s1 s2 - -> rands :: Int -> Int -> [Int] -> rands s1 s2 -> | z < 1 = z + 2147483562 : rands s1'' s2'' -> | otherwise = z : rands s1'' s2'' -> where k = s1 `div` 53668 -> s1' = 40014 * (s1 - k * 53668) - k * 12211 -> s1'' | s1' < 0 = s1' + 2147483563 -> | otherwise = s1' -> k' = s2 `div` 52774 -> s2' = 40692 * (s2 - k' * 52774) - k' * 3791 -> s2'' | s2' < 0 = s2' + 2147483399 -> | otherwise = s2' -> z = s1'' - s2'' - -> ordered :: (Ord a) => [a] -> Bool -> ordered [] = True -> ordered [a] = True -> ordered (a1 : as @ (a2 : _)) = a1 <= a2 && ordered as - -> meld [] y = y -> meld x@(a:_) [] = x -> meld x@(a:x') y@(b:y') -> | a <= b = a : meld x' y -> | otherwise = b : meld x y' - -Konversion in `richtige' 2-3-4 B"aume f"ur die graphische Darstellung. - -> data Tree24 a = Void -> | Node2 (Tree24 a) a (Tree24 a) -> | Node3 (Tree24 a) a (Tree24 a) a (Tree24 a) -> | Node4 (Tree24 a) a (Tree24 a) a (Tree24 a) a (Tree24 a) - -> class Conv tree where -> conv :: tree a -> Tree24 a -> -> instance Conv Empty where -> conv E = Void -> -> instance (Conv tree) => Conv (Node23 tree) where -> conv (N2 t1 a1 t2) = Node2 (conv t1) a1 (conv t2) -> conv (N3 t1 a1 t2 a2 t3) = Node3 (conv t1) a1 (conv t2) a2 (conv t3) - -> convert Nil = Void -> convert (Id s) = convert' Void s Void - -> convert' :: (Conv t) => Tree24 a -> FST1 t a -> Tree24 a -> Tree24 a -> convert' l (S2 a1) r = Node2 l a1 r -> convert' l (S3 a1 t1 a2) r = Node3 l a1 (conv t1) a2 r -> convert' l (C f m r) r' = convert' (link l f) m (knil r r') - -> link t1 (One (Cons a1 t2)) = Node2 t1 a1 (conv t2) -> link t1 (Two (Cons a1 (N2 t2 a2 t3))) = Node3 t1 a1 (conv t2) a2 (conv t3) -> link t1 (Two (Cons a1 (N3 t2 a2 t3 a3 t4))) = Node4 t1 a1 (conv t2) a2 (conv t3) a3 (conv t4) -> -> knil (One (Snoc t1 a1)) t2 = Node2 (conv t1) a1 t2 -> knil (Two (Snoc (N2 t1 a1 t2) a2)) t3 = Node3 (conv t1) a1 (conv t2) a2 t3 -> knil (Two (Snoc (N3 t1 a1 t2 a2 t3) a3)) t4 = Node4 (conv t1) a1 (conv t2) a2 (conv t3) a3 t4 - -convert $ fromList [1 .. 12] - -convert $ fromList [1 .. 17] -convert $ fromList [18 .. 24] -convert $ fromList [1 .. 17] <> fromList [18 .. 24] - -convert $ fst $ partition 13 (fromList [1 .. 17] <> fromList [18 .. 24]) -convert $ snd $ partition 13 (fromList [1 .. 17] <> fromList [18 .. 24]) - -%endif diff --git a/Swish/HaskellRDF/Sort/MergeSort.lhs b/Swish/HaskellRDF/Sort/MergeSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/MergeSort.lhs +++ /dev/null @@ -1,295 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Sorting by merging} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.MergeSort -> where -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.ListLib - -> infixr {-"\,"-} `merge`, \+/ - -%align 33 - -> sort :: (Ord a) => [a] -> [a] -> sort = bottomUpMergeSort - -%-------------------------------= -------------------------------------------- -\section{Top-down merge sort} -%-------------------------------= -------------------------------------------- - -The archetypical functional sorting algorithm is without any doubt -merge sort. It follows the divide and conquer scheme: the input list is -split into two halves, both are sorted recursively and the results are -finally merged together. - -> merge :: (Ord a) => [a] -> [a] -> [a] -> merge = mergeBy (<=) -> -> (\+/) :: (Ord a) => [a] -> [a] -> [a] -> (\+/) = mergeBy (<=) -> -> mergeBy :: Rel a -> [a] -> [a] -> [a] -> mergeBy (<=) = merge -> where -> merge [] bs = bs -> merge as@(_ : _) [] = as -> merge as@(a : as') bs@(b : bs') -> | a <= b = a : merge as' bs -> | otherwise = b : merge as bs' -> -> mergeSort :: (Ord a) => [a] -> [a] -> mergeSort = mergeSortBy (<=) -> -> mergeSortBy :: Rel a -> [a] -> [a] -> mergeSortBy (<=) as -> | simple as = as -> | otherwise = mergeBy (<=) (mergeSortBy (<=) as1) -> (mergeSortBy (<=) as2) -> where (as1, as2) = halve as - -Since the divide phase takes $\Theta(n\log n)$ time, |mergeSort| is -not lazy: |head . mergeSort| has a running time of $\Theta(n\log n)$. - -%-------------------------------= -------------------------------------------- -\section{Bottom-up merge sort} -%-------------------------------= -------------------------------------------- - -The function |bottomUpMergeSort| improves the divide phase to -$\Theta(n)$ and is consequently asymptotically optimal, stable, and -lazy, but alas not in any way adaptive. - -> bottomUpMergeSort :: (Ord a) => [a] -> [a] -> bottomUpMergeSort = bottomUpMergeSortBy (<=) -> -> bottomUpMergeSortBy :: Rel a -> [a] -> [a] -> bottomUpMergeSortBy (<=) = gfoldm [] (\a -> [a]) (mergeBy (<=)) - -%-------------------------------= -------------------------------------------- -\section{Straight merge sort} -%-------------------------------= -------------------------------------------- - -Both |mergeSort| and |bottomUpMergeSort| take $\Theta(n\log n)$ -irrespective of the presortedness of the input. If we replace the test -|simple| by |ordered| we obtain an adaptive variant which is optimal -with respect to the measure |Runs| and adaptive wrt |Inv| and |Rem| -\cite[p.~449]{ECW92Sur}. - -> straightMergeSort :: (Ord a) => [a] -> [a] -> straightMergeSort = straightMergeSortBy (<=) - -> straightMergeSortBy :: Rel a -> [a] -> [a] -> straightMergeSortBy (<=) as -> | orderedBy (<=) as = as -> | otherwise = mergeBy (<=) (straightMergeSortBy (<=) as1) -> (straightMergeSortBy (<=) as2) -> where (as1, as2) = halve as - -\Todo{To adapt to ascending as well as descending sequences we could -reverse the sublists in every step and apply Augustson's -stable/anti-stable trick.} - -%-------------------------------= -------------------------------------------- -\section{Odd-even merge sort} -%-------------------------------= -------------------------------------------- - -If we use a different partioning scheme, |uninterleave| instead of -|halve|, we obtain an adaptive variant which is optimal wrt |Dis = Max| -\cite[p.~450]{ECW92Sur}. - -> oddEvenMergeSort :: (Ord a) => [a] -> [a] -> oddEvenMergeSort = oddEvenMergeSortBy (<=) -> -> oddEvenMergeSortBy :: Rel a -> [a] -> [a] -> oddEvenMergeSortBy (<=) as -> | orderedBy (<=) as = as -> | otherwise = mergeBy (<=) (oddEvenMergeSortBy (<=) as1) -> (oddEvenMergeSortBy (<=) as2) -> where (as1, as2) = uninterleave as - -Unfortunately, |oddEvenMergeSort| is no longer stable. Consider, for -instance, |uninterleave [a1, a2, a3] = ([a1, a3], [a2])| and assume -that the three elements are equal. However, |oddEvenMergeSort| can be -improved so that the divide phase takes only linear time. This is left -as an instructive exercise to the reader. - -%-------------------------------= -------------------------------------------- -\section{Split sort} -%-------------------------------= -------------------------------------------- - -A partioning scheme which adapts to |Rem| was given by Levcopoulos -and Petersson \cite[p.~451]{ECW92Sur} and is based on a method by -Cook and Kim for removing $\Theta(|Rem(as)|)$ elements from a list -|as|, such that an ordered sequence is left over. - -The function |lpDivision as| divides its input into three lists |g|, -|s|, and |l| such that |s| is sorted and |g| and |l| have the same -length which is at most |Rem(as)|. The tricky thing is to ensure that -the splitting is performed in a stable way, ie the order in which the -elements in |g| and |l| appear is the same in which they appear in -|as|. Consider the sequence |1 2 5 1 4 3 1 9 2 8 9 1|: -% -\[ -\begin{array}{l||l||r} -\text{|g| and |s|} & |l| & |as| \\\hline -|1 2 5| & & |1 4 3 1 9 2 8 9 1| \\ -|1 2 [5]| & |1| & |4 3 1 9 2 8 9 1| \\ -|1 2 [5] 4| & |1| & |3 1 9 2 8 9 1| \\ -|1 2 [5 4]| & |3 1| & |1 9 2 8 9 1| \\ -|1 [2 5 4]| & |1 3 1| & |9 2 8 9 1| \\ -|1 [2 5 4] 9| & |1 3 1| & |2 8 9 1| \\ -|1 [2 5 4 9]| & |2 1 3 1| & |8 9 1| \\ -|1 [2 5 4 9] 8| & |2 1 3 1| & |9 1| \\ -|1 [2 5 4 9] 8 9| & |2 1 3 1| & |1| \\ -|1 [2 5 4 9] 8 [9]| & |1 2 1 3 1| & -\end{array} -\] -The data type |Region| is designed to represent |g| and |s|. Elements -in |g| are grouped to allow for efficient access to the last element in -|s|. For instance, |1 [2 5 4 9] 8 [9]| is essentially represented by |G -(S (G (S Nil 1) [2, 5, 4, 9]) 8) [9]|. - -> type Sequ a = [a] -> [a] -> -> data Region a = Nil -> | S (Region a) a -> | G (Region a) (Sequ a) -> -> single :: a -> Sequ a -> single a = \x -> a : x -> -> g :: Region a -> Sequ a -> Region a -> g Nil gs = G Nil gs -> g (S s a) gs = G (S s a) gs -> g (G s gs1) gs2 = G s (gs1 . gs2) -> -> lpDivisionBy :: Rel a -> [a] -> ([a], [a], [a]) -> lpDivisionBy (<=) [] = ([], [], []) -> lpDivisionBy (<=) (a : as) = lp (S Nil a) [] as -> where -> lp s l [] = (g [], reverse s', reverse l) -> where (g, s') = lpPart s -> lp Nil l (a : as) = lp (S Nil a) l as -> lp s@(G Nil gs) l (a : as)= lp (S s a) l as -> lp s@(G (S s' m) gs) l (a : as) -> | m <= a = lp (S s a) l as -> | otherwise = lp (g s' (single m . gs)) (a : l) as -> lp (G (G _ _) _) _ (_ : _)= error "lp" -> lp s@(S s' m) l (a : as) -> | m <= a = lp (S s a) l as -> | otherwise = lp (g s' (single m)) (a : l) as -> -> lpPart :: Region a -> ([a] -> [a], [a]) -> lpPart Nil = (id, []) -> lpPart (S s a) = (g, a : s') -> where (g, s') = lpPart s -> lpPart (G s gs) = (gs . g, s') -> where (g, s') = lpPart s - -Unfortunately, the relative order between equal elements in |g ++ s ++ l| -is not the same as in |as|. Hence, |lpMergeSort| is not stable either. - -> lpMergeSort :: (Ord a) => [a] -> [a] -> lpMergeSort = lpMergeSortBy (<=) -> -> lpMergeSortBy :: Rel a -> [a] -> [a] -> lpMergeSortBy (<=) as -> | simple as = as -> | otherwise = mergeBy (<=) (lpMergeSortBy (<=) as1) -> (mergeBy (<=) s (lpMergeSortBy (<=) as2)) -> where (as1, s, as2) = lpDivisionBy (<=) as - -\Todo{To adapt to ascending as well as descending sequences we could -reverse the sublists in every step. \NB stability is already lost.} - -%-------------------------------= -------------------------------------------- -\section{Adaptive merge sort} -%-------------------------------= -------------------------------------------- -%format sort1 = sort "_1" -%format sort2 = sort "_2" -%format sort3 = sort "_3" - -If we combine |halve|, |uninterleave|, and |lpDivision| we obtain -a sorting algorithm which is adaptive wrt |Exc|, |Dis|, |Inv|, |Rem|, -and |Runs| \cite[p.~451]{ECW92Sur}. - -> adaptiveMergeSort :: (Ord a) => [a] -> [a] -> adaptiveMergeSort = adaptiveMergeSortBy (<=) -> -> adaptiveMergeSortBy :: Rel a -> [a] -> [a] -> adaptiveMergeSortBy (<=) = sort1 -> where -> (\+/) = mergeBy (<=) -> -> sort1 as -> | simple as = as -> | otherwise = sort2 as1 \+/ s \+/ sort2 as2 -> where (as1, s, as2) = lpDivisionBy (<=) as -> -> sort2 as = sort3 as1 \+/ sort3 as2 -> where (as1, as2) = uninterleave as -> -> sort3 as = sort1 as1 \+/ sort1 as2 -> where (as1, as2) = halve as - -\Todo{How about reversing the lists in the first step in order to adapt -to descending sequences as well? cf.~\cite[p.~52]{ECW91Pra}} - -%-------------------------------= -------------------------------------------- -\section{Natural merge sort} -%-------------------------------= -------------------------------------------- - -The function |straightMergeSort| somehow guesses the number of runs. It is -more efficient to group the input into runs beforehand. - -> naturalMergeSort :: (Ord a) => [a] -> [a] -> naturalMergeSort = naturalMergeSortBy (<=) -> -> naturalMergeSortBy :: Rel a -> [a] -> [a] -> naturalMergeSortBy (<=) = foldm (mergeBy (<=)) [] . runsBy (<=) -> -> runsBy :: Rel a -> [a] -> [[a]] -> runsBy (<=) [] = [[]] -> runsBy (<=) (a : as) = upRun a [] as -> where -> upRun m r [] = [reverse (m : r)] -> upRun m r (a : as) -> | m <= a = upRun a (m : r) as -> | otherwise = reverse (m : r) : upRun a [] as - -Natural merge sort was first studied in the context of external -sorting. The hbc library contains a similar function. - -The function |runs| recognized only ascending runs. With little -additional effort we can also detect descending runs. - -> symmetricNaturalMergeSort :: (Ord a) => [a] -> [a] -> symmetricNaturalMergeSort = symmetricNaturalMergeSortBy (<=) -> -> symmetricNaturalMergeSortBy :: Rel a -> [a] -> [a] -> symmetricNaturalMergeSortBy (<=) -> = foldm (mergeBy (<=)) [] . upDownRunsBy (<=) -> -> upDownRunsBy :: Rel a -> [a] -> [[a]] -> upDownRunsBy (<=) [] = [] -> upDownRunsBy (<=) (a : as) = upDownRun a as -> where -> upDownRun a [] = [[a]] -> upDownRun a1 (a2 : as) -> | a1 <= a2 = upRun a2 [a1] as -> | otherwise = downRun a2 [a1] as -> upRun m r [] = [reverse (m : r)] -> upRun m r (a : as) -> | m <= a = upRun a (m : r) as -> | otherwise = reverse (m : r) : upDownRun a as -> -> downRun m r [] = [m : r] -> downRun m r (a : as) -> | m <= a = (m : r) : upDownRun a as -> | otherwise = downRun a (m : r) as - -\NB To preserve stability |downRun| uses only \emph{strictly} -decreasing sequences: |[n, n, n-1, n-1, .. 1, 1]| is split into |n| -runs. Does anybody know of a better solution? diff --git a/Swish/HaskellRDF/Sort/PairingHeap.lhs b/Swish/HaskellRDF/Sort/PairingHeap.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/PairingHeap.lhs +++ /dev/null @@ -1,88 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Pairing heaps} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.PairingHeap -> where -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.ListLib (treefold) -> infixr {-"\,"-} \+/ - -%align 33 - -Sorting based on pairing heaps \cite[p.~52]{Oka98Pur} performs -extremely well in practice and it combines many virtues: it is -asymptotically optimal (at least |pairingSort|, for |mpPairingSort| -which is based on multi-pass pairing heaps no tight theoretical bounds -are known), it is lazy and I conjecture that it adapts to the input. -However, to the best of my knowledge this has not been shown. On the -negative side, it is not stable which is typical for sorting algorithms -based on priority queues. - -> data PairingHeap a = Empty -> | Node a [PairingHeap a] - -\NB The constructor |Empty| is only used on the top-level, it never -appears below a |Node|. - -> leaf :: a -> PairingHeap a -> leaf a = Node a [] -> -> (\+/) :: (Ord a) => PairingHeap a -> PairingHeap a -> PairingHeap a -> (\+/) = meldBy (<=) -> -> meldBy :: Rel a -> PairingHeap a -> PairingHeap a -> PairingHeap a -> meldBy (<=) Empty u = u -> meldBy (<=) t@(Node _ _) Empty= t -> meldBy (<=) t@(Node a ts) u@(Node b us) -> | a <= b = Node a (u : ts) -> | otherwise = Node b (t : us) -> -> pairingSort :: (Ord a) => [a] -> [a] -> pairingSort = pairingSortBy (<=) -> -> pairingSortBy :: Rel a -> [a] -> [a] -> pairingSortBy (<=) = unHeap . meldAll . map leaf -> where -> (\+/) = meldBy (<=) - -Different variants of pairing heaps differ in the implementation of -|meldAll|. - -> meldAll [] = Empty -> meldAll [t] = t -> meldAll (t1 : t2 : ts) = (t1 \+/ t2) \+/ meldAll ts - -Note that subsequent trees are first paired using |meld|, hence the -name of the data structure. - -> unHeap Empty = [] -> unHeap (Node a ts) = a : unHeap (meldAll ts) - -What about the running time? Fredman et al~\cite{FSS86Pai} show that -|meld| and |splitMin| run in $O(\log n)$ amortized time. Hence we have -$O(n\log n)$ worst case behaviour. \NB Chris Okasaki has developed a -persistent variant of pairing heaps~\cite{Oka96Fun} which might be -worth trying, as well. - -The function |meldAll| corresponds to |foldr meld empty . pairfold -meld|. Alternatively, one can make repeated passes over the trees using -|treefold meld empty|. - -> mpPairingSort :: (Ord a) => [a] -> [a] -> mpPairingSort = mpPairingSortBy (<=) -> -> mpPairingSortBy :: Rel a -> [a] -> [a] -> mpPairingSortBy (<=) = unHeap . meldAll . map leaf -> where -> meldAll = treefold (meldBy (<=)) Empty -> unHeap Empty = [] -> unHeap (Node a ts) = a : unHeap (meldAll ts) - -Fredman et al~\cite{FSS86Pai} state that the multipass variant is not -easy to analyse which is certainly true. They only succeeded in proving -an $O(\log n\log\log n/\log\log\log n)$ bound on the amortized time per -heap operation. Hence it is not clear whether |mpPairingSort| is an -$O(n\log n)$ algorithm. diff --git a/Swish/HaskellRDF/Sort/QuickSort.lhs b/Swish/HaskellRDF/Sort/QuickSort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/QuickSort.lhs +++ /dev/null @@ -1,170 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Partioning sort} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.QuickSort -> where -> import Swish.HaskellRDF.Sort.MergeSort (mergeSortBy) -> import Data.List -> import Swish.HaskellRDF.Sort.LibBase - -%align 33 - -%-------------------------------= -------------------------------------------- -\section{Some variations of quick sort} -%-------------------------------= -------------------------------------------- -%format qsort1 = qsort "_1" -%format qsort2 = qsort "_2" -%format qsort3 = qsort "_3" - -This section lists some variants of quick sort which \emph{cannot be -recommended} for use. The first and probably the most popular of all -appears in \cite[p.~154]{BiW88}, \cite[p.~128]{HinFun92}, -\cite[p.~433]{Tho96Has}, and \cite[p.~9]{HPF97Gen}. - -> qsort1 :: (Ord a) => [a] -> [a] -> qsort1 [] = [] -> qsort1 (p : as) = qsort1 [ a | a <- as, a < p ] -> ++ p : qsort1 [ a | a <- as, p <= a ] - -Its main purpose is probably to demonstrate the use and elegancy of -list comprehensions. The definition has, however, several drawbacks -part from the fact that quick sort is not asymptotically optimal. -% -\begin{enumerate} -\item -it traverses the list twice, - -\item -it has a space leak: |as| is alive until the second traversal is done -\cite[p.~18]{Bir96Fun}, - -\item -it uses |(++)| to catenate the results of the recursive calls (note that -|(++)| takes time proportional to the length of its first argument). -\end{enumerate} - -The second variant uses the library function |partition| to avoid the -double traversal. - -> qsort2 :: (Ord a) => [a] -> [a] -> qsort2 [] = [] -> qsort2 (p : as) = qsort2 l ++ p : qsort2 r -> where (l, r) = partition (< p) as - -And finally, here is a variant which employs a tail recursive partition -function. - -> qsort3 :: (Ord a) => [a] -> [a] -> qsort3 [] = [] -> qsort3 [a] = [a] -> qsort3 (p : as) = partition [] [] as -> where -> partition l r [] = qsort3 l ++ p : qsort3 r -> partition l r (a : as) -> | p <= a = partition l (a : r) as -> | otherwise = partition (a : l) r as - -Note however that |qsort3| is no longer stable since |l| and |r| are in -reverse order. - -%-------------------------------= -------------------------------------------- -\section{Paulson's quicksort} -%-------------------------------= -------------------------------------------- - -The following code is adpated from \cite[p.~110]{Pau96ML}. The main -difference to |qsort3| is that it uses an accumulating argument to -eliminate the calls to |(++)|. - -> quickSort :: (Ord a) => [a] -> [a] -> quickSort = quickSortBy (<=) -> -> quickSortBy :: Rel a -> [a] -> [a] -> quickSortBy (<=) as = qsort as [] -> where -> qsort [] x = x -> qsort [a] x = a : x -> qsort (p : as) x = partition [] [] as -> where -> partition l r [] = qsort l (p : qsort r x) -> partition l r (a : as) -> | p <= a = partition l (a : r) as -> | otherwise = partition (a : l) r as - -%-------------------------------= -------------------------------------------- -\section{Augustsson's stable quicksort} -%-------------------------------= -------------------------------------------- - -Neither |qsort3| nor |quickSort| is stable. This is due to the fact -that partition reverses the order of elements (the lists |l| and |r| -are used as a stack). By duplicating the code into a stable and an -anti-stable variant we obtain stability. - -> stableQuickSort :: (Ord a) => [a] -> [a] -> stableQuickSort = stableQuickSortBy (<=) -> -> stableQuickSortBy :: Rel a -> [a] -> [a] -> stableQuickSortBy (<=) as = qsortBy (<=) as [] -> -> qsortBy :: Rel a -> [a] -> [a] -> [a] -> qsortBy (<=) [] x = x -> qsortBy (<=) [a] x = a : x -> qsortBy (<=) (p : as) x = partition [] [] as -> where - -The function |partition| partitions and sorts the sublists. Note that -|l| and |r| are in reverse order and must be sorted with an anti-stable -sorting. - -> partition l r [] = rqsortBy (<=) l (p : rqsortBy (<=) r x) -> partition l r (a : as) -> | p <= a = partition l (a : r) as -> | otherwise = partition (a : l) r as - -The function |rqsortBy| is as |qsort| but anti-stable, ie it reverses -equal elements (compare the last two equations of |partition|). - -> rqsortBy :: Rel a -> [a] -> [a] -> [a] -> rqsortBy (<=) [] x = x -> rqsortBy (<=) [a] x = a : x -> rqsortBy (<=) (p : as) x = partition [] [] as -> where -> partition l r [] = qsortBy (<=) l (p : qsortBy (<=) r x) -> partition l r (a : as) -> | a <= p = partition (a : l) r as -> | otherwise = partition l (a : r) as - -%-------------------------------= -------------------------------------------- -\section{Introspective quicksort} -%-------------------------------= -------------------------------------------- - -One of the big disadvantages of quick sort is its quadratic worst-case -behaviour. It turns out that it is quite easy to solve this dilemma: -simply limit the recursion depth to a fixed bound, and for subproblems -which exceed the limit use an $\Theta(n\lg n)$ algorithm -\cite{Mus97Int}. - -> introSort :: (Ord a) => [a] -> [a] -> introSort = introSortBy (<=) - -> introSortBy :: Rel a -> [a] -> [a] -> introSortBy (<=) as = isort (2 * floorLg (length as)) as [] -> where -> isort 0 as x = mergeSortBy (<=) as ++ x -> isort (d + 1) [] x = x -> isort (d + 1) [a] x = a : x -> isort (d + 1) (p : as) x = partition [] [] as -> where -> partition l r [] = isort d l (p : isort d r x) -> partition l r (a : as) -> | p <= a = partition l (a : r) as -> | otherwise = partition (a : l) r as - -Musser recommends a depth bound of |2*floor (lg n)|. - -> floorLg :: Int -> Int -> floorLg n -> | n == 1 = 0 -> | otherwise = 1 + floorLg (n `div` 2) diff --git a/Swish/HaskellRDF/Sort/RedBlackTree.lhs b/Swish/HaskellRDF/Sort/RedBlackTree.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/RedBlackTree.lhs +++ /dev/null @@ -1,119 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Red-black trees} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.RedBlackTree -> where -> import Swish.HaskellRDF.Sort.LibBase - -%align 33 - -Every search tree scheme can be used for sorting: the elements are -repeatedly inserted into an empty initial tree; an inorder traversal of -the final tree yields the desired ordered permutation of the input. -Here we use red-black trees as described by Chris Okasaki -\cite[p.~24]{Oka98Pur}. - -Sorting on the basis of red-black trees is asymptotically optimal and -stable but neither adpative nor lazy. - -> data RedBlackTree a = Empty -> | Red (RedBlackTree a) a (RedBlackTree a) -> | Black (RedBlackTree a) a (RedBlackTree a) - -\NB For reasons of efficiency nodes do not have a separate color field, -instead the color is coded into the constructor. - -> insertBy :: Rel a -> a -> RedBlackTree a -> RedBlackTree a -> insertBy (<=) a t = blacken (ins t) -> where ins Empty = Red Empty a Empty -> ins (Red l b r) -> | a <= b = Red (ins l) b r -> | otherwise = Red l b (ins r) -> ins (Black l b r) -> | a <= b = lblack (ins l) b r -> | otherwise = rblack l b (ins r) -> -> blacken :: RedBlackTree a -> RedBlackTree a -> blacken (Red l a r) = Black l a r -> blacken t = t - -%align 49 -{\setlength{\lwidth}{\lwidth + 1cm} - -> lblack :: RedBlackTree a -> a -> RedBlackTree a -> RedBlackTree a -> lblack (Red (Red t1 a1 t2) a2 t3) a3 t4 = Red (Black t1 a1 t2) a2 (Black t3 a3 t4) -> lblack (Red t1 a1 (Red t2 a2 t3)) a3 t4 = Red (Black t1 a1 t2) a2 (Black t3 a3 t4) -> lblack l a r = Black l a r -> -> rblack :: RedBlackTree a -> a -> RedBlackTree a -> RedBlackTree a -> rblack t1 a1 (Red (Red t2 a2 t3) a3 t4) = Red (Black t1 a1 t2) a2 (Black t3 a3 t4) -> rblack t1 a1 (Red t2 a2 (Red t3 a3 t4)) = Red (Black t1 a1 t2) a2 (Black t3 a3 t4) -> rblack l a r = Black l a r - -} -%align 33 - -> inorder :: RedBlackTree a -> [a] -> inorder t = traverse t [] -> where -> traverse Empty x = x -> traverse (Red l a r) x = traverse l (a : traverse r x) -> traverse (Black l a r) x = traverse l (a : traverse r x) -> -> redBlackSort :: (Ord a) => [a] -> [a] -> redBlackSort = redBlackSortBy (<=) -> -> redBlackSortBy :: Rel a -> [a] -> [a] -> redBlackSortBy (<=) = inorder . foldr (insertBy (<=)) Empty - - -Note that |lblack| and |rblack| sometimes perform an unnecessary test -since both subtrees are tested for red-red violations. Here is a -variant of |insertBy| which remedies this shortcoming, albeit at the -expense of readability (this solves exercise~3.10(b) in -\cite{Oka98Pur}, the original version already solves -exercise~3.10(a)). - -> insertBy' :: Rel a -> a -> RedBlackTree a -> RedBlackTree a -> insertBy' (<=) a t = blacken (ins t) -> where -> ins Empty = Red Empty a Empty -> ins (Red l b r) = error "red node" -> ins (Black l b r) = black l b r -> -> black l b r -> | a <= b = case l of -> Empty -> Black (Red Empty a Empty) b r -> Red ll lb lr -> | a <= lb -> case ins ll of -> Red lll llb llr -> Red (Black lll llb llr) lb (Black lr b r) -> ll' -> Black (Red ll' lb lr) b r -> | otherwise -> case ins lr of -> Red lrl lrb lrr -> Red (Black ll lb lrl) lrb (Black lrr b r) -> lr' -> Black (Red ll lb lr') b r -> Black ll lb lr -> Black (black ll lb lr) b r -> | otherwise = case r of -> Empty -> Black l b (Red Empty a Empty) -> Red rl rb rr -> | a <= rb -> case ins rl of -> Red rll rlb rlr -> Red (Black l b rll) rlb (Black rlr rb rr) -> rl' -> Black l b (Red rl' rb rr) -> | otherwise -> case ins rr of -> Red rrl rrb rrr -> Red (Black l a rl) rb (Black rrl rrb rrr) -> rr' -> Black l b (Red rl rb rr') -> Black ll lb lr -> Black l b (black ll lb lr) -> -> redBlackSort' :: (Ord a) => [a] -> [a] -> redBlackSort' = redBlackSortBy (<=) -> -> redBlackSortBy' :: Rel a -> [a] -> [a] -> redBlackSortBy' (<=) = inorder . foldr (insertBy' (<=)) Empty - -Empirical tests show that the decrease in readability is not justified -or counterbalanced by an increase in speed: |redBlackSort'| is -sometimes marginally faster, and sometimes marginally slower. -\Todo{Curiously, |redBlackSort'| outperforms |redBlackSort| on strictly -increasing sequences thereby contradicting the theory.} diff --git a/Swish/HaskellRDF/Sort/SplaySort.lhs b/Swish/HaskellRDF/Sort/SplaySort.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/SplaySort.lhs +++ /dev/null @@ -1,63 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Splay sort} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.SplaySort -> where -> import Swish.HaskellRDF.Sort.LibBase - -%align 33 - -Sorting on the basis on splay trees has most of the desired features: -is asymptotically optimal, stable and it adapts to the input. In fact, -it has been conjectured \cite{MEP96Spl} that it is optimatically -adaptive to all accepted measures of presortedness. The following code -is due to Chris Okasaki \cite[p.~46]{Oka98Pur}. - -> data SplayTree a = Empty -> | Bin (SplayTree a) a (SplayTree a) -> -> insertBy :: Rel a -> a -> SplayTree a -> SplayTree a -> insertBy (<=) a t = Bin lt a ge -> where (lt, ge) = partBy (<=) a t - -\NB |lt| means \U{l}ess \U{t}han and |ge| means \U{g}reater \U{e}qual. - -> partBy :: Rel a -> a -> SplayTree a -> (SplayTree a, SplayTree a) -> partBy (<=) k Empty = (Empty, Empty) -> partBy (<=) k t@(Bin l a r) -> | k <= a = case l of -> Empty -> (Empty, t) -> Bin ll la lr -> | k <= la -> let (lt, ge) = partBy (<=) k ll in (lt, Bin ge la (Bin lr a r)) -> | otherwise -> let (lt, ge) = partBy (<=) k lr in (Bin ll la lt, Bin ge a r) -> | otherwise = case r of -> Empty -> (t, Empty) -> Bin rl ra rr -> | k <= ra -> let (lt, ge) = partBy (<=) k rl in (Bin l a lt, Bin ge ra rr) -> | otherwise -> let (lt, ge) = partBy (<=) k rr in (Bin (Bin l a rl) ra lt, ge) - -\NB Throughout the library great care is taken to ensure that the -relative order of equal elements is preserved. This is most easily -accomplished if the order of the arguments to a function reflects the -original order within the input. Consider, for example, the definition -of |insertBy|: on the left hand side |a| appears before |t|, on the -right hand side |a| appears before |ge| which may contain elements -equal to |a|. Thus, the relative order of equal elements is preserved. -That said, it is probably clear which we use |foldr| instead of |foldl| -for building trees. - -> inorder :: SplayTree a -> [a] -> inorder t = traverse t [] -> where -> traverse Empty x = x -> traverse (Bin l a r) x = traverse l (a : traverse r x) -> -> splaySort :: (Ord a) => [a] -> [a] -> splaySort = splaySortBy (<=) -> -> splaySortBy :: Rel a -> [a] -> [a] -> splaySortBy (<=) = inorder . foldr (insertBy (<=)) Empty - diff --git a/Swish/HaskellRDF/Sort/Squiggol.lhs b/Swish/HaskellRDF/Sort/Squiggol.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/Squiggol.lhs +++ /dev/null @@ -1,53 +0,0 @@ -%-------------------------------= -------------------------------------------- -\chapter{Squiggol} -%-------------------------------= -------------------------------------------- - -%align - -> module Swish.HaskellRDF.Sort.Squiggol (module Swish.HaskellRDF.Sort.Squiggol) -> where -> import Swish.HaskellRDF.Sort.ListLib (halve) -> import Swish.HaskellRDF.Sort.MergeSort (merge) - -%align 33 -%format (cata (x)) = "\llparenthesis " x "\rrparenthesis " -%format (ana (x)) = "\llbracket " x "\rrbracket " -%format phi = "\varphi " -%format psi = "\psi " -%format (In (a)) = a - -The squiggol approach to sorting. - -> newtype Mu f = In (f (Mu f)) -> -> cata :: (Functor f) => (f a -> a) -> Mu f -> a -> cata phi (In x) = phi (fmap (cata phi) x) -> -> ana :: (Functor f) => (a -> f a) -> a -> Mu f -> ana psi x = In (fmap (ana psi) (psi x)) -> -> data Cell a list = Nil | Cons a list -> -> type List a = Mu (Cell a) - -> data Node a bush = Empty | Leaf a | Fork bush bush -> -> instance Functor (Node a) where -> fmap f Empty = Empty -> fmap f (Leaf a) = Leaf a -> fmap f (Fork b1 b2) = Fork (f b1) (f b2) -> -> type Bush a = Mu (Node a) - -> mergeSort :: (Ord a) => [a] -> [a] -> mergeSort = cata join . ana split - -> split :: [a] -> Node a [a] -> split [] = Empty -> split [a] = Leaf a -> split as = uncurry Fork (halve as) - -> join :: (Ord a) => Node a [a] -> [a] -> join Empty = [] -> join (Leaf a) = [a] -> join (Fork l r) = merge l r diff --git a/Swish/HaskellRDF/Sort/Stable.lhs b/Swish/HaskellRDF/Sort/Stable.lhs deleted file mode 100644 --- a/Swish/HaskellRDF/Sort/Stable.lhs +++ /dev/null @@ -1,58 +0,0 @@ -> module Swish.HaskellRDF.Sort.Stable (module Swish.HaskellRDF.Sort.Stable) -> where -> import Data.List (group) -> import Swish.HaskellRDF.Sort.ListLib -> import Swish.HaskellRDF.Sort.LibBase -> import Swish.HaskellRDF.Sort.PairingHeap - -Datentypen, um Stabilit"at zu testen. - -> data With a b = a :- b -> deriving (Show) -> -> sat :: With a b -> b -> sat (_ :- s) = s - -> instance (Eq a) => Eq (With a b) where -> a :- _ == b :- _ = a == b -> -> instance (Ord a) => Ord (With a b) where -> a :- _ <= b :- _ = a <= b - -> number :: (Enum b, Num b) => [a] -> [With a b] -> number as = [ a :- i | (a, i) <- zip as [1 ..] ] - -> isStable :: (Num a, Num b, Enum b, Eq c, Ord d) -> => ([With a b] -> [With c d]) -> [([a],[With c d])] -> isStable sort = [ (as, s) -> | as <- perms [1, 1, 2, 2, 2], -> let as' = number as, -> let s = sort as', -> not (stable s) ] - -> stable :: (Eq a, Ord b) => [With a b] -> Bool -> stable as = and [ ordered (map sat g) | g <- group as ] - -%if False - -> {- -> data A = A1 | A2 | A3 -> -> instance Eq A where -> _ == _ = True -> -> instance Ord A where -> compare _ _ = EQ - -> eq A1 A1 = True -> eq A2 A2 = True -> eq A3 A3 = True -> eq _ _ = False -> -> equal as1 as2 = and [ eq a1 a2 | (a1, a2) <- zip as1 as2 ] - -[ (as, s) | as <- perms [A1, A2, A3], let s = heapSort as, not (equal as s) ] - -> -} - -%endif diff --git a/Swish/HaskellRDF/Swish.hs b/Swish/HaskellRDF/Swish.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Swish.hs +++ /dev/null @@ -1,122 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: Swish.hs,v 1.11 2004/01/09 14:36:33 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Swish --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module is a wrapper for the main program of Swish. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.Swish where --- module Main where WNH RIP OUT!!!! - -import Swish.HaskellRDF.SwishMain - - -import System.Environment - ( getArgs ) - -import System.Exit - ( ExitCode(ExitSuccess,ExitFailure), exitWith ) - - ------------------------------------------------------------- --- 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 { - putStrLn ("Swish-0.2.1 CLI\n\n") - ; - args <- getArgs - ; code <- runSwishArgs args - ; if code == ExitSuccess then - return () - else - if code == (ExitFailure 1) then - putStrLn $ "Swish: graphs compare different" - else - putStrLn $ "Swish: "++show code - ; exitWith code - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Swish.hs,v $ --- $Author: graham $ --- $Revision: 1.11 $ --- $Log: Swish.hs,v $ --- Revision 1.11 2004/01/09 14:36:33 graham --- Revert Swish.hs and Sw3ishtestAll.hs to declare module Main. --- GHC compilation without -main-is option. Tests OK. --- --- Revision 1.10 2004/01/06 16:29:56 graham --- Fix up module exports to avoid GHC warnings --- --- Revision 1.9 2003/09/24 18:50:53 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.8 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.7 2003/05/29 12:39:49 graham --- Improved error handling for stand-alone swish program --- --- Revision 1.6 2003/05/29 11:52:41 graham --- Juggle Swish code: SwishMain.hs is main program logic, with --- Swish.hs and SwishTest.hs being alternative "Main" modules for --- the real program and test harness respectively. --- --- Revision 1.5 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.4 2003/05/23 00:02:42 graham --- Fixed blank node id generation bug in N3Formatter --- --- Revision 1.3 2003/05/21 13:34:13 graham --- Various N3 parser bug fixes. --- Need to fix handling of :name terms. --- --- Revision 1.2 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.1 2003/05/20 17:30:48 graham --- Initial swish program skeleton runs using isolated tests under Hugs --- diff --git a/Swish/HaskellRDF/SwishCommands.hs b/Swish/HaskellRDF/SwishCommands.hs deleted file mode 100644 --- a/Swish/HaskellRDF/SwishCommands.hs +++ /dev/null @@ -1,451 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: SwishCommands.hs,v 1.14 2004/02/11 14:19:36 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishCommands --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- SwishCommands: functions to deal with indivudual Swish command options. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.SwishCommands - ( swishFormat - , swishInput - , swishOutput - , swishMerge - , swishCompare - , swishGraphDiff - , swishScript - ) -where - -import Swish.HaskellRDF.SwishMonad - ( SwishStateIO, SwishState(..) - , setFormat, setGraph - , resetInfo, resetError, setExitcode - , SwishFormat(..) - , swishError - , reportLine - ) - -import Swish.HaskellRDF.SwishScript - ( parseScriptFromString - ) - -import Swish.HaskellRDF.GraphPartition - ( GraphPartition(..) - , partitionGraph, comparePartitions - , partitionShowP - ) - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph, merge ) - -import Swish.HaskellRDF.N3Formatter - ( formatGraphAsShowS ) - -import Swish.HaskellRDF.N3Parser - ( parseN3fromString ) - -import Swish.HaskellRDF.GraphClass - ( LDGraph(..) - , Label(..) - ) - -import Swish.HaskellUtils.ErrorM( ErrorM(..) ) - -import System.IO - ( Handle, openFile, IOMode(..) - , hPutStr, hPutStrLn, hClose, hGetContents - , hIsReadable, hIsWritable - , stdin, stdout, stderr - ) - -import Control.Monad.Trans( MonadTrans(..) ) - -import Control.Monad.State - ( modify, gets - ) - -import Data.Maybe - ( Maybe(..), isJust, fromJust ) - -import Control.Monad - ( when ) - -import System.Exit - ( ExitCode(..) ) - -import System.IO.Error - ------------------------------------------------------------- --- Set file format to supplied value ------------------------------------------------------------- - -swishFormat :: SwishFormat -> SwishStateIO () -swishFormat fmt = modify $ setFormat fmt - ------------------------------------------------------------- --- Read graph from named file ------------------------------------------------------------- - -swishInput :: String -> SwishStateIO () -swishInput fnam = - do { maybegraph <- swishReadGraph fnam - ; case maybegraph of - Just g -> modify $ setGraph g - _ -> return () - } - ------------------------------------------------------------- --- Merge graph from named file ------------------------------------------------------------- - -swishMerge :: String -> SwishStateIO () -swishMerge fnam = - do { maybegraph <- swishReadGraph fnam - ; case maybegraph of - Just g -> modify $ mergeGraph g - _ -> return () - } - -mergeGraph gr state = state { graph = newgr } - where - newgr = merge gr (graph state) - ------------------------------------------------------------- --- Compare graph from named file ------------------------------------------------------------- - -swishCompare :: String -> SwishStateIO () -swishCompare fnam = - do { maybegraph <- swishReadGraph fnam - ; case maybegraph of - Just g -> compareGraph g - _ -> return () - } - -compareGraph :: RDFGraph -> SwishStateIO () -compareGraph gr = - do { oldgr <- gets graph - ; let exitCode = if gr == oldgr then ExitSuccess - else ExitFailure 1 - ; modify $ setExitcode exitCode - } - ------------------------------------------------------------- --- Display graph differences from named file ------------------------------------------------------------- - -swishGraphDiff :: String -> SwishStateIO () -swishGraphDiff fnam = - do { maybegraph <- swishReadGraph fnam - ; case maybegraph of - Just g -> diffGraph g - _ -> return () - } - -diffGraph :: RDFGraph -> SwishStateIO () -diffGraph gr = - do { oldgr <- gets graph - ; let p1 = partitionGraph (getArcs oldgr) - ; let p2 = partitionGraph (getArcs gr) - ; let diffs = comparePartitions p1 p2 - ; maybehandleclose <- swishWriteFile "" -- null filename -> stdout - ; case maybehandleclose of - Just (h,c) -> - do { swishOutputDiffs "" h diffs - ; if c then lift $ hClose h else return () - } - _ -> return () - } - -swishOutputDiffs :: (Label lb) => - String -> Handle - -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] - -> SwishStateIO () -swishOutputDiffs fnam hnd diffs = - do { lift $ hPutStrLn hnd ("Graph differences: "++show (length diffs)) - ; sequence_ $ map (swishOutputDiff fnam hnd) (zip [1..] diffs) - } - -swishOutputDiff :: (Label lb) => - 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) => - String -> Handle -> Maybe (GraphPartition lb) -> SwishStateIO () -swishOutputPart fnam hnd part = - do { let out = case part of - Just p -> partitionShowP "\n" p - Nothing -> "\n(No arcs)" - ; lift $ hPutStrLn hnd out - } - ------------------------------------------------------------- --- Execute script from named file ------------------------------------------------------------- - -swishScript :: String -> SwishStateIO () -swishScript fnam = - do { scs <- swishReadScript fnam - ; sequence_ (map swishCheckResult scs) - } - -swishReadScript :: String -> SwishStateIO [SwishStateIO ()] -swishReadScript fnam = - do { maybefile <- swishOpenFile fnam - ; case maybefile of - Just (h,i) -> - do { res <- swishParseScript fnam i - ; lift $ hClose h - ; return res - } - _ -> return [] - } - -swishParseScript :: - String -> String -> SwishStateIO [SwishStateIO ()] -swishParseScript fnam inp = - do { let base = if null fnam then Nothing else Just fnam - ; let sres = parseScriptFromString base inp - ; case sres of - Error err -> - do { swishError ("Script syntax error in file "++fnam++": "++err) 2 - ; return [] - } - Result scs -> return scs - } - -swishCheckResult :: SwishStateIO () -> SwishStateIO () -swishCheckResult swishcommand = - do { swishcommand - ; er <- gets errormsg - ; when (isJust er) $ - do { swishError (fromJust er) 5 - ; modify $ resetError - } - ; ms <- gets infomsg - ; when (isJust ms) $ - do { reportLine (fromJust ms) - ; modify $ resetInfo - } - } - ------------------------------------------------------------- --- Output graph to named file ------------------------------------------------------------- - -swishOutput :: String -> SwishStateIO () -swishOutput fnam = - do { maybehandleclose <- swishWriteFile fnam - ; case maybehandleclose of - Just (h,c) -> - do { swishOutputGraph fnam h - ; if c then lift $ hClose h else return () - } - _ -> return () - } - -swishOutputGraph :: String -> Handle -> SwishStateIO () -swishOutputGraph fnam hnd = - do { fmt <- gets $ format - ; case fmt of - N3 -> swishFormatN3 fnam hnd - _ -> swishError - ("Unsupported file format: "++(show fmt)) 4 - } - -swishFormatN3 :: String -> Handle -> SwishStateIO () -swishFormatN3 fnam hnd = - do { out <- gets $ formatGraphAsShowS . graph - ; lift $ hPutStr hnd (out "") - } - ------------------------------------------------------------- --- Common input functions ------------------------------------------------------------- --- --- Keep the logic separate for reading file data and --- parsing it to an RDF graph value. - -swishReadGraph :: String -> SwishStateIO (Maybe RDFGraph) -swishReadGraph fnam = - do { maybefile <- swishOpenFile fnam - ; case maybefile of - Just (h,i) -> - do { res <- swishParse fnam i - ; lift $ hClose h - ; return res - } - _ -> return Nothing - } - --- Open and read file, returning its handle and content, or Nothing --- WARNING: the handle must not be closed until input is fully evaluated -swishOpenFile :: String -> SwishStateIO (Maybe (Handle,String)) -swishOpenFile fnam = - do { (hnd,hop) <- lift $ - if null fnam then - return (stdin,True) - else - do { o <- try (openFile fnam ReadMode) - ; case o of - Left e -> return (stdin,False) - Right h -> return (h,True) - } - ; hrd <- lift $ hIsReadable hnd - ; res <- if hop && hrd then - do { - ; fc <- lift $ hGetContents hnd - ; return $ Just (hnd,fc) - } - else - do { lift $ hClose hnd - ; swishError ("Cannot read file: "++fnam) 3 - ; return Nothing - } - ; return res - } - -swishParse :: String -> String -> SwishStateIO (Maybe RDFGraph) -swishParse fnam inp = - do { fmt <- gets $ format - ; case fmt of - N3 -> swishParseN3 fnam inp - _ -> - do { swishError ("Unsupported file format: "++(show fmt)) 4 - ; return Nothing - } - } - -swishParseN3 :: String -> String -> SwishStateIO (Maybe RDFGraph) -swishParseN3 fnam inp = - do { let pres = parseN3fromString inp - ; case pres of - Error err -> - do { swishError ("N3 syntax error in file "++fnam++": "++err) 2 - ; return Nothing - } - Result gr -> return $ Just gr - } - --- 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). -swishWriteFile :: String -> SwishStateIO (Maybe (Handle,Bool)) -swishWriteFile fnam = - do { (hnd,hop,cls) <- lift $ - if null fnam then - return (stdout,True,False) - else - do { o <- try (openFile fnam WriteMode) - ; case o of - Left e -> return (stderr,False,False) - Right h -> return (h,True,True) - } - ; hwt <- lift $ hIsWritable hnd - ; if hop && hwt then - return $ Just (hnd,cls) - else - do { if cls then lift $ hClose hnd else return () - ; swishError ("Cannot write file: "++fnam) 3 - ; return Nothing - } - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/SwishCommands.hs,v $ --- $Author: graham $ --- $Revision: 1.14 $ --- $Log: SwishCommands.hs,v $ --- Revision 1.14 2004/02/11 14:19:36 graham --- Add graph-difference option to Swish --- --- Revision 1.13 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.12 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.11 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.10 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. --- --- Revision 1.9 2003/09/24 18:50:53 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.8 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.7 2003/05/29 12:39:49 graham --- Improved error handling for stand-alone swish program --- --- Revision 1.6 2003/05/29 10:49:08 graham --- Added and tested merge option (-m) for Swish program --- --- Revision 1.5 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.4 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.3 2003/05/23 00:03:55 graham --- Added HUnit test module for swish program. --- Greatly enhanced N3Formatter tests --- --- Revision 1.2 2003/05/21 13:34:13 graham --- Various N3 parser bug fixes. --- Need to fix handling of :name terms. --- --- Revision 1.1 2003/05/20 23:36:30 graham --- Add new Swish modules --- diff --git a/Swish/HaskellRDF/SwishMain.hs b/Swish/HaskellRDF/SwishMain.hs deleted file mode 100644 --- a/Swish/HaskellRDF/SwishMain.hs +++ /dev/null @@ -1,273 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: SwishMain.hs,v 1.15 2004/02/11 17:37:02 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishMain --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- 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, Notation 3 parser --- and Notation 3 formatter modules. --- --- 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. --- I anticipate that this module may be used as a starting point for --- creating new programs rathar 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). As such, it is part of --- another experiment along the lines described in [3]. --- --- [1] Semantic werb: http://www.w3.org/2001/sw/ --- [2] CWM: http://www.w3.org/2000/10/swap/doc/cwm.html --- [3] Motivation: http://www.w3.org/2000/10/swap/doc/Motivation.html --- [4] Notation 3: http://www.w3.org/DesignIssues/Notation3.html --- [5] RDF: http://www.w3.org/RDF/ --- --- For command line details, see 'usageText' below. --- --- TODO: --- + Add RDF/XML input and output --- + Add N-triples input and output --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.SwishMain(runSwish,runSwishArgs) where - -import Swish.HaskellRDF.SwishCommands - ( swishFormat - , swishInput - , swishOutput - , swishMerge - , swishCompare - , swishGraphDiff - , swishScript - ) - -import Swish.HaskellRDF.SwishMonad - ( SwishStateIO, SwishState(..) - , emptyState - , SwishFormat(..) - , swishError - , reportLines - ) - -import Swish.HaskellUtils.ListHelpers - ( breakAll ) - -import Control.Monad.State - ( execStateT ) - -import Data.Char - ( isSpace ) - -import Control.Monad - ( when ) - -import System.Exit - ( ExitCode(ExitSuccess) ) - ------------------------------------------------------------- --- Command line description ------------------------------------------------------------- - -usageText :: [[Char]] -usageText = - [ "Swish 0.2.1" - , "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:" - , "-? display this message." - , "-n3 use Notation3 format for subsequent input and output." - , "-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." - , "" - , " 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 -n3 -i=file" - , " read file as Notation3, and report any syntax errors." - , "swich -n3 -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." - , "swish -n3 -i=file1 -o=file2" - , " read file1 as Notation3, report any syntax errors, and output the" - , " resulting graph as reformatted Notation3. (The output may be" - , " unedifying, but is intended to be used to test round-tripping" - , " of Notation 3 data. The Notation3 formatter may be improved in" - , " subsequent versions.)" - ] - ------------------------------------------------------------- --- 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. --- --- sequence_ is a Monad sequencer, returning a new monad that --- executes members of a list in turn, passing state along the --- chain. --- -swishCommands :: [String] -> SwishStateIO () -swishCommands args = - do { sequence_ (map swishCommand args) - } - -swishCommand :: String -> SwishStateIO () -swishCommand cmd = - let - (nam,more) = break (=='=') cmd - arg = drop 1 more - in - case nam of - "" -> return () -- do nothing - "-?" -> swishHelp - "-n3" -> swishFormat N3 - "-i" -> swishInput arg - "-m" -> swishMerge arg - "-c" -> swishCompare arg - "-d" -> swishGraphDiff arg - "-o" -> swishOutput arg - "-s" -> swishScript arg - _ -> swishError ("Invalid command line element: "++cmd) 4 - -swishHelp :: SwishStateIO () -swishHelp = reportLines usageText - ------------------------------------------------------------- --- Interactive test function (e.g. for use in Hugs) ------------------------------------------------------------- - -runSwish :: String -> IO ExitCode -runSwish cmdline = - do { let args = breakAll isSpace cmdline - ; ec <- runSwishArgs args - ; when (ec /= ExitSuccess) (putStrLn $ "Swish exit: "++show ec) - ; return ec - } - -runSwishArgs :: [String] -> IO ExitCode -runSwishArgs args = - do { state <- execStateT (swishCommands args) emptyState - ; return $ exitcode state - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/SwishMain.hs,v $ --- $Author: graham $ --- $Revision: 1.15 $ --- $Log: SwishMain.hs,v $ --- Revision 1.15 2004/02/11 17:37:02 graham --- Update for Swish 0.2.1 --- --- Revision 1.14 2004/02/11 14:19:36 graham --- Add graph-difference option to Swish --- --- Revision 1.13 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. --- --- Revision 1.12 2003/12/20 17:07:48 graham --- Display swish version number in usage message --- --- Revision 1.11 2003/12/20 14:34:21 graham --- Update command line options help message. --- --- Revision 1.10 2003/12/19 21:29:33 graham --- Minor edits --- --- Revision 1.9 2003/12/19 16:34:12 graham --- Add 'test' function to run SwishTest script --- --- Revision 1.8 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.7 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.6 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.5 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. --- --- Revision 1.4 2003/09/24 18:50:53 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.3 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.2 2003/05/29 12:39:49 graham --- Improved error handling for stand-alone swish program --- --- Revision 1.1 2003/05/29 11:52:41 graham --- Juggle Swish code: SwishMain.hs is main program logic, with --- Swish.hs and SwishTest.hs being alternative "Main" modules for --- the real program and test harness respectively. diff --git a/Swish/HaskellRDF/SwishMonad.hs b/Swish/HaskellRDF/SwishMonad.hs deleted file mode 100644 --- a/Swish/HaskellRDF/SwishMonad.hs +++ /dev/null @@ -1,306 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} --------------------------------------------------------------------------------- --- $Id: SwishMonad.hs,v 1.12 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishMonad --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- SwishMonad: Composed state and IO monad for Swish --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.SwishMonad - ( SwishStateIO, SwishState(..) - , setFormat, setGraph - , modGraphs, findGraph, findFormula - , modRules, findRule - , modRulesets, findRuleset - , findOpenVarModify, findDatatype - , setInfo, resetInfo, setError, resetError, setExitcode - , emptyState - , SwishFormat(..) - , NamedGraph(..) - , swishError - , reportLines, reportLine - ) -where - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph, emptyRDFGraph ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule, RDFRuleMap, RDFRuleset, RDFRulesetMap ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFOpenVarBindingModify - ) - -import Swish.HaskellRDF.BuiltInMap - ( findRDFOpenVarBindingModifier - , findRDFDatatype - , rdfRulesetMap - ) - -import Swish.HaskellRDF.Ruleset - ( getMaybeContextAxiom - , getMaybeContextRule - ) - -import Swish.HaskellRDF.Rule - ( Formula(..) - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap - , mapFindMaybe - , mapVals - ) - -import Control.Monad.Trans - ( MonadTrans(..) ) - -import Control.Monad.State - ( modify, StateT(..)) - -import System.Exit - ( ExitCode(ExitSuccess,ExitFailure) ) - -import System.IO - ( hPutStrLn, stderr ) - ------------------------------------------------------------- --- State and state monad for Swish program ------------------------------------------------------------- --- --- Uses StateT Monad transformer: --- See example by Mark Carroll at http://www.haskell.org/hawiki/MonadState - -data SwishFormat = N3 | NT | RDF - deriving (Eq, Show) - -data SwishState = SwishState - { format :: SwishFormat - , 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 :: ExitCode - } - -type SwishStateIO a = StateT SwishState IO a - -emptyState :: SwishState -emptyState = SwishState - { format = N3 - , graph = emptyRDFGraph - , graphs = emptyLookupMap - , rules = emptyLookupMap - , rulesets = rdfRulesetMap - , infomsg = Nothing - , errormsg = Nothing - , exitcode = ExitSuccess - } - -setFormat :: SwishFormat -> SwishState -> SwishState -setFormat fm state = state { format = fm } - -setGraph :: RDFGraph -> SwishState -> SwishState -setGraph gr state = state { graph = gr } - -modGraphs :: - ( NamedGraphMap -> NamedGraphMap ) -> SwishState -> SwishState -modGraphs grmod state = state { graphs = grmod (graphs state) } - -findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph] -findGraph nam state = mapFindMaybe nam (graphs state) - -findFormula :: ScopedName -> SwishState -> Maybe RDFFormula -findFormula nam state = case findGraph nam state of - Nothing -> getMaybeContextAxiom nam (mapVals $ rulesets state) - Just [] -> Just $ Formula nam emptyRDFGraph - Just grs -> Just $ Formula nam (head grs) - -modRules :: - ( RDFRuleMap -> RDFRuleMap ) -> SwishState -> SwishState -modRules rlmod state = state { rules = rlmod (rules state) } - -findRule :: ScopedName -> SwishState -> Maybe RDFRule -findRule nam state = - let - localrule = mapFindMaybe nam (rules state) - contextrule = getMaybeContextRule nam $ mapVals $ rulesets state - in - case localrule of - Nothing -> contextrule - justlr -> justlr - -modRulesets :: - ( RDFRulesetMap -> RDFRulesetMap ) -> SwishState -> SwishState -modRulesets rsmod state = state { rulesets = rsmod (rulesets state) } - -findRuleset :: - ScopedName -> SwishState -> Maybe RDFRuleset -findRuleset nam state = mapFindMaybe (snScope nam) (rulesets state) - -findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify -findOpenVarModify nam _ = findRDFOpenVarBindingModifier nam - -findDatatype :: ScopedName -> SwishState -> Maybe RDFDatatype -findDatatype nam _ = findRDFDatatype nam - -setInfo :: String -> SwishState -> SwishState -setInfo msg state = state { infomsg = Just msg } - -resetInfo :: SwishState -> SwishState -resetInfo state = state { infomsg = Nothing } - -setError :: String -> SwishState -> SwishState -setError msg state = state { errormsg = Just msg } - -resetError :: SwishState -> SwishState -resetError state = state { errormsg = Nothing } - -setExitcode :: ExitCode -> SwishState -> SwishState -setExitcode ec state = state { exitcode = ec } - - ------------------------------------------------------------- --- Data types for Swish script dictionaries ------------------------------------------------------------- --- --- The graphs dictionary contains named graphs and/or lists --- of graphs that are created and used by script statements. - -data NamedGraph = NamedGraph - { ngName :: ScopedName - , ngGraph :: [RDFGraph] - } - -instance LookupEntryClass NamedGraph ScopedName [RDFGraph] - where - keyVal (NamedGraph k v) = (k,v) - newEntry (k,v) = (NamedGraph k v) - -type NamedGraphMap = LookupMap NamedGraph - ------------------------------------------------------------- --- Report error and set exit status code ------------------------------------------------------------- - -swishError :: String -> Int -> SwishStateIO () -swishError msg sts = - do { reportLine $ msg - ; if sts == 4 then - reportLine $ "Use 'Swish -?' for help" - else - return () - ; modify $ setExitcode (ExitFailure sts) - } - ------------------------------------------------------------- --- Output text to the standard error stream ------------------------------------------------------------- --- --- Each string in the supplied list is a line of text to --- be displayed. - -reportLines :: [String] -> SwishStateIO () -reportLines text = - sequence_ (map reportLine text) - -reportLine :: String -> SwishStateIO () -reportLine line = - -- lift putStrLn line - lift $ hPutStrLn stderr line - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/SwishMonad.hs,v $ --- $Author: graham $ --- $Revision: 1.12 $ --- $Log: SwishMonad.hs,v $ --- Revision 1.12 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.11 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.10 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.9 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.8 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.7 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.6 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. --- --- Revision 1.5 2003/09/24 18:50:53 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.4 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.3 2003/05/29 12:39:49 graham --- Improved error handling for stand-alone swish program --- --- Revision 1.2 2003/05/21 13:34:13 graham --- Various N3 parser bug fixes. --- Need to fix handling of :name terms. --- --- Revision 1.1 2003/05/20 23:36:30 graham --- Add new Swish modules --- diff --git a/Swish/HaskellRDF/SwishScript.hs b/Swish/HaskellRDF/SwishScript.hs deleted file mode 100644 --- a/Swish/HaskellRDF/SwishScript.hs +++ /dev/null @@ -1,1031 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: SwishScript.hs,v 1.10 2004/02/09 22:22:44 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishScript --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- 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. --- --- The script syntax is based loosely on Notation3, and the script parser is an --- extension of the Notation3 parser in module N3Parser.hs. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.SwishScript - ( parseScriptFromString - ) -where - -import Swish.HaskellRDF.SwishMonad - ( SwishStateIO - , modGraphs, findGraph, findFormula - , modRules, findRule - , modRulesets, findRuleset - , findOpenVarModify, findDatatype - , setInfo, setError, setExitcode - , NamedGraph(..) - ) - -import Swish.HaskellRDF.RDFDatatype - ( RDFDatatype ) - -import Swish.HaskellRDF.RDFRuleset - ( RDFFormula, RDFRule - , RDFRuleset - , makeRDFClosureRule - ) - -import Swish.HaskellRDF.RDFProof - ( RDFProofStep, makeRDFProof, makeRDFProofStep ) - -import Swish.HaskellRDF.RDFVarBinding - ( RDFVarBindingModify - ) - -import Swish.HaskellRDF.RDFGraphShowM() - -import Swish.HaskellRDF.RDFGraph - ( RDFGraph, RDFLabel(..) - , emptyRDFGraph - , NamespaceMap - , setNamespaces - , merge, add - ) - -import Swish.HaskellRDF.N3Parser - ( parseAnyfromString - , N3Parser, N3State(..) - , whiteSpace, symbol, eof, identLetter - , defaultPrefix, namedPrefix - , document, subgraph, uriRef2, varid, lexUriRef - , newBlankNode - ) - -import Swish.HaskellRDF.N3Formatter - ( formatGraphAsShowS ) - -import Swish.HaskellRDF.Datatype - ( typeMkRules ) - -import Swish.HaskellRDF.Proof - ( explainProof, showsProof ) - -import Swish.HaskellRDF.Ruleset - ( makeRuleset, getRulesetRule, getMaybeContextRule ) - -import Swish.HaskellRDF.Rule - ( Formula(..), Rule(..) -- , RuleMap - ) - -import Swish.HaskellRDF.VarBinding - ( composeSequence ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - -import Swish.HaskellUtils.LookupMap - ( mapReplaceOrAdd ) - -import Swish.HaskellUtils.ListHelpers - ( equiv, flist ) - -import Swish.HaskellUtils.ErrorM - ( ErrorM(..) ) - -import Text.ParserCombinators.Parsec - ( (), (<|>) - , many, manyTill, option, sepBy, between, try, notFollowedBy - , string, char, anyChar - , getState - ) - -import Control.Monad.State - ( modify, gets, lift - -- , StateT(..), execStateT - ) - -import Control.Monad - ( when, liftM ) - -{- WNH -import System.IO - ( IOMode(..), hPutStr - , IOError, try, ioeGetErrorString - ) - -import qualified System.IO - ( IOMode(..), hPutStr - , IOError, try, ioeGetErrorString - ) - -import Directory - ( doesFileExist ) --} - - -import qualified System.IO.Error as IO - -import System.Exit - ( ExitCode(ExitFailure) ) - ------------------------------------------------------------- --- Parser for Swish script processor ------------------------------------------------------------- --- --- The parser is based on the Notation3 parser, and uses many --- of the same syntax productions, but the top-level productions used --- are quite different. - -parseScriptFromString :: Maybe String -> String -> ErrorM [SwishStateIO ()] -parseScriptFromString base inp = - case parseAnyfromString script base inp of - Left err -> Error err - Right scs -> Result scs - ----------------------------------------------------------------------- --- Syntax productions ----------------------------------------------------------------------- - -script :: N3Parser [SwishStateIO ()] -script = - do { whiteSpace - ; scs <- many command - ; eof - ; return scs - } - -command :: N3Parser (SwishStateIO ()) -command = - do { try $ symbol "@prefix" - ; ( defaultPrefix <|> namedPrefix ) - ; return $ return () - } - <|> nameItem - <|> readGraph - <|> writeGraph - <|> mergeGraphs - <|> compareGraphs - <|> assertEquiv - <|> assertMember - <|> defineRule - <|> defineRuleset - <|> defineConstraints - <|> checkProofCmd - <|> fwdChain - <|> bwdChain - - "script command" - -nameItem :: N3Parser (SwishStateIO ()) -nameItem = - -- name :- graph - -- name :- ( graph* ) - do { u <- uriRef2 - ; symbol ":-" - ; g <- graphOrList - ; return $ ssAddGraph u g - } - -readGraph :: N3Parser (SwishStateIO ()) -readGraph = - -- @read name [ ] - do { commandName "@read" - ; n <- uriRef2 - ; u <- option "" lexUriRef - ; return $ ssRead n (if null u then Nothing else Just u) - } - -writeGraph :: N3Parser (SwishStateIO ()) -writeGraph = - -- @write name [ ] ; Comment - do { commandName "@write" - ; n <- uriRef2 - ; let gs = ssGetList n :: SwishStateIO (Either String [RDFGraph]) - ; u <- option "" lexUriRef - ; symbol ";" - ; c <- restOfLine - ; let muri = if null u then Nothing else Just u - ; return $ ssWriteList muri gs c - } - -mergeGraphs :: N3Parser (SwishStateIO ()) -mergeGraphs = - -- @merge ( name* ) => name - do { commandName "@merge" - ; gs <- graphList - ; symbol "=>" - ; n <- uriRef2 - ; return $ ssMerge n gs - } - -compareGraphs :: N3Parser (SwishStateIO ()) -compareGraphs = - -- @compare name name - do { commandName "@compare" - ; n1 <- uriRef2 - ; n2 <- uriRef2 - ; return $ ssCompare n1 n2 - } - -assertEquiv :: N3Parser (SwishStateIO ()) -assertEquiv = - -- @asserteq name name ; Comment - do { commandName "@asserteq" - ; n1 <- uriRef2 - ; n2 <- uriRef2 - ; symbol ";" - ; c <- restOfLine - ; return $ ssAssertEq n1 n2 c - } - -assertMember :: N3Parser (SwishStateIO ()) -assertMember = - -- @assertin name name ; Comment - do { commandName "@assertin" - ; n1 <- uriRef2 - ; n2 <- uriRef2 - ; symbol ";" - ; c <- restOfLine - ; return $ ssAssertIn n1 n2 c - } - -defineRule :: N3Parser (SwishStateIO ()) -defineRule = - -- @rule name :- ( name* ) => name [ | ( (name var*)* ) ] - do { commandName "@rule" - ; rn <- uriRef2 - ; symbol ":-" - ; ags <- graphOrList - ; symbol "=>" - ; cg <- graphExpr - ; vms <- option [] varModifiers - ; return $ ssDefineRule rn ags cg vms - } - -defineRuleset :: N3Parser (SwishStateIO ()) -defineRuleset = - -- @ruleset name :- ( name* ) ; ( name* ) - do { commandName "@ruleset" - ; sn <- uriRef2 - ; symbol ":-" - ; ags <- nameList - ; symbol ";" - ; rns <- nameList - ; return $ ssDefineRuleset sn ags rns - } - -defineConstraints :: N3Parser (SwishStateIO ()) -defineConstraints = - -- @constraints pref :- ( name* ) | ( name* ) - do { commandName "@constraints" - ; sn <- uriRef2 - ; symbol ":-" - ; cgs <- graphOrList - ; symbol "|" - ; cns <- nameOrList - ; return $ ssDefineConstraints sn cgs cns - } - -checkProofCmd :: N3Parser (SwishStateIO ()) -checkProofCmd = - -- @proof name ( name* ) - -- @input name - -- @step name ( name* ) => name # rule-name, antecedents, consequent - -- @result name - do { commandName "@proof" - ; pn <- uriRef2 - ; sns <- nameList - ; commandName "@input" - ; igf <- formulaExpr - ; sts <- many checkStep - ; commandName "@result" - ; rgf <- formulaExpr - ; return $ ssCheckProof pn sns igf sts rgf - } - -checkStep :: - N3Parser (Either String [RDFRuleset] - -> SwishStateIO (Either String RDFProofStep)) -checkStep = - do { commandName "@step" - ; rn <- uriRef2 - ; agfs <- formulaList - ; symbol "=>" - ; cgf <- formulaExpr - ; return $ ssCheckStep rn agfs cgf - } - -fwdChain :: N3Parser (SwishStateIO ()) -fwdChain = - -- # ruleset rule (antecedents) => result - -- @fwdchain pref name ( name* ) => name - do { commandName "@fwdchain" - ; sn <- uriRef2 - ; rn <- uriRef2 - ; ags <- graphOrList - ; symbol "=>" - ; cn <- uriRef2 - ; s <- getState :: N3Parser N3State - ; let prefs = prefixUris s :: NamespaceMap - ; return $ ssFwdChain sn rn ags cn prefs - } - -bwdChain :: N3Parser (SwishStateIO ()) -bwdChain = - -- # ruleset rule consequent <= (antecedent-alts) - -- @bwdchain pref name graph <= name - do { commandName "@bwdchain" - ; sn <- uriRef2 - ; rn <- uriRef2 - ; cg <- graphExpr - ; symbol "<=" - ; an <- uriRef2 - ; s <- getState :: N3Parser N3State - ; let prefs = prefixUris s :: NamespaceMap - ; return $ ssBwdChain sn rn cg an prefs - } - ----------------------------------------------------------------------- --- Syntax clause helpers ----------------------------------------------------------------------- - -commandName :: String -> N3Parser () -commandName cmd = try $ - do { string cmd - ; notFollowedBy identLetter - ; whiteSpace - } - -restOfLine :: N3Parser String -restOfLine = - do { s <- manyTill anyChar (char '\n') - ; whiteSpace - ; return s - } - -nameList :: N3Parser [ScopedName] -nameList = - do { symbol "(" - ; ns <- many uriRef2 - ; symbol ")" - ; return ns - } - -nameOrList :: N3Parser [ScopedName] -nameOrList = - do { n <- uriRef2 - ; return $ [n] - } - <|> - nameList - - "Name, or list of names" - -graphExpr :: N3Parser (SwishStateIO (Either String RDFGraph)) -graphExpr = - graphOnly - <|> - do { f <- formulaExpr - ; return $ liftM (liftM formExpr) f - } - - "Graph expression, graph name or named graph definition" - -graphOnly :: N3Parser (SwishStateIO (Either String RDFGraph)) -graphOnly = - do { symbol "{" - ; b <- newBlankNode - ; g <- subgraph b :: N3Parser RDFGraph - ; symbol "}" - ; s <- getState - ; let gp = setNamespaces (prefixUris s) g - ; return $ return (Right gp) - } - -graphList :: N3Parser [SwishStateIO (Either String RDFGraph)] -graphList = between (symbol "(") (symbol ")") (many graphExpr) - - "List of graphs" - -graphOrList :: N3Parser [SwishStateIO (Either String RDFGraph)] -graphOrList = - do { g <- graphExpr - ; return $ [g] - } - <|> - graphList - - "Graph, or list of graphs" - -formulaExpr :: N3Parser (SwishStateIO (Either String RDFFormula)) -formulaExpr = - do { n <- uriRef2 - ; namedGraph n - } - "Formula (name or named graph)" - -namedGraph :: ScopedName -> N3Parser (SwishStateIO (Either String RDFFormula)) -namedGraph n = - do { symbol ":-" - ; g <- graphOnly - ; return $ ssAddReturnFormula n g - } - <|> - return (ssGetFormula n) - -formulaList :: N3Parser [SwishStateIO (Either String RDFFormula)] -formulaList = between (symbol "(") (symbol ")") (many formulaExpr) - - "List of formulae (names or named graphs)" - -varModifiers :: N3Parser [(ScopedName,[RDFLabel])] -varModifiers = - do { symbol "|" - ; varModList - } - -varModList :: N3Parser [(ScopedName,[RDFLabel])] -varModList = - do { symbol "(" - ; vms <- sepBy varMod (symbol ",") - ; symbol ")" - ; return vms - } - <|> - do { vm <- varMod - ; return [vm] - } - -varMod :: N3Parser (ScopedName,[RDFLabel]) -varMod = - do { rn <- uriRef2 - ; vns <- many varid - ; return (rn,vns) - } - ----------------------------------------------------------------------- --- SwishState helper functions ----------------------------------------------------------------------- --- --- The functions below operate in the SwishStateIO monad, and are used --- to assemble an executable version of the parsed script. - -ssAddReturnFormula :: - ScopedName -> SwishStateIO (Either String RDFGraph) - -> SwishStateIO (Either String RDFFormula) -ssAddReturnFormula nam gf = - do { egr <- gf - ; ssAddGraph nam [return egr] - ; return $ liftM (Formula nam) egr - } - -ssAddGraph :: - ScopedName -> [SwishStateIO (Either String RDFGraph)] - -> SwishStateIO () -ssAddGraph nam gf = - let errmsg = "Graph/list not added: "++show nam++"; " - in - do { esg <- sequence gf -- [Either String RDFGraph] - ; let egs = sequence esg -- Either String [RDFGraph] - ; let fgs = case egs of - Left er -> setError (errmsg++er) - Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam gs)) - ; modify fgs - } - -ssGetGraph :: ScopedName -> SwishStateIO (Either String RDFGraph) -ssGetGraph nam = - do { grs <- ssGetList nam - ; return $ liftM head grs - } - -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 String -> SwishStateIO () -ssRead nam muri = ssAddGraph nam [ssReadGraph muri] - -ssReadGraph :: Maybe String -> SwishStateIO (Either String RDFGraph) -ssReadGraph muri = - do { inp <- getResourceData muri - ; return $ gf inp - } - where - gf inp = case inp of - Left es -> Left es - Right is -> parseAnyfromString document muri is - -ssWriteList :: - Maybe String -> 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 [gr] -> ssWriteGraph muri gr comment - Right grs -> sequence_ writegrs where - writegrs = if null grs - then [putResourceData Nothing ("+ Swish: Writing empty list"++)] - else map writegr (zip [0..] grs) - writegr (n,gr) = ssWriteGraph (murin muri n) gr - ("["++show n++"] "++comment) - murin Nothing _ = Nothing - murin (Just uri) n = Just (inituri++show n++lasturi) - where - splituri1 = splitBy (=='/') uri - splituri2 = splitBy (=='.') (lastseg splituri1) - inituri = concat (initseg splituri1 ++ initseg splituri2) - lasturi = lastseg splituri2 - } - -splitBy :: (a->Bool) -> [a] -> [[a]] -splitBy _ [] = [] -splitBy p (s0:str) = let (s1,sr) = break p str in - (s0:s1):splitBy p sr - -lastseg :: [[a]] -> [a] -lastseg [] = [] -lastseg [as] = [] -lastseg ass = last ass - -initseg :: [[a]] -> [[a]] -initseg [] = [] -initseg [as] = [as] -initseg ass = init ass - -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 String -> RDFGraph -> String -> SwishStateIO () -ssWriteGraph muri gr comment = - putResourceData muri ((c++) . (formatGraphAsShowS gr)) - where - c = "# "++comment++"\n" - -ssMerge :: - ScopedName -> [SwishStateIO (Either String RDFGraph)] - -> SwishStateIO () -ssMerge nam gfs = - let errmsg = "Graph merge not defined: "++show nam++"; " - in - do { esg <- sequence gfs -- [Either String RDFGraph] - ; let egs = sequence esg -- Either String [RDFGraph] - ; let fgs = case egs of - Left er -> setError (errmsg++er) - Right [] -> setError (errmsg++"No graphs to merge") - Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam [g])) - where g = foldl1 merge gs - ; modify fgs - } - -ssCompare :: ScopedName -> ScopedName -> SwishStateIO () -ssCompare n1 n2 = - do { g1 <- ssGetGraph n1 - ; g2 <- ssGetGraph n2 - ; when (g1 /= g2) (modify $ setExitcode (ExitFailure 1)) - } - -ssAssertEq :: ScopedName -> ScopedName -> String -> SwishStateIO () -ssAssertEq n1 n2 comment = - let er1 = ":\n Graph or list compare not performed: invalid graph/list." - in - do { 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 (not $ equiv gr1 gr2) $ modify $ - setError (comment++":\n Graph "++show n1 - ++" differs from "++show n2++".") - } - -ssAssertIn :: ScopedName -> ScopedName -> String -> SwishStateIO () -ssAssertIn n1 n2 comment = - let er1 = ":\n Membership test not performed: invalid graph." - er2 = ":\n Membership test not performed: invalid list." - in - do { 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) -> - when (not $ elem gr 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 vm = makeRDFClosureRule rn agrs cgr vm - in - case composeSequence vbms of - Just vm -> modRules (mapReplaceOrAdd (newRule vm)) - Nothing -> setError errmsg4 - ; modify frl - } - -ssFindVarModify :: - (ScopedName,[RDFLabel]) -> SwishStateIO (Either String RDFVarBindingModify) -ssFindVarModify (nam,lbs) = gets $ findVarMod nam lbs - where - findVarMod nam lbs 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 = sequence $ map ssGetFormula ans - :: SwishStateIO [(Either String RDFFormula)] - ; aesg <- agfs -- [Either String RDFFormula] - ; let eags = sequence aesg :: Either String [RDFFormula] - ; let erlf = sequence $ map ssFindRule rns - :: SwishStateIO [(Either String RDFRule)] - ; rles <- erlf -- [Either String RDFRule] - ; let erls = sequence rles :: (Either String [RDFRule]) - ; let frs = case (eags,erls) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right ags,Right rls) -> - modRulesets (mapReplaceOrAdd rs) - where - rs = makeRuleset (snScope sn) ags rls - ; modify frs - } - -ssFindRule :: ScopedName -> SwishStateIO (Either String RDFRule) -ssFindRule nam = gets $ find - where - find st = case findRule nam st of - Nothing -> Left ("Rule not found: "++show nam) - Just rl -> Right rl - -ssDefineConstraints :: - ScopedName - -> [SwishStateIO (Either String RDFGraph)] - -> [ScopedName] - -> SwishStateIO () -ssDefineConstraints sn cgfs dtns = - let errmsg1 = "Error in constraint graph(s): " - errmsg2 = "Error in datatype(s): " - in - do { cges <- sequence cgfs -- [Either String RDFGraph] - ; let ecgs = sequence cges :: Either String [RDFGraph] - ; let ecgr = case ecgs of - Left er -> Left er - Right [] -> Right $ emptyRDFGraph - Right grs -> Right $ foldl1 merge grs - ; edtf <- sequence $ map ssFindDatatype dtns - -- [Either String RDFDatatype] - ; let edts = sequence edtf :: Either String [RDFDatatype] - ; let frs = case (ecgr,edts) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right cgr,Right dts) -> - modRulesets (mapReplaceOrAdd rs) - where - rs = makeRuleset (snScope sn) [] rls - rls = concatMap (flip 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 er) -> return () - (Right pr) -> putResourceData Nothing $ - (("Proof "++show pn++"\n")++) - . showsProof "\n" pr - ; let checkproof = case proof of - (Left er) -> setError er - (Right pr) -> - case explainProof pr of - Nothing -> setInfo (infmsg1++show pn) - Just ex -> setError (errmsg5++show pn++", "++ex) - {- - if not $ checkProof pr then - setError (errmsg5++show pn) - else - setInfo (infmsg1++show pn) - -} - ; modify $ checkproof - } - -ssCheckStep :: - ScopedName -- rule name - -> [SwishStateIO (Either String RDFFormula)] -- antecedent graph formulae - -> SwishStateIO (Either String RDFFormula) -- consequent graph formula - -> Either String [RDFRuleset] -- rulesets - -> SwishStateIO (Either String RDFProofStep) -- resulting proof step -ssCheckStep _ _ _ (Left er) = return $ Left er -ssCheckStep rn eagf ecgf (Right rss) = - let - errmsg1 = "Rule not in proof step ruleset(s): " - errmsg2 = "Error in proof step antecedent graph(s): " - errmsg3 = "Error in proof step consequent graph: " - in - do { let mrul = getMaybeContextRule rn rss :: Maybe RDFRule - ; esag <- sequence $ eagf -- [Either String RDFFormula]] - ; let eags = sequence $ esag :: Either String [RDFFormula] - ; ecg <- ecgf -- Either String RDFFormula - ; let est = case (mrul,eags,ecg) of - (Nothing,_,_) -> Left (errmsg1++show rn) - (_,Left er,_) -> Left (errmsg2++er) - (_,_,Left er) -> Left (errmsg3++er) - (Just rul,Right ags,Right cg) -> - Right $ makeRDFProofStep rul ags cg - ; return est - } - -ssFwdChain :: - ScopedName -- ruleset name - -> ScopedName -- rule name - -> [SwishStateIO (Either String RDFGraph)] -- antecedent graphs - -> ScopedName -- consequent graph name - -> NamespaceMap -- prefixes for new graph - -> SwishStateIO () -ssFwdChain sn rn agfs cn prefs = - let - errmsg1 = "FwdChain rule error: " - errmsg2 = "FwdChain antecedent error: " - in - do { erl <- ssFindRulesetRule sn rn - ; aesg <- sequence agfs -- [Either String RDFGraph] - ; let eags = sequence aesg :: Either String [RDFGraph] - ; let fcr = case (erl,eags) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right rl,Right ags) -> - modGraphs (mapReplaceOrAdd (NamedGraph cn [cg])) - where - cg = case fwdApply rl ags of - [] -> emptyRDFGraph - grs -> setNamespaces prefs $ foldl1 add grs - ; modify fcr - } - -ssFindRulesetRule :: - ScopedName -> ScopedName -> SwishStateIO (Either String RDFRule) -ssFindRulesetRule sn rn = gets $ find - where - find st = case findRuleset sn st of - Nothing -> Left ("Ruleset not found: "++show sn) - Just rs -> find1 rs - find1 rs = case getRulesetRule rn rs of - Nothing -> Left ("Rule not in ruleset: "++show sn++": "++show rn) - Just rl -> Right rl - -ssFindRuleset :: - ScopedName -> SwishStateIO (Either String RDFRuleset) -ssFindRuleset sn = gets $ find - where - find st = case findRuleset sn st of - Nothing -> Left ("Ruleset not found: "++show sn) - Just rs -> Right rs - -ssBwdChain :: - ScopedName -- ruleset name - -> ScopedName -- rule name - -> SwishStateIO (Either String RDFGraph) -- consequent graphs - -> ScopedName -- antecedent alts name - -> NamespaceMap -- prefixes for new graphs - -> SwishStateIO () -ssBwdChain sn rn cgf an prefs = - let - errmsg1 = "BwdChain rule error: " - errmsg2 = "BwdChain goal error: " - in - do { erl <- ssFindRulesetRule sn rn - ; ecg <- cgf -- Either String RDFGraph - ; let fcr = case (erl,ecg) of - (Left er,_) -> setError (errmsg1++er) - (_,Left er) -> setError (errmsg2++er) - (Right rl,Right cg) -> - modGraphs (mapReplaceOrAdd (NamedGraph an ags)) - where - ags = map mergegr (bwdApply rl cg) - mergegr grs = case grs of - [] -> emptyRDFGraph - _ -> setNamespaces prefs $ foldl1 add grs - ; modify fcr - } - --- Temporary implementation: just read local file WNH --- (Add logic to separate filenames from URIs, and --- attempt HTTP GET, or similar.) -getResourceData :: Maybe String -> SwishStateIO (Either String String) -getResourceData muri = - case muri of - Nothing -> fromStdin - Just uri -> fromUri uri - where - fromStdin = - do { dat <- lift getContents - ; return $ Right dat - } - fromUri uri = - do { -- WNH b <- lift $ doesFileExist uri - -- WNH; if not b then - -- WNH return $ Left ("File not found: "++uri) - -- WNHelse - fromFile uri - } - fromFile uri = - do { dat <- lift $ readFile uri - ; return $ Right dat - } - --- Temporary implementation: just write local file --- (Need to add logic to separate filenames from URIs, and --- attempt HTTP PUT, or similar.) -putResourceData :: Maybe String -> ShowS -> SwishStateIO () -putResourceData muri gsh = - do { ios <- lift $ IO.try $ - case muri of - Nothing -> toStdout - Just uri -> toUri uri - ; case ios of - Left ioe -> modify $ setError - ("Error writing graph: "++ - IO.ioeGetErrorString ioe) - Right a -> return a - } - where - toStdout = putStrLn gstr - toUri uri = writeFile uri gstr - gstr = gsh "" - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/SwishScript.hs,v $ --- $Author: graham $ --- $Revision: 1.10 $ --- $Log: SwishScript.hs,v $ --- Revision 1.10 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. --- --- Revision 1.9 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.8 2003/12/19 15:51:41 graham --- Sync minor edits --- --- Revision 1.7 2003/12/12 14:12:01 graham --- Add comment about parser structure to SwishScript.hs --- --- Revision 1.6 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.5 2003/12/10 14:43:00 graham --- Backup. --- --- Revision 1.4 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.3 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.2 2003/12/05 02:31:32 graham --- Script parsing complete. --- Some Swish script functions run successfully. --- Command execution to be completed. --- --- Revision 1.1 2003/12/04 02:53:28 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- diff --git a/Swish/HaskellRDF/SwishTest.hs b/Swish/HaskellRDF/SwishTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/SwishTest.hs +++ /dev/null @@ -1,182 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: SwishTest.hs,v 1.10 2004/01/06 13:53:10 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : SwishTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- SwishTest: Test cases for Swish program. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.SwishTest where - -import System.Exit - -import System.Time - -import Test.HUnit - ( Test(..), Assertable(..), - assertEqual, runTestTT, runTestText, putTextToHandle ) - -import Swish.HaskellRDF.SwishMain - - ------------------------------------------------------------- --- Interactive test cases ------------------------------------------------------------- - -testSwish :: String -> IO Bool -testSwish cmdline = - do { exitcode <- runSwish cmdline - -- ; putStr $ "Exit status: "++(show exitcode) - ; return $ exitcode == ExitSuccess - } - -swishTestCase :: String -> Test -swishTestCase cmdline = TestCase ( assert $ testSwish cmdline ) - -test1 = runSwish "-?" -test2 = runSwish "-!not=validcommand" - -test3 = swishTestCase "-i=Data/N3TestGenReport.n3" -test4 = swishTestCase "-i=Data/sbp-data.n3" -test5 = swishTestCase "-i=Data/Simple.n3 " -test6 = swishTestCase "-i=Data/Simple.n3 -o=Data/Simple.tmp" -test7 = swishTestCase "-i=Data/Simple.n3 -c=Data/Simple.n3" -test8 = swishTestCase "-i=Data/Simple.n3 -c=Data/Simple.tmp" -test9 = swishTestCase "-i=Data/Simple.tmp -c=Data/Simple.tmp" - -test10a = swishTestCase "-i=Data/Simple3.n3" -test10b = swishTestCase "-i=Data/Simple3.n3 -o" - -test10 = swishTestCase "-i=Data/Simple3.n3 -o=Data/Simple3.tmp" -test11 = swishTestCase "-i=Data/Simple3.n3 -c=Data/Simple3.n3" -test12 = swishTestCase "-i=Data/Simple3.n3 -c=Data/Simple3.tmp" -test13 = swishTestCase "-i=Data/Simple3.tmp -c=Data/Simple3.tmp" - -test20a = swishTestCase "-i=Data/N3TestGenReport.n3" -test20b = swishTestCase "-i=Data/N3TestGenReport.n3 -o" - -test20 = swishTestCase "-i=Data/N3TestGenReport.n3 -o=Data/N3TestGenReport.tmp" -test21 = swishTestCase "-i=Data/N3TestGenReport.n3 -c=Data/N3TestGenReport.n3" -test22 = swishTestCase "-i=Data/N3TestGenReport.n3 -c=Data/N3TestGenReport.tmp" -test23 = swishTestCase "-i=Data/N3TestGenReport.tmp -c=Data/N3TestGenReport.tmp" - -test30 = swishTestCase "-i=Data/Merge1.n3 -m=Data/Merge2.n3 -c=Data/Merge3.n3" - -test31 = swishTestCase "-s=Swishtest.ss" - -tests1a = swishTestCase "-i=Data/Simple2.n3 -o=Data/Simple2.tmp" -tests1b = swishTestCase "-i=Data/Simple2.n3 -c=Data/Simple2.tmp" - -allTests = TestList - [ test3 - , test4 - , test5 - , test6 - , test7 - , test8 - , test9 - , test10 - , test11 - , test12 - , test13 - , tests1a - , tests1b - , test20 - , test21 - , test22 - , test23 - , test30 - , test31 - ] - -runTest t = - do { st <- getClockTime - ; putStr $ "Test started: "++show st++"\n" - ; runTestTT t - ; ft <- getClockTime - ; putStr $ "Test finished: "++show ft++"\n" - ; let et = diffClockTimes ft st - ; return et - ; putStr $ "Test duration: "++show et++"\n" - } - -testAll = runTest allTests - -tt = runTest -t20a = runTest test20a -t20b = runTest test20b - -main = testAll - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/SwishTest.hs,v $ --- $Author: graham $ --- $Revision: 1.10 $ --- $Log: SwishTest.hs,v $ --- Revision 1.10 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.9 2003/09/24 18:50:53 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.8 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.7 2003/05/29 11:53:31 graham --- Juggle Swish code: SwishMain.hs is main program logic, with --- Swish.hs and SwishTest.hs being alternative "Main" modules for --- the real program and test harness respectively. --- --- Revision 1.6 2003/05/29 10:49:08 graham --- Added and tested merge option (-m) for Swish program --- --- Revision 1.5 2003/05/29 01:50:56 graham --- More performance tuning, courtesy of GHC profiler. --- All modules showing reasonable performance now. --- --- Revision 1.4 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.3 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.2 2003/05/28 17:39:30 graham --- Trying to track down N3 formatter performance problem. --- --- Revision 1.1 2003/05/23 00:03:55 graham --- Added HUnit test module for swish program. --- Greatly enhanced N3Formatter tests --- diff --git a/Swish/HaskellRDF/VarBinding.hs b/Swish/HaskellRDF/VarBinding.hs deleted file mode 100644 --- a/Swish/HaskellRDF/VarBinding.hs +++ /dev/null @@ -1,593 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} -{-# OPTIONS -XTypeSynonymInstances #-} --------------------------------------------------------------------------------- --- $Id: VarBinding.hs,v 1.12 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : VarBinding --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- 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.HaskellRDF.VarBinding - ( VarBinding(..), nullVarBinding - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings, addVarBinding - , VarBindingModify(..), OpenVarBindingModify - , vbmCompatibility, vbmCompose - , composeSequence, findCompositions, findComposition - , VarBindingFilter(..) - , makeVarFilterModify - , makeVarTestFilter, makeVarCompareFilter - , varBindingId, nullVarBindingModify - , varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE - ) -where - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..) - , makeLookupMap, mapFindMaybe - ) - -import Swish.HaskellUtils.Namespace - ( ScopedName(..) ) - -import Swish.HaskellRDF.Vocabulary - ( swishName ) - -import Swish.HaskellUtils.ListHelpers - ( equiv, subset, flist, headOrNothing, permutations ) - -import Data.Maybe - ( catMaybes, fromMaybe, isJust, fromJust, listToMaybe ) - -import Data.List - ( find, intersect, union, (\\) ) - - ------------------------------------------------------------- --- 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 :: [(a,b)] - , vbNull :: Bool - } - --- |VarBinding is an instance of class Eq, so that variable --- bindings can be compared for equivalence --- -instance (Eq a, Eq b) => Eq (VarBinding a b) where - vb1 == vb2 = (vbEnum vb1) `equiv` (vbEnum vb2) - --- |VarBinding is an instance of class Show, so that variable --- bindings can be displayed --- -instance (Show a, Show b) => Show (VarBinding a b) where - show vb = show (vbEnum vb) - --- |nullVarBinding: maps no query variables. --- -nullVarBinding :: VarBinding a b -nullVarBinding = VarBinding - { vbMap = const Nothing - , vbEnum = [] - , vbNull = True - } - --- |Return a list of the variables bound by a supplied variable binding --- -boundVars :: VarBinding a b -> [a] -boundVars = map fst . vbEnum - --- |VarBinding subset function, tests to see if one query binding --- is a subset of another; i.e. every query variable mapping defined --- by one is also defined by the other. --- -subBinding :: (Eq a, Eq b) => (VarBinding a b) -> (VarBinding a b) -> Bool -subBinding vb1 vb2 = (vbEnum vb1) `subset` (vbEnum vb2) - --- |Function to make a variable binding from a list of --- pairs of variable and corresponding assigned value. --- -makeVarBinding :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> VarBinding a b -makeVarBinding vrbs = - if null vrbs then nullVarBinding -- (nullVarBinding :: VarBinding a b) - else VarBinding - { vbMap = selectFrom vrbs - , vbEnum = vrbs - , vbNull = null vrbs - } - where - selectFrom = flip mapFindMaybe . makeLookupMap - -- selectFrom bs is the VarBinding lookup function - {- - selectFrom :: (Eq a) => [(a,b)] -> a -> Maybe b - selectFrom [] _ = Nothing - selectFrom ((v,r):bs) l = if l == v then Just r - else selectFrom bs l - -} - --- |Apply query binding to a supplied value, returning the value --- unchanged if no binding is defined --- -applyVarBinding :: VarBinding a a -> a -> a -applyVarBinding vbind v = fromMaybe v (vbMap vbind v) - --- |Join a pair of query bindings, returning a new binding that --- maps all variables recognized by either of the input bindings. --- If the bindings should overlap, such overlap is not detected and --- the value from the first binding provided is used arbitrarily. --- -joinVarBindings :: (Eq a) => VarBinding a b -> VarBinding a b -> VarBinding a b -joinVarBindings vb1 vb2 - | vbNull vb1 = vb2 - | vbNull vb2 = vb1 - | otherwise = VarBinding - { vbMap = mv12 - , vbEnum = map (\v -> (v,fromJust (mv12 v))) bv12 - , vbNull = False - } - where - -- flist fs a = map ($ a) fs; see also monad function 'ap' - mv12 = headOrNothing . filter isJust . flist [ vbMap vb1, vbMap vb2 ] - bv12 = boundVars vb1 `union` boundVars vb2 - --- |Add a single new value to a variable binding and return the resulting --- new variable binding. --- -addVarBinding :: (Eq a, Show a, Eq b, Show b) => a -> b -> VarBinding a b - -> VarBinding a b -addVarBinding lb val vbind = joinVarBindings vbind $ makeVarBinding [(lb,val)] - ------------------------------------------------------------- --- Datatypes for variable binding modifiers ------------------------------------------------------------- - --- |Define the type of a function to modify variable bindings in --- forward chaining based on rule antecedent matches. This --- function is used to implement the "allocated to" logic described --- in Appendix B of the RDF semantics document, in which a specific --- blank node is associated with all matches of some specific value --- by applications of the rule on a given graph. --- Use 'id' if no modification of the variable bindings is required. --- --- This datatype consists of the modifier function itself, which --- operates on a list of variable bindings rather than a single --- variable binding (because some modifications share context across --- a set of bindings), and some additional descriptive information --- that allows possible usage patterns to be analyzed. --- --- Some usage patterns (see vbmUsage): --- (a) 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. --- (b) 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. --- (c) modifier: for each supplied variable binding, one or more --- new variable bindings may be created that contain the --- input variables bound as supplied plus some additional variables. --- Identifiable by an element of vbmUsage some subset of vbmVocab. --- --- A variety of variable usage patterns may be supported by a given --- modifier: a modifier may be used to define new variable bindings --- from existing bindings in a number of ways, or simply to check that --- some required relationship between bindings is satisfied. --- (Example, for a + b = c, any one variable can be deduced from the --- other two, or all three may be supplied to check that the relationship --- does indeed hold.) --- -data VarBindingModify a b = VarBindingModify - { vbmName :: ScopedName - -- ^Name used to identify this variable binding - -- modifier when building inference rules. - , vbmApply :: [VarBinding a b] -> [VarBinding a b] - -- ^Apply variable binding modifier to a - -- list of variable bindings, returning a - -- new list. The result list is not - -- necessarily the same length as the - -- supplied list. - , vbmVocab :: [a] -- ^List of variables used by this modifier. - -- All results of applying this modifier contain - -- bindings for these variables. - , vbmUsage :: [[a]] -- ^List of binding modifier usage patterns - -- supported. Each pattern is characterized as - -- a list of variables for which new bindings - -- may be created by some application of this - -- modifier, assuming that bindings for all other - -- variables in vbmVocab are supplied. - } - --- |Allow a VarBindingModify value to be accessed using a LookupMap. --- -instance LookupEntryClass - (VarBindingModify a b) ScopedName (VarBindingModify a b) - where - keyVal vbm = (vbmName vbm,vbm) - newEntry (_,vbm) = vbm - --- |Type for variable binding modifier that has yet to be instantiated --- with respect to the variables that it operates upon. --- -type OpenVarBindingModify lb vn = [lb] -> VarBindingModify lb vn - --- |Extract variable binding name from OpenVarBindingModify value --- --- (Because only the name is required, the application to an undefined --- list of variable labels should never be evaluated, as long as the --- name is not dependent on the variable names in any way.) --- --- NOT QUITE... some of the functions that create OpenVarBindingModify --- instances also pattern-match the number of labels provided, forcing --- evaluation of the labels parameter, even though it's not used. --- -openVbmName :: OpenVarBindingModify lb vn -> ScopedName -openVbmName ovbm = vbmName (ovbm (error "Undefined labels in variable binding")) - --- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. --- -instance LookupEntryClass - (OpenVarBindingModify a b) ScopedName (OpenVarBindingModify a b) - where - keyVal ovbm = (openVbmName ovbm,ovbm) - newEntry (_,ovbm) = ovbm - --- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. --- -instance Show (OpenVarBindingModify a b) - where - show = show . openVbmName - --- |Variable binding modifier compatibility test. --- --- Given a list of bound variables and a variable binding modifier, return --- a list of new variables that may be bound, or Nothing. --- --- Note: if the usage pattern component is well-formed (i.e. all --- elements different) then at most one element can be compatible with --- a given input variable set. --- -vbmCompatibility :: (Eq a) => VarBindingModify a b -> [a] -> Maybe [a] -vbmCompatibility vbm vars = find compat (vbmUsage vbm) - where - compat ovars = vbmCompatibleVars vars (vbmVocab vbm) ovars - --- |Variable binding usage compatibility test. --- --- bvars are variables supplied with bindings --- vocab are variables returned with bindings by a modifier --- ovars are variables assigned new bindings by a modifier --- --- 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] -> [a] -> [a] -> Bool -vbmCompatibleVars bvars vocab ovars = - null (ivars `intersect` ovars) && -- ivars and ovars don't overlap - null ((vocab \\ ovars) \\ ivars) -- ovars and ivars cover vocab - where - ivars = bvars `intersect` vocab - --- |Compose variable binding modifiers. --- --- Returns Just a new variable binding modifier that corresponds to --- applying the first supplied modifier and then applying the second --- one, or Nothing if the two modifiers cannot be compatibly composed. --- --- NOTE: this function does not, in general, commute. --- --- NOTE: if there are different ways to achieve the same usage, that --- usage is currently repeated in the result returned. --- -vbmCompose :: (Eq a) => VarBindingModify a b -> VarBindingModify a b - -> Maybe (VarBindingModify a b) -vbmCompose - (VarBindingModify nam1 app1 voc1 use1) - (VarBindingModify nam2 app2 voc2 use2) - | not (null use12) = Just $ VarBindingModify - { vbmName = swishName ("_"++(snLocal nam1)++"_"++(snLocal nam2)++"_") - , vbmApply = app2 . app1 - , vbmVocab = voc1 `union` voc2 - , vbmUsage = use12 - } - | otherwise = Nothing - where - use12 = compatibleUsage voc1 use1 use2 - --- |Determine compatible ways in which variable binding modifiers may --- be combined. --- --- voc1 is the total vocabulary of the first modifier to be applied --- use1 is a list of usage patterns for the first modifier. --- use2 is a list of usage patterns for the second modifier. --- --- Returns 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. --- --- 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 above.) --- --- NOTE: if there are different ways to achieve the same usage, that --- usage is currently repeated in the result returned. --- -compatibleUsage :: (Eq a) => [a] -> [[a]] -> [[a]] -> [[a]] -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 = - catMaybes $ map (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 vars (Just vbm) - | isJust $ vbmCompatibility vbm vars = (Just vbm) - | otherwise = Nothing - --- |Compose sequence of variable binding modifiers. --- -composeSequence :: (Eq a) => [VarBindingModify a b] - -> Maybe (VarBindingModify a b) -composeSequence [] = Just varBindingId -composeSequence (vbm:vbms) = - foldl composePair (Just vbm) vbms - --- |Compose a pair of variable binding modifiers, returning --- Just (composed modifier), or Nothing --- -composePair :: (Eq a) => Maybe (VarBindingModify a b) -> VarBindingModify a b - -> Maybe (VarBindingModify a b) -composePair Nothing _ = Nothing -composePair (Just vbm1) vbm2 = vbmCompose vbm1 vbm2 - --- |Return Just a compatible composition of variable binding modifiers --- for a given set of supplied bound variables, or Nothing if there --- is no compatible composition --- -findComposition :: (Eq a) => [VarBindingModify a b] -> [a] - -> Maybe (VarBindingModify a b) -findComposition = listToMaybe `c2` findCompositions - where - c2 = (.) . (.) -- compose with function of two arguments - --- |Variable binding modifier that returns exactly those --- variable bindings presented. --- -varBindingId :: VarBindingModify a b -varBindingId = VarBindingModify - { vbmName = swishName "varBindingId" - , vbmApply = id - , vbmVocab = [] - , vbmUsage = [[]] - } - --- |Null variable binding modifier --- --- This is like varBindingId except parameterized by some labels. --- I think this is redundant, and should be eliminated. --- -nullVarBindingModify :: OpenVarBindingModify a b -nullVarBindingModify lbs = VarBindingModify - { vbmName = swishName "nullVarBindingModify" - , vbmApply = id - , vbmVocab = lbs - , vbmUsage = [[]] - } - ------------------------------------------------------------- --- Query binding filters ------------------------------------------------------------- - --- |VarBindingFilter is a function type that tests to see if --- a query binding satisfies some criterion. --- --- Queries often want to apply some kind of filter or condition --- to the variable bindings that are processed. In inference rules, --- it sometimes seems desirable to stipulate additional conditions on --- the things that are matched. --- --- This function type is used to perform such tests. --- A number of simple implementations are included below. -data VarBindingFilter a b = VarBindingFilter - { vbfName :: ScopedName - , vbfVocab :: [a] - , vbfTest :: (VarBinding a b) -> Bool - } - --- |Make a variable binding modifier from a variable binding filter value. -makeVarFilterModify :: VarBindingFilter a b -> VarBindingModify a b -makeVarFilterModify vbf = VarBindingModify - { vbmName = vbfName vbf - , vbmApply = filter (vbfTest vbf) - , vbmVocab = vbfVocab vbf - , vbmUsage = [[]] - } - --- |Make a variable test filter for a named variable using a --- supplied value testing function. -makeVarTestFilter :: - ScopedName -> (b -> Bool) -> a -> VarBindingFilter a b -makeVarTestFilter nam vtest var = VarBindingFilter - { vbfName = nam - , vbfVocab = [var] - , vbfTest = \vb -> case vbMap vb var of - Just val -> vtest val - _ -> False - } - --- |Make a variable comparison filter for named variables using --- a supplied value comparison function. -makeVarCompareFilter :: - ScopedName -> (b -> b -> Bool) -> a -> a -> VarBindingFilter a b -makeVarCompareFilter nam vcomp v1 v2 = VarBindingFilter - { vbfName = nam - , vbfVocab = [v1,v2] - , vbfTest = \vb -> case (vbMap vb v1,vbMap vb v2) of - (Just val1, Just val2) -> vcomp val1 val2 - _ -> False - } - ------------------------------------------------------------- --- Declare some generally useful query binding filters ------------------------------------------------------------- - --- |This function generates a query binding filter that ensures that --- two indicated query variables are mapped to the same value. -varFilterEQ :: (Eq b) => a -> a -> VarBindingFilter a b -varFilterEQ v1 v2 = - makeVarCompareFilter (swishName "varFilterEQ") (==) v1 v2 - --- |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 v1 v2 = - makeVarCompareFilter (swishName "varFilterNE") (/=) v1 v2 - --- |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) - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/VarBinding.hs,v $ --- $Author: graham $ --- $Revision: 1.12 $ --- $Log: VarBinding.hs,v $ --- Revision 1.12 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.11 2003/12/10 03:48:58 graham --- SwishScript nearly complete: BwdChain and PrrofCheck to do. --- --- Revision 1.10 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.9 2003/12/08 17:29:19 graham --- Moved OpenVarBinding type definitions from -Datatype to -VarBinding modules. --- --- Revision 1.8 2003/12/08 16:58:27 graham --- Add name to variable binding modifiers and filters. --- Add namespace for Swish-defined names. --- --- Revision 1.7 2003/12/04 02:53:28 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.6 2003/10/24 21:05:08 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.5 2003/10/22 15:47:46 graham --- Working on datatype inference support. --- --- Revision 1.4 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.3 2003/10/15 16:40:52 graham --- Reworked RDFQuery to use new query binding framework. --- (Note: still uses VarBindingFilter rather than VarBindingModify. --- The intent is to incorproate the VarBindingModify logic into RDFProof, --- displaying the existing use of BindingFilter.) --- --- Revision 1.2 2003/10/15 00:07:01 graham --- Added variable binding filter structures, and some common filters --- --- Revision 1.1 2003/10/14 20:30:58 graham --- Add separate module for generic variable binding functions. --- diff --git a/Swish/HaskellRDF/VarBindingTest.hs b/Swish/HaskellRDF/VarBindingTest.hs deleted file mode 100644 --- a/Swish/HaskellRDF/VarBindingTest.hs +++ /dev/null @@ -1,991 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: VarBindingTest.hs,v 1.6 2004/01/06 13:53:10 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : VarBindingTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for variable binding values and --- variable binding modifier values. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellRDF.VarBindingTest where - -import Swish.HaskellRDF.VarBinding - ( VarBinding(..) - , subBinding, nullVarBinding, makeVarBinding - , boundVars, subBinding, makeVarBinding - , applyVarBinding, joinVarBindings - , VarBindingModify(..) - , vbmCompatibility, vbmCompose - , findCompositions, findComposition - , makeVarFilterModify - , makeVarTestFilter, makeVarCompareFilter - , varBindingId, varFilterDisjunction, varFilterConjunction - , varFilterEQ, varFilterNE - ) - -import Swish.HaskellRDF.Vocabulary - ( swishName ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , Assertion - , assertBool, assertEqual, assertString, assertFailure - , runTestTT, runTestText, putTextToHandle - ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Control.Monad ( unless ) - -import Data.List - ( sort, union, intersect ) - -import Data.Maybe - ( isJust, fromJust ) - - ------------------------------------------------------------- --- 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 bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++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) ) - --- Test for Just x or Nothing - -testJust :: String -> Maybe a -> Test -testJust lab av = - TestCase ( assertBool ("testJust:"++lab) (isJust av) ) - -testNothing :: String -> Maybe a -> Test -testNothing lab av = - TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) - --- Compare lists and lists of lists and Maybe lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - -testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqvEqv lab a1 a2 = - TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest $ map ListTest a1 - ma2 = ListTest $ map ListTest a2 - -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test -testHasEqv lab a1 a2 = - TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest a1 - ma2 = map ListTest a2 - -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv lab a1 a2 = - TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) - where - ma1 = (MaybeListTest a1) - ma2 = (MaybeListTest a2) - ------------------------------------------------------------- --- Define and variable bindings ------------------------------------------------------------- - -vb1 :: VarBinding Int String -vb1 = makeVarBinding [(1,"a"),(2,"b"),(3,"c")] -vb1str = "[(1,\"a\"),(2,\"b\"),(3,\"c\")]" - -vb2 :: VarBinding Int String -vb2 = makeVarBinding [(3,"c"),(2,"b"),(1,"a")] -vb2str = "[(3,\"c\"),(2,\"b\"),(1,\"a\")]" - -vb3 :: VarBinding Int String -vb3 = makeVarBinding [(1,"a"),(2,"b"),(3,"c"),(4,"d"),(5,"e")] -vb3str = "[(1,\"a\"),(2,\"b\"),(3,\"c\"),(4,\"d\"),(5,\"e\")]" - -vb4 :: VarBinding Int String -vb4 = nullVarBinding -vb4str = "[]" - -testVarBinding01 = test "testVarBinding01" $ (vb1==vb2) -testVarBinding02 = test "testVarBinding02" $ (vb1/=vb3) -testVarBinding03 = test "testVarBinding03" $ (vb1/=vb4) -testVarBinding04 = testEq "testVarBinding04" vb1str $ show vb1 -testVarBinding05 = testEq "testVarBinding05" vb2str $ show vb2 -testVarBinding06 = testEq "testVarBinding06" vb4str $ show vb4 - -testVarBinding10 = testEq "testVarBinding10" [1,2,3] $ boundVars vb1 -testVarBinding11 = testEq "testVarBinding11" [3,2,1] $ boundVars vb2 -testVarBinding12 = testEq "testVarBinding12" [] $ boundVars vb4 - -testVarBinding20 = test "testVarBinding20" $ (subBinding vb1 vb2) -testVarBinding21 = test "testVarBinding21" $ (subBinding vb1 vb3) -testVarBinding22 = test "testVarBinding22" $ not (subBinding vb1 vb4) -testVarBinding23 = test "testVarBinding23" $ (subBinding vb2 vb1) -testVarBinding24 = test "testVarBinding24" $ not (subBinding vb3 vb1) -testVarBinding25 = test "testVarBinding25" $ (subBinding vb4 vb1) -testVarBinding26 = test "testVarBinding26" $ (subBinding vb4 vb4) - -vb5 :: VarBinding Int Int -vb5 = makeVarBinding [(1,11),(2,22),(3,33)] - -testVarBinding30 = testEq "testVarBinding30" 0 $ applyVarBinding vb5 0 -testVarBinding31 = testEq "testVarBinding31" 11 $ applyVarBinding vb5 1 -testVarBinding32 = testEq "testVarBinding32" 22 $ applyVarBinding vb5 2 -testVarBinding33 = testEq "testVarBinding33" 33 $ applyVarBinding vb5 3 -testVarBinding34 = testEq "testVarBinding34" 4 $ applyVarBinding vb5 4 -testVarBinding35 = testEq "testVarBinding35" 11 $ applyVarBinding vb5 11 - -vb6 :: VarBinding Int String -vb6 = makeVarBinding [(3,"cc"),(4,"dd"),(5,"ee")] - -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 = vb1str -vb13str = vb3str -vb14str = vb1str -vb16str = "[(1,\"a\"),(2,\"b\"),(3,\"c\"),(4,\"dd\"),(5,\"ee\")]" -vb21str = vb2str -vb44str = vb4str - -testVarBinding40 = test "testVarBinding40" $ not (vbNull vb12) -testVarBinding41 = test "testVarBinding41" $ not (vbNull vb13) -testVarBinding42 = test "testVarBinding42" $ not (vbNull vb14) -testVarBinding43 = test "testVarBinding43" $ not (vbNull vb16) -testVarBinding44 = test "testVarBinding44" $ not (vbNull vb21) -testVarBinding45 = test "testVarBinding45" $ (vbNull vb44) - -testVarBinding50 = test "testVarBinding50" $ (subBinding vb12 vb13) -testVarBinding51 = test "testVarBinding51" $ (subBinding vb12 vb14) -testVarBinding52 = test "testVarBinding52" $ (subBinding vb12 vb16) -testVarBinding53 = test "testVarBinding53" $ (subBinding vb12 vb21) -testVarBinding54 = test "testVarBinding54" $ not (subBinding vb12 vb44) -testVarBinding55 = test "testVarBinding55" $ not (subBinding vb13 vb12) -testVarBinding56 = test "testVarBinding56" $ (subBinding vb14 vb12) -testVarBinding57 = test "testVarBinding57" $ (subBinding vb44 vb12) -testVarBinding58 = test "testVarBinding58" $ not (subBinding vb16 vb12) - -testVarBinding60 = testEq "testVarBinding60" vb12str $ show vb12 -testVarBinding61 = testEq "testVarBinding61" vb13str $ show vb13 -testVarBinding62 = testEq "testVarBinding62" vb14str $ show vb14 -testVarBinding63 = testEq "testVarBinding63" vb16str $ show vb16 -testVarBinding64 = testEq "testVarBinding64" vb21str $ show vb21 -testVarBinding65 = testEq "testVarBinding65" vb44str $ show vb44 - -testVarBinding70 = testEq "testVarBinding70" (Just "a") $ vbMap vb16 1 -testVarBinding71 = testEq "testVarBinding71" (Just "c") $ vbMap vb16 3 -testVarBinding72 = testEq "testVarBinding72" (Just "ee") $ vbMap vb16 5 -testVarBinding73 = testEq "testVarBinding73" Nothing $ vbMap vb16 7 - -testVarBindingSuite = TestList - [ testVarBinding01, testVarBinding02, testVarBinding03, testVarBinding04 - , testVarBinding05, testVarBinding06 - , testVarBinding10, testVarBinding11, testVarBinding12 - , testVarBinding20, testVarBinding21, testVarBinding22, testVarBinding23 - , testVarBinding24, testVarBinding25, testVarBinding26 - , testVarBinding30, testVarBinding31, testVarBinding32, testVarBinding33 - , testVarBinding34, testVarBinding35 - , testVarBinding40, testVarBinding41, testVarBinding42, testVarBinding43 - , testVarBinding44, testVarBinding45 - , testVarBinding50, testVarBinding51, testVarBinding52, testVarBinding53 - , testVarBinding54, testVarBinding55, testVarBinding56, testVarBinding57 - , testVarBinding58 - , testVarBinding60, testVarBinding61, testVarBinding62, testVarBinding63 - , testVarBinding64, testVarBinding65 - , testVarBinding70, testVarBinding71, testVarBinding72, testVarBinding73 - ] - ------------------------------------------------------------- --- 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 = VarBindingModify - { vbmName = swishName "vbm1" - , vbmApply = map (\vb -> joinVarBindings vb vb9m) - , vbmVocab = boundVars vb9m - , vbmUsage = [boundVars vb9m] - } - -[vb1m1] = vbmApply vbm1 [vb1m] -[vb2m1] = vbmApply vbm1 [vb2m] - -testVarModifyName01 = testEq "testVarModifyName01" - (swishName "vbm1") $ - vbmName vbm1 - -testVarModify01 = testEq "testVarModify01" (Just 1) $ vbMap vb1m1 "a" -testVarModify02 = testEq "testVarModify02" Nothing $ vbMap vb1m1 "b" -testVarModify03 = testEq "testVarModify03" Nothing $ vbMap vb2m1 "c" -testVarModify04 = testEq "testVarModify04" (Just 9) $ vbMap vb1m1 "i" -testVarModify05 = testEq "testVarModify05" (Just 1) $ vbMap vb2m1 "a" -testVarModify06 = testEq "testVarModify06" (Just 2) $ vbMap vb2m1 "b" -testVarModify07 = testEq "testVarModify07" Nothing $ vbMap vb2m1 "c" -testVarModify08 = testEq "testVarModify08" (Just 9) $ vbMap vb2m1 "i" - -testVarModify10 = testEq "testVarModify10" (Just ["i"]) $ - vbmCompatibility vbm1 ["a","b"] -testVarModify11 = testEq "testVarModify11" Nothing $ - vbmCompatibility vbm1 ["a","b","i"] - --- 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 = vbmApply vbm2 [vb1m,vb2m,vb9m] - -testVarModifyName02 = testEq "testVarModifyName02" - (swishName "vbm2") $ - vbmName vbm2 - -testVarModify20 = testEq "testVarModify20" 2 $ length vb12m2 -testVarModify21 = testEq "testVarModify21" vb1m $ vb12m2!!0 -testVarModify22 = testEq "testVarModify22" vb2m $ vb12m2!!1 -testVarModify23 = testEq "testVarModify23" (Just []) $ - vbmCompatibility vbm2 ["a","b"] -testVarModify24 = testEq "testVarModify24" (Just []) $ - vbmCompatibility vbm2 ["a","b"] -testVarModify25 = testEq "testVarModify25" (Just []) $ - vbmCompatibility vbm2 ["a","b","i"] -testVarModify26 = testEq "testVarModify26" Nothing $ - vbmCompatibility vbm2 ["i"] - --- 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 vbinds = concatMap abSumc vbinds - 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 = vbmApply vbm3 [vb1m,vb2m,vb3m,vb4m,vb5m,vb6m] - -testVarModifyName03 = testEq "testVarModifyName03" - (swishName "vbm3") $ - vbmName vbm3 - -testVarModify30 = testEq "testVarModify30" 4 $ length vb16m3 -testVarModify31 = testEq "testVarModify31" vb5m $ (vb16m3!!0) -testVarModify32 = testEq "testVarModify32" vb5m $ (vb16m3!!1) -testVarModify33 = testEq "testVarModify33" vb5m $ (vb16m3!!2) -testVarModify34 = testEq "testVarModify34" vb5m $ (vb16m3!!3) -testVarModify35 = testEq "testVarModify35" (Just ["c"]) $ - vbmCompatibility vbm3 ["a","b"] -testVarModify36 = testEq "testVarModify36" (Just ["b"]) $ - vbmCompatibility vbm3 ["a","c"] -testVarModify37 = testEq "testVarModify37" (Just ["a"]) $ - vbmCompatibility vbm3 ["b","c","i"] -testVarModify38 = testEq "testVarModify38" (Just []) $ - vbmCompatibility vbm3 ["i","c","a","b"] -testVarModify39 = testEq "testVarModify39" Nothing $ - vbmCompatibility vbm3 ["i","a"] -testVarModify40 = testEq "testVarModify40" Nothing $ - vbmCompatibility vbm3 ["i","b"] -testVarModify41 = testEq "testVarModify41" Nothing $ - vbmCompatibility vbm3 ["i","c"] -testVarModify42 = testEq "testVarModify42" Nothing $ - vbmCompatibility vbm3 ["i","d"] - -testVarModifySuite = TestList - [ testVarModifyName01, testVarModifyName02, testVarModifyName03 - , testVarModify01, testVarModify02, testVarModify03 - , testVarModify04, testVarModify05, testVarModify06 - , testVarModify07, testVarModify08 - , testVarModify10, testVarModify11 - , testVarModify20, testVarModify21, testVarModify22 - , testVarModify23, testVarModify24, testVarModify25 - , testVarModify26 - , testVarModify30, testVarModify31, testVarModify32 - , testVarModify33, testVarModify34, testVarModify35 - , testVarModify36, testVarModify37, testVarModify38 - , testVarModify39, testVarModify40, testVarModify41 - , testVarModify42 - ] - ------------------------------------------------------------- --- 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"]] - } - -Just vbm34 = vbmCompose vbm3 vbm4 -vbm34vocab = [ "a", "b", "c", "d"] -vbm34usage = [ ["a","d"], ["b","d"], ["c","d"] - , ["a"], ["b"], ["c"], ["d"], [] - ] - -Just vbm43 = vbmCompose vbm4 vbm3 -vbm43vocab = [ "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)] - - -testVarModifyName04 = testEq "testVarModifyName04" - (swishName "vbm4") $ - vbmName vbm4 - -testVarModifyName05 = testEq "testVarModifyName05" - (swishName "_vbm4_vbm3_") $ - vbmName vbm43 - -testVarModifyName06 = testEq "testVarModifyName06" - (swishName "_vbm3_vbm4_") $ - vbmName vbm34 - -testVarCompose01 = testEqv "testVarCompose01" vbm34vocab $ - vbmVocab vbm34 -testVarCompose02 = testEqvEqv "testVarCompose02" vbm34usage $ - vbmUsage vbm34 -testVarCompose03 = testMaybeEqv "testVarCompose03" (Just ["c","d"]) $ - vbmCompatibility vbm34 ["a","b"] -testVarCompose04 = testMaybeEqv "testVarCompose04" (Just ["b","d"]) $ - vbmCompatibility vbm34 ["a","c"] -testVarCompose05 = testMaybeEqv "testVarCompose05" Nothing $ - vbmCompatibility vbm34 ["a","d"] -testVarCompose06 = testMaybeEqv "testVarCompose06" (Just ["a","d"]) $ - vbmCompatibility vbm34 ["b","c"] -testVarCompose07 = testMaybeEqv "testVarCompose07" Nothing $ - vbmCompatibility vbm34 ["b","d"] -testVarCompose08 = testMaybeEqv "testVarCompose08" Nothing $ - vbmCompatibility vbm34 ["c","d"] -testVarCompose09 = testMaybeEqv "testVarCompose09" (Just ["a"]) $ - vbmCompatibility vbm34 ["b","c","d"] -testVarCompose10 = testMaybeEqv "testVarCompose10" (Just ["b"]) $ - vbmCompatibility vbm34 ["a","c","d"] -testVarCompose11 = testMaybeEqv "testVarCompose11" (Just ["c"]) $ - vbmCompatibility vbm34 ["a","b","d"] -testVarCompose12 = testMaybeEqv "testVarCompose12" (Just ["d"]) $ - vbmCompatibility vbm34 ["a","b","c"] -testVarCompose13 = testMaybeEqv "testVarCompose13" (Just []) $ - vbmCompatibility vbm34 ["a","b","c","d"] -testVarCompose14 = testEqv "testVarCompose14" [vbabcd,vbabcd,vbabcd] $ - vbmApply vbm34 [vbab,vbac,vbbc] -testVarCompose15 = testEqv "testVarCompose15" [] $ - vbmApply vbm34 [vbad,vbbd,vbcd] - -testVarCompose21 = testEqv "testVarCompose21" vbm43vocab $ - vbmVocab vbm43 -testVarCompose22 = testEqvEqv "testVarCompose22" vbm43usage $ - vbmUsage vbm43 -testVarCompose23 = testMaybeEqv "testVarCompose23" Nothing $ - vbmCompatibility vbm43 ["a","b"] -testVarCompose24 = testMaybeEqv "testVarCompose24" (Just ["b","d"]) $ - vbmCompatibility vbm43 ["a","c"] -testVarCompose25 = testMaybeEqv "testVarCompose25" (Just ["b","c"]) $ - vbmCompatibility vbm43 ["a","d"] -testVarCompose26 = testMaybeEqv "testVarCompose26" Nothing $ - vbmCompatibility vbm43 ["b","c"] -testVarCompose27 = testMaybeEqv "testVarCompose27" Nothing $ - vbmCompatibility vbm43 ["b","d"] -testVarCompose28 = testMaybeEqv "testVarCompose28" (Just ["a","b"]) $ - vbmCompatibility vbm43 ["c","d"] -testVarCompose29 = testMaybeEqv "testVarCompose29" (Just ["a"]) $ - vbmCompatibility vbm43 ["b","c","d"] -testVarCompose30 = testMaybeEqv "testVarCompose30" (Just ["b"]) $ - vbmCompatibility vbm43 ["a","c","d"] -testVarCompose31 = testMaybeEqv "testVarCompose31" (Just ["c"]) $ - vbmCompatibility vbm43 ["a","b","d"] -testVarCompose32 = testMaybeEqv "testVarCompose32" (Just ["d"]) $ - vbmCompatibility vbm43 ["a","b","c"] -testVarCompose33 = testMaybeEqv "testVarCompose33" (Just []) $ - vbmCompatibility vbm43 ["a","b","c","d"] -testVarCompose34 = testEqv "testVarCompose34" [] $ - vbmApply vbm43 [vbab,vbbc,vbbd] -testVarCompose35 = testEqv "testVarCompose35" [vbabcd,vbabcd,vbabcd] $ - vbmApply vbm43 [vbac,vbad,vbcd] - --- [[[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 = vbmCompose vbm5 vbm6 -vbm65 = vbmCompose vbm6 vbm5 -vbm78 = vbmCompose vbm7 vbm8 -vbm87 = vbmCompose vbm8 vbm7 -vbm87usage = [["a","b"],["a","c"],["a","b","c"]] - -testVarCompose41 = test "testVarCompose41" $ not (isJust vbm56) -testVarCompose42 = test "testVarCompose42" $ not (isJust vbm65) -testVarCompose43 = test "testVarCompose43" $ not (isJust vbm78) -testVarCompose44 = test "testVarCompose44" $ (isJust vbm87) -testVarCompose45 = testEqvEqv "testVarCompose45" vbm87usage $ - vbmUsage (fromJust vbm87) - -jvbm1id = vbmCompose vbm1 varBindingId -jvbmid1 = vbmCompose varBindingId vbm1 - -testVarCompose51 = test "testVarCompose51" $ isJust jvbm1id -testVarCompose52 = test "testVarCompose52" $ isJust jvbmid1 - -[vb1m1id] = vbmApply (fromJust jvbm1id) [vb1m] -[vb2m1id] = vbmApply (fromJust jvbm1id) [vb2m] - -testVarModifyName07 = testEq "testVarModifyName07" - (swishName "_vbm1_varBindingId_") $ - vbmName (fromJust jvbm1id) - -testVarModifyName08 = testEq "testVarModifyName08" - (swishName "_varBindingId_vbm1_") $ - vbmName (fromJust jvbmid1) - -testVarCompose61 = testEq "testVarCompose61" (Just 1) $ vbMap vb1m1id "a" -testVarCompose62 = testEq "testVarCompose62" Nothing $ vbMap vb1m1id "b" -testVarCompose63 = testEq "testVarCompose63" Nothing $ vbMap vb2m1id "c" -testVarCompose64 = testEq "testVarCompose64" (Just 9) $ vbMap vb1m1id "i" -testVarCompose65 = testEq "testVarCompose65" (Just 1) $ vbMap vb2m1id "a" -testVarCompose66 = testEq "testVarCompose66" (Just 2) $ vbMap vb2m1id "b" -testVarCompose67 = testEq "testVarCompose67" Nothing $ vbMap vb2m1id "c" -testVarCompose68 = testEq "testVarCompose68" (Just 9) $ vbMap vb2m1id "i" - -[vb1mid1] = vbmApply (fromJust jvbmid1) [vb1m] -[vb2mid1] = vbmApply (fromJust jvbmid1) [vb2m] - -testVarCompose71 = testEq "testVarCompose71" (Just 1) $ vbMap vb1mid1 "a" -testVarCompose72 = testEq "testVarCompose72" Nothing $ vbMap vb1mid1 "b" -testVarCompose73 = testEq "testVarCompose73" Nothing $ vbMap vb2mid1 "c" -testVarCompose74 = testEq "testVarCompose74" (Just 9) $ vbMap vb1mid1 "i" -testVarCompose75 = testEq "testVarCompose75" (Just 1) $ vbMap vb2mid1 "a" -testVarCompose76 = testEq "testVarCompose76" (Just 2) $ vbMap vb2mid1 "b" -testVarCompose77 = testEq "testVarCompose77" Nothing $ vbMap vb2mid1 "c" -testVarCompose78 = testEq "testVarCompose78" (Just 9) $ vbMap vb2mid1 "i" - -testVarComposeSuite = TestList - [ testVarModifyName04, testVarModifyName05, testVarModifyName06 - , testVarModifyName07, testVarModifyName08 - , testVarCompose01, testVarCompose02, testVarCompose03, testVarCompose04 - , testVarCompose05, testVarCompose06, testVarCompose07, testVarCompose08 - , testVarCompose09, testVarCompose10, testVarCompose11, testVarCompose12 - , testVarCompose13, testVarCompose14, testVarCompose15 - , testVarCompose21, testVarCompose22, testVarCompose23, testVarCompose24 - , testVarCompose25, testVarCompose26, testVarCompose27, testVarCompose28 - , testVarCompose29, testVarCompose30, testVarCompose31, testVarCompose32 - , testVarCompose33, testVarCompose34, testVarCompose35 - , testVarCompose41, testVarCompose42, testVarCompose43, testVarCompose44 - , testVarCompose45 - , testVarCompose51, testVarCompose52 - , testVarCompose61, testVarCompose62, testVarCompose63, testVarCompose64 - , testVarCompose65, testVarCompose66, testVarCompose67, testVarCompose68 - , testVarCompose71, testVarCompose72, testVarCompose73, testVarCompose74 - , testVarCompose75, testVarCompose76, testVarCompose77, testVarCompose78 - ] - ------------------------------------------------------------- --- 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 = 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 - -testVarModifyName09 = testEq "testVarModifyName08" - (swishName "__vbm4_vbm3__vbm9_") $ - vbmName (compad!!0) - -testVarModifyName10 = testEq "testVarModifyName08" - (swishName "__vbm4_vbm9__vbm3_") $ - vbmName (compad!!1) - -testFindComp01 = testEq "testFindComp01" 1 $ (length compab) -testFindComp02 = testEq "testFindComp02" 3 $ (length compac) -testFindComp03 = testEq "testFindComp03" 2 $ (length compad) -testFindComp04 = testEq "testFindComp04" 0 $ (length compae) -testFindComp05 = testEq "testFindComp05" 1 $ (length compba) -testFindComp06 = testEq "testFindComp06" 1 $ (length compbc) -testFindComp07 = testEq "testFindComp07" 0 $ (length compbd) -testFindComp08 = testEq "testFindComp08" 0 $ (length compbe) -testFindComp09 = testEq "testFindComp09" 3 $ (length compca) -testFindComp10 = testEq "testFindComp10" 3 $ (length compcd) -testFindComp11 = testEq "testFindComp11" 1 $ (length compce) -testFindComp12 = testEq "testFindComp12" 1 $ (length compde) - -compvocab = ["a","b","c","d","e"] - -testFindComp21 = testEqv "testFindComp21" compvocab $ vbmVocab (head compab) -testFindComp22 = testEqv "testFindComp22" compvocab $ vbmVocab (head compac) -testFindComp23 = testEqv "testFindComp23" compvocab $ vbmVocab (head compad) -testFindComp24 = testEqv "testFindComp24" compvocab $ vbmVocab (head compba) -testFindComp25 = testEqv "testFindComp25" compvocab $ vbmVocab (head compbc) -testFindComp26 = testEqv "testFindComp26" compvocab $ vbmVocab (head compca) -testFindComp27 = testEqv "testFindComp27" compvocab $ vbmVocab (head compcd) -testFindComp28 = testEqv "testFindComp28" compvocab $ vbmVocab (head compce) -testFindComp29 = testEqv "testFindComp29" compvocab $ vbmVocab (head compde) - -testFindComp31 = testHasEqv "testFindComp31" ["c","d","e"] $ vbmUsage (head compab) -testFindComp32 = testHasEqv "testFindComp32" ["b","d","e"] $ vbmUsage (head compac) -testFindComp33 = testHasEqv "testFindComp33" ["b","c","e"] $ vbmUsage (head compad) -testFindComp34 = testHasEqv "testFindComp34" ["c","d","e"] $ vbmUsage (head compba) -testFindComp35 = testHasEqv "testFindComp35" ["a","d","e"] $ vbmUsage (head compbc) -testFindComp36 = testHasEqv "testFindComp36" ["b","d","e"] $ vbmUsage (head compca) -testFindComp37 = testHasEqv "testFindComp37" ["a","b","e"] $ vbmUsage (head compcd) -testFindComp38 = testHasEqv "testFindComp38" ["a","b","d"] $ vbmUsage (head compce) -testFindComp39 = testHasEqv "testFindComp39" ["a","b","c"] $ vbmUsage (head compde) - -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 - -testFindComp41 = testEqv "testFindComp41" compResult $ (compApply compab) -testFindComp42 = testEqv "testFindComp42" compResult $ (compApply compac) -testFindComp43 = testEqv "testFindComp43" compResult $ (compApply compad) -testFindComp44 = testEqv "testFindComp44" compResult $ (compApply compba) -testFindComp45 = testEqv "testFindComp45" compResult $ (compApply compbc) -testFindComp46 = testEqv "testFindComp46" compResult $ (compApply compca) -testFindComp47 = testEqv "testFindComp47" compResult $ (compApply compcd) -testFindComp48 = testEqv "testFindComp48" compResult $ (compApply compce) -testFindComp49 = testEqv "testFindComp49" compResult $ (compApply compde) - -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 - -testFindComp51 = testJust "testFindComp51" jcompab -testFindComp52 = testJust "testFindComp52" jcompac -testFindComp53 = testJust "testFindComp53" jcompad -testFindComp54 = testNothing "testFindComp54" jcompae -testFindComp55 = testJust "testFindComp55" jcompba -testFindComp56 = testJust "testFindComp56" jcompbc -testFindComp57 = testNothing "testFindComp57" jcompbd -testFindComp58 = testNothing "testFindComp58" jcompbe -testFindComp59 = testJust "testFindComp59" jcompca -testFindComp60 = testJust "testFindComp60" jcompcd -testFindComp61 = testJust "testFindComp61" jcompce -testFindComp62 = testJust "testFindComp62" jcompde - -testFindCompSuite = TestList - [ testVarModifyName09, testVarModifyName10 - , testFindComp01, testFindComp02, testFindComp03, testFindComp04 - , testFindComp05, testFindComp06, testFindComp07, testFindComp08 - , testFindComp09, testFindComp10, testFindComp11, testFindComp12 - , testFindComp21, testFindComp22, testFindComp23, testFindComp24 - , testFindComp25, testFindComp26, testFindComp27, testFindComp28 - , testFindComp29 - , testFindComp31, testFindComp32, testFindComp33, testFindComp34 - , testFindComp35, testFindComp36, testFindComp37, testFindComp38 - , testFindComp39 - , testFindComp41, testFindComp42, testFindComp43, testFindComp44 - , testFindComp45, testFindComp46, testFindComp47, testFindComp48 - , testFindComp49 - ] - ------------------------------------------------------------- --- 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"] -vbdisj = vbaceq `union` vba0 - -filterconjunct :: VarBindingModify String Int -filterconjunct = makeVarFilterModify $ - varFilterConjunction - [ makeVarTestFilter (swishName "isZero") (==0) "a" - , varFilterEQ "a" "c"] -vbconj = vbaceq `intersect` vba0 - -testFilterName01 = testEq "testFilterName01" (swishName "filtertesta0") $ - vbmName filtertesta0 -testFilterName02 = testEq "testFilterName02" (swishName "filtertestc0") $ - vbmName filtertestc0 -testFilterName03 = testEq "testFilterName03" (swishName "varFilterEQ") $ - vbmName filtercompabeq -testFilterName04 = testEq "testFilterName04" (swishName "varFilterNE") $ - vbmName filtercompbcne -testFilterName05 = testEq "testFilterName05" (swishName "varFilterDisjunction") $ - vbmName filterdisjunct -testFilterName06 = testEq "testFilterName06" (swishName "varFilterConjunction") $ - vbmName filterconjunct - -testFilter01 = testEqv "testFilter01" vba0 $ vbmApply filtertesta0 testFilterBindings -testFilter02 = testEqv "testFilter02" vbc0 $ vbmApply filtertestc0 testFilterBindings -testFilter03 = testEqv "testFilter03" vbabeq $ vbmApply filtercompabeq testFilterBindings -testFilter04 = testEqv "testFilter04" vbaceq $ vbmApply filtercompaceq testFilterBindings -testFilter05 = testEqv "testFilter05" vbbceq $ vbmApply filtercompbceq testFilterBindings -testFilter06 = testEqv "testFilter06" vbbcne $ vbmApply filtercompbcne testFilterBindings -testFilter07 = testEqv "testFilter07" vbdisj $ vbmApply filterdisjunct testFilterBindings -testFilter08 = testEqv "testFilter08" vbconj $ vbmApply filterconjunct testFilterBindings - -testFilter10 = testEqv "testFilter10" testFilterBindings $ - vbmApply varBindingId testFilterBindings - -testFilterSuite = TestList - [ testFilterName01, testFilterName02, testFilterName03 - , testFilterName04, testFilterName05, testFilterName06 - , testFilter01, testFilter02, testFilter03, testFilter04 - , testFilter05, testFilter06, testFilter07, testFilter08 - , testFilter10 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testVarBindingSuite - , testVarModifySuite - , testVarComposeSuite - , testFindCompSuite - , testFilterSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/VarBindingTest.hs,v $ --- $Author: graham $ --- $Revision: 1.6 $ --- $Log: VarBindingTest.hs,v $ --- Revision 1.6 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.5 2003/12/08 16:58:27 graham --- Add name to variable binding modifiers and filters. --- Add namespace for Swish-defined names. --- --- Revision 1.4 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.3 2003/10/15 16:40:52 graham --- Reworked RDFQuery to use new query binding framework. --- (Note: still uses VarBindingFilter rather than VarBindingModify. --- The intent is to incorproate the VarBindingModify logic into RDFProof, --- displaying the existing use of BindingFilter.) --- --- Revision 1.2 2003/10/15 00:07:01 graham --- Added variable binding filter structures, and some common filters --- --- Revision 1.1 2003/10/14 20:30:58 graham --- Add separate module for generic variable binding functions. --- diff --git a/Swish/HaskellRDF/Vocabulary.hs b/Swish/HaskellRDF/Vocabulary.hs deleted file mode 100644 --- a/Swish/HaskellRDF/Vocabulary.hs +++ /dev/null @@ -1,314 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: Vocabulary.hs,v 1.7 2004/01/07 19:49:13 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Vocabulary --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines some commonly used vocabulary terms, --- using the Namespace and ScopedName data types. --- --------------------------------------------------------------------------------- - -module Swish.HaskellRDF.Vocabulary - ( namespaceNull - , namespaceRDF - , namespaceRDFS - , namespaceRDFD - , namespaceRDFC - , namespaceRDFO - , namespaceOWL - , namespaceXSD - , namespaceXsdType - , namespaceMATH - , namespaceLOG - , namespaceDAML - , namespaceDefault - , namespaceSwish, swishName - , namespaceLang, langName, langTag, isLang - , scopeRDF - , scopeRDFS - , scopeRDFD - , rdf_datatype, rdf_resource, rdf_about, rdf_ID - , rdf_type - , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral - , rdfs_member - , rdfd_GeneralRestriction - , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality - , owl_sameAs - , xsd_type, xsd_string, xsd_boolean - , xsd_decimal, xsd_integer - , xsd_nonneg_integer, xsd_nonpos_integer, xsd_pos_integer, xsd_neg_integer - , xsd_float, xsd_double - , operator_plus, operator_minus, operator_slash, operator_star - , default_base - ) -where - -import Swish.HaskellUtils.Namespace - ( Namespace(..), ScopedName(..) ) - -import Swish.HaskellUtils.MiscHelpers - ( lower ) - ------------------------------------------------------------- --- Define some common namespace values ------------------------------------------------------------- - -namespaceNull :: Namespace -namespaceNull - = Namespace "" "" - -namespaceRDF :: Namespace -namespaceRDF = - Namespace "rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" - -namespaceRDFS :: Namespace -namespaceRDFS = - Namespace "rdfs" "http://www.w3.org/2000/01/rdf-schema#" - -namespaceRDFD :: Namespace -namespaceRDFD = - Namespace "rdfd" "http://id.ninebynine.org/2003/rdfext/rdfd#" - -namespaceRDFC :: Namespace -namespaceRDFC = - Namespace "rdfc" "http://id.ninebynine.org/2003/rdfext/rdfc#" - -namespaceRDFO :: Namespace -namespaceRDFO = - Namespace "rdfo" "http://id.ninebynine.org/2003/rdfext/rdfo#" - -namespaceOWL :: Namespace -namespaceOWL = - Namespace "owl" "http://www.w3.org/2002/07/owl#" - -namespaceXSD :: Namespace -namespaceXSD = - Namespace "xsd" "http://www.w3.org/2001/XMLSchema#" - -namespaceXsdType :: String -> Namespace -namespaceXsdType dtname = - Namespace ("xsd_"++dtname) - ("http://id.ninebynine.org/2003/XMLSchema/"++dtname++"#") - -namespaceMATH :: Namespace -namespaceMATH = - Namespace "math" "http://www.w3.org/2000/10/swap/math#" - -namespaceLOG :: Namespace -namespaceLOG = - Namespace "log" "http://www.w3.org/2000/10/swap/log.n3#" - -namespaceDAML :: Namespace -namespaceDAML = - Namespace "daml" "http://www.daml.org/2000/10/daml-ont#" - -namespaceDefault :: Namespace -namespaceDefault - = Namespace "default" "http://id.ninebynine.org/default/" - -namespaceSwish :: Namespace -namespaceSwish - = Namespace "swish" "http://id.ninebynine.org/2003/Swish/" - -swishName :: String -> ScopedName -swishName local = ScopedName namespaceSwish local - ------------------------------------------------------------ --- Language tags ------------------------------------------------------------- --- --- Note: simple language tag URIs may be abbreviated as lang:tag, --- but if the tag contains ahyphen, 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 m,ay change that). - -namespaceLang :: Namespace -namespaceLang - = Namespace "lang" "http://id.ninebynine.org/2003/Swish/Lang/" - -- To be replaced by urn:ietf:params:lang? - -langName :: String -> ScopedName -langName tag = ScopedName namespaceLang (lower tag) - -langTag :: ScopedName -> String -langTag sname = snLocal sname - -isLang :: ScopedName -> Bool -isLang sname = snScope sname == namespaceLang - ------------------------------------------------------------- --- Define namespaces for RDF rules, axioms, etc ------------------------------------------------------------- - -scopeRDF :: Namespace -scopeRDF = - Namespace "rs_rdf" "http://id.ninebynine.org/2003/Ruleset/rdf#" - -scopeRDFS :: Namespace -scopeRDFS = - Namespace "rs_rdfs" "http://id.ninebynine.org/2003/Ruleset/rdfs#" - -scopeRDFD :: Namespace -scopeRDFD = - Namespace "rs_rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" - ------------------------------------------------------------- --- Define some common vocabulary terms ------------------------------------------------------------- - -rdf_datatype :: ScopedName -rdf_datatype = ScopedName namespaceRDF "datatype" - -rdf_resource :: ScopedName -rdf_resource = ScopedName namespaceRDF "resource" - -rdf_about :: ScopedName -rdf_about = ScopedName namespaceRDF "about" - -rdf_ID :: ScopedName -rdf_ID = ScopedName namespaceRDF "ID" - -rdf_type :: ScopedName -rdf_type = ScopedName namespaceRDF "type" - -rdf_first :: ScopedName -rdf_first = ScopedName namespaceRDF "first" - -rdf_rest :: ScopedName -rdf_rest = ScopedName namespaceRDF "rest" - -rdf_nil :: ScopedName -rdf_nil = ScopedName namespaceRDF "nil" - -rdf_XMLLiteral :: ScopedName -rdf_XMLLiteral = ScopedName namespaceRDF "XMLLiteral" - -rdfs_member :: ScopedName -rdfs_member = ScopedName namespaceRDFS "member" - -rdfd_GeneralRestriction :: ScopedName -rdfd_GeneralRestriction = ScopedName namespaceRDFD "GeneralRestriction" - -rdfd_onProperties :: ScopedName -rdfd_onProperties = ScopedName namespaceRDFD "onProperties" - -rdfd_constraint :: ScopedName -rdfd_constraint = ScopedName namespaceRDFD "constraint" - -rdfd_maxCardinality :: ScopedName -rdfd_maxCardinality = ScopedName namespaceRDFD "maxCardinality" - -xsd_type :: String -> ScopedName -xsd_type typnam = ScopedName namespaceXSD typnam - -xsd_string :: ScopedName -xsd_string = xsd_type "string" - -xsd_boolean :: ScopedName -xsd_boolean = xsd_type "boolean" - -xsd_decimal :: ScopedName -xsd_decimal = xsd_type "decimal" - -xsd_integer :: ScopedName -xsd_integer = xsd_type "integer" - -xsd_nonneg_integer :: ScopedName -xsd_nonneg_integer = xsd_type "nonNegativeInteger" - -xsd_nonpos_integer :: ScopedName -xsd_nonpos_integer = xsd_type "nonPositiveInteger" - -xsd_pos_integer :: ScopedName -xsd_pos_integer = xsd_type "positiveInteger" - -xsd_neg_integer :: ScopedName -xsd_neg_integer = xsd_type "negativeInteger" - -xsd_float :: ScopedName -xsd_float = xsd_type "float" - -xsd_double :: ScopedName -xsd_double = xsd_type "double" - -owl_sameAs :: ScopedName -owl_sameAs = ScopedName namespaceOWL "sameAs" - -operator_plus :: ScopedName -operator_plus = ScopedName namespaceRDFO "plus" - -operator_minus :: ScopedName -operator_minus = ScopedName namespaceRDFO "minus" - -operator_slash :: ScopedName -operator_slash = ScopedName namespaceRDFO "slash" - -operator_star :: ScopedName -operator_star = ScopedName namespaceRDFO "star" - -default_base :: ScopedName -default_base = ScopedName namespaceDefault "base" - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellRDF/Vocabulary.hs,v $ --- $Author: graham $ --- $Revision: 1.7 $ --- $Log: Vocabulary.hs,v $ --- Revision 1.7 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.6 2004/01/06 16:29:56 graham --- Fix up module exports to avoid GHC warnings --- --- Revision 1.5 2003/12/16 07:05:37 graham --- Working on updated RDFProofContext --- --- Revision 1.4 2003/12/11 19:11:07 graham --- Script processor passes all initial tests. --- --- Revision 1.3 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.2 2003/12/08 16:58:27 graham --- Add name to variable binding modifiers and filters. --- Add namespace for Swish-defined names. --- --- Revision 1.1 2003/11/24 17:20:35 graham --- Separate module Vocabulary from module Namespace. --- diff --git a/Swish/HaskellUtils/AccumulateM.hs b/Swish/HaskellUtils/AccumulateM.hs deleted file mode 100644 --- a/Swish/HaskellUtils/AccumulateM.hs +++ /dev/null @@ -1,143 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} -{-# OPTIONS -XFunctionalDependencies #-} -{-# OPTIONS -XFlexibleInstances #-} - --------------------------------------------------------------------------------- --- $Id: AccumulateM.hs,v 1.3 2004/01/22 19:53:46 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : AccummulateM --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a monadic accumulator type. The plan is that it be --- used in conjunction with FunctorM and similar constructs to accumulate --- some or all of the values visited. --- --- Using a monad of type Accumulator, which wraps some type 'c' and is --- also declared to be an instance of MonadAccum Accumulator c e, for some e, --- then foldM can be used to accumulate values of type e with an initial --- value of type c with the instance-supplied growVal method. --- --- This module also declares accumulator instances for Int, Integer and list --- datatypes. --- --- This is all very well, but rather unnecessary: it is just as easy, and --- more standard (hence easier for other Haskell programmers to follow), --- to use a state monad with a nullary return type; e.g. --- execsState (stateMonadExpr) initialState --- which returns the final state value. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.AccumulateM - ( Accumulator(..) ) -where - -import Control.Monad - ( foldM ) - - -class (Monad m) => MonadAccum m c e | m c -> e where - growVal :: c -> e -> m c - reapVal :: m c -> c - -data Accumulator c = Accumulator c deriving (Eq, Show) - -instance Monad Accumulator where - (Accumulator v) >>= k = k v - return v = Accumulator v - -instance MonadAccum Accumulator Int Int where - growVal n m = Accumulator (n+m) - reapVal (Accumulator n) = n - -instance MonadAccum Accumulator Integer Integer where - growVal n m = Accumulator (n+m) - reapVal (Accumulator n) = n - -instance MonadAccum Accumulator [v] v where - growVal vs v = Accumulator (v:vs) - reapVal (Accumulator vs) = vs - - --- Tests -addVal :: Int -> Int -> (Accumulator Int) -addVal m n = Accumulator (n+m) - -testList = [1,2,3,4,5,6] :: [Int] -testList1 = [1,2,3,4,5,6] :: [Integer] -testList2 = "plugh" - -test1 = foldM addVal 0 testList -test2 = Accumulator 0 -test3 = (Accumulator 0) >>= addVal 1 -test4 = (Accumulator 5) >>= addVal 5 -test5 = (growVal 3 :: Int -> Accumulator Int) 20 -test6 = foldM growVal 0 testList :: Accumulator Int -test7 = foldM growVal 0 testList1 :: Accumulator Integer -test8 = reapVal (foldM growVal 0 testList :: Accumulator Int) -test9 = reapVal (foldM growVal [] testList2 :: Accumulator [Char]) - -test = and - [ test1 == Accumulator 21 - , test2 == Accumulator 0 - , test3 == Accumulator 1 - , test4 == Accumulator 10 - , test5 == Accumulator 23 - , test6 == Accumulator 21 - , test7 == Accumulator 21 - , test8 == 21 - , test9 == "hgulp" - ] - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/AccumulateM.hs,v $ --- $Author: graham $ --- $Revision: 1.3 $ --- $Log: AccumulateM.hs,v $ --- Revision 1.3 2004/01/22 19:53:46 graham --- Sync. --- --- Revision 1.2 2004/01/13 17:12:08 graham --- Complete functionality of AccumulateM, using functional dependencies --- in the MonadAccum type class. --- --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.2 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.1 2003/06/12 00:49:04 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- diff --git a/Swish/HaskellUtils/DateTime.hs b/Swish/HaskellUtils/DateTime.hs deleted file mode 100644 --- a/Swish/HaskellUtils/DateTime.hs +++ /dev/null @@ -1,391 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: DateTime.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : DateTime --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module defines a collection of date/time manipulation functions. --- --- Date/time value manipulation. --- --- Date/time can be date-only or time-only --- --- type DateTime is an instance of built-in classes Eq and Show --- type DateTime has a constructor that accepts a string in the format --- defined by RFC 3339. --- Timezone interpretation is per RFC3339. --- --------------------------------------------------------------------------------- --- --- year,month,day,hour,min,sec,millisec,timezone ---class (Show a,Eq a) => DateTimeClass a where --- newDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> a --- toString :: a -> String --- size :: a -> Int --- toDateTime :: String -> a --- toDate :: String -> a --- toTime :: String -> a --- (==) :: a -> a -> Bool -- same date/time --- (<) :: a -> a -> Bool -- first precedes second --- (+) :: a -> a -> a -- advance by time --- (-) :: a -> a -> a -- difference between times --- dtShow :: a -> String -- return string form --- dtYear :: a -> Int --- dtMonth :: a -> Int --- dtDay :: a -> Int --- dtHour :: a -> Int --- dtMinute :: a -> Int --- dtSecond :: a -> Int --- dtMillisecs :: a -> Int --- dtTimezone :: a -> Int -- time zone offset in minutes --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.DateTime where - -data DateTime - = DateTime Int Int Int Int Int Int Int Int - -instance Eq DateTime where - d1 == d2 = simpleEq ( normTZ d1 ) ( normTZ d2 ) - -instance Show DateTime where - show dt = dtShow dt - -instance Ord DateTime where - dt1 < dt2 = simpleLT ( normTZ dt1 ) ( normTZ dt2 ) - dt1 > dt2 = dt2 < dt1 - dt1 <= dt2 = (dt1 < dt2)||(dt1==dt2) - dt1 >= dt2 = (dt2 < dt1)||(dt1==dt2) - -leapYear :: Int -> Bool -leapYear year - | ( year `mod` 4 == 0 ) && - not ( ( year `mod` 100 == 0 ) && - not ( year `mod` 400 == 0 ) ) = True - | otherwise = False - -daysInMonth :: Int -> Int -> Int -daysInMonth month year - | month==1 = 31 --Jan - | month==2 = if leapYear year then 29 else 28 --Feb - | month==3 = 31 --Mar - | month==4 = 30 --Apr - | month==5 = 31 --May - | month==6 = 30 --Jun - | month==7 = 31 --Jul - | month==8 = 31 --Aug - | month==9 = 30 --Sep - | month==10 = 31 --Oct - | month==11 = 30 --Nov - | month==12 = 31 --Dec - | otherwise = 0 - -validJulianDate :: Int -> Int -> Int -> Bool -validJulianDate yr mo da - | yr < 1900 = False - | mo > 12 = False - | da > (daysInMonth mo yr) = False - | otherwise = True - -toJulianDate1 :: DateTime -> Int -toJulianDate1 (DateTime y m d _ _ _ _ _) = toJulianDate y m d - -toJulianDate :: Int -> Int -> Int -> Int -toJulianDate year month day --- | not (validJulianDate year month day) = -1 - | year==1900 && month<=2 = if month==2 then day + 30 else day - 1 - | month>=3 = toJD1 (year-1900) (month-3) (day) - | otherwise = toJD1 (year-1901) (month+9) (day) - where - toJD1 :: Int -> Int -> Int -> Int - toJD1 year month day - = ( (1461*year) `div` 4 ) - - (year `div` 100) + - ((year+300) `div` 400) + - ( ( (153*month) + 2 ) `div` 5 ) + - day + 58 - -fromJulianDate:: Int -> DateTime -fromJulianDate jdate - | jdate <= 58 = fromJD1 jdate - | otherwise = fromJD2 jdate - where - fromJD1 :: Int -> DateTime - fromJD1 jdate - | jdate<=30 = (DateTime 1900 1 (jdate+1 ) 0 0 0 0 0) - | otherwise = (DateTime 1900 2 (jdate-30) 0 0 0 0 0) - - fromJD2 :: Int -> DateTime - fromJD2 j - = DateTime y2 m2 d1 0 0 0 0 0 - where --- t1 = (400*(j+((j+36467)`div`36525)-((j+109517)`div`dc))) - 23638 -- 1/400-days from 1900-02-28 [t] - t1 = (400* - (j - +((4*(j+36465))`div`146097) - -((j+109513)`div`146097))) - 23638 -- 1/400-days from 1900-02-28 [t] - dc = 146100 -- days in cycle period (400 years) = 1/400-days in year - t2 = ( ( t1 `mod` dc ) `div` 400 )*5 + 2 -- fifth-days into year, +2 [j3] - d1 = ( t2 `mod` 153 ) `div` 5 + 1 -- day of month (magic number 153) [d] - m1 = t2 `div` 153 -- month Mar=0 -> Feb=11 [j4] - m2 = if m1 <= 9 then m1+3 else m1-9 -- correct month to Jan=1 -> Dec=12 [m] - y1 = t1 `div` dc + 1900 -- year from 1900-02-28 - y2 = if m1 <= 9 then y1 else y1+1 -- correct year for month wrap-around - -- 36525 = days/century, not counting century adjustments - -- 109517 = 146100 * (1900-1600)/400 - 58 - -- 23238 = 58*400 + 38 ??? 38=152/4 ?? - -{- -- this code works for dates before 2100 only - t1 = (4*j) - 233 -- quarter-days from 1900-02-28 - dc = 1461 -- days in cycle period (4 years) = quarter-days in year - t2 = ( ( t1 `mod` dc ) `div` 4 )*5 + 2 -- fifth-days into year, +2 - d1 = ( t2 `mod` 153 ) `div` 5 + 1 -- day of month (magic number 153) - m1 = t2 `div` 153 -- month Mar=0 -> Feb=11 - m2 = if m1 <= 9 then m1+3 else m1-9 -- correct month to Jan=1 -> Dec=12 - y1 = t1 `div` dc + 1900 -- year from 1900-02-28 - y2 = if m1 <= 9 then y1 else y1+1 -- correct year for month wrap-around --} - -date :: Int -> Int -> Int -> DateTime -date y m d = DateTime y m d 0 0 0 0 0 - -time :: Int -> Int -> Int -> Int -> Int -> DateTime -time h m s ms z = DateTime 0 0 0 h m s ms z - -dtYear :: DateTime -> Int -dtMonth :: DateTime -> Int -dtDay :: DateTime -> Int -dtHour :: DateTime -> Int -dtMinute :: DateTime -> Int -dtSecond :: DateTime -> Int -dtMillisecs :: DateTime -> Int -dtTimezone :: DateTime -> Int -- time zone offset in minutes -dtYear ( DateTime x _ _ _ _ _ _ _ ) = x -dtMonth ( DateTime _ x _ _ _ _ _ _ ) = x -dtDay ( DateTime _ _ x _ _ _ _ _ ) = x -dtHour ( DateTime _ _ _ x _ _ _ _ ) = x -dtMinute ( DateTime _ _ _ _ x _ _ _ ) = x -dtSecond ( DateTime _ _ _ _ _ x _ _ ) = x -dtMillisecs ( DateTime _ _ _ _ _ _ x _ ) = x -dtTimezone ( DateTime _ _ _ _ _ _ _ x ) = x - -lenFix :: String -> Int -> String -lenFix inStr newLen - | length inStr >= newLen = inStr - | otherwise = lenFix ('0':inStr) newLen - -showTZ :: Int -> String -showTZ tz - | tz<0 = "-" ++ showTZabs ( -tz ) - | tz==0 = showTZabs ( tz ) - | otherwise = "+" ++ showTZabs ( tz ) - -showTZabs :: Int -> String -showTZabs tz - | tz==0 = "Z" - | otherwise = lenFix ( show ( tz `div` 60 ) ) 2 ++ ":" ++ - lenFix ( show ( tz `mod` 60 ) ) 2 - -showTime :: DateTime -> String -showTime ( DateTime yr mo da hr mi se ms tz ) - | ms==0 = lenFix ( show hr ) 2 ++ ":" ++ - lenFix ( show mi ) 2 ++ ":" ++ - lenFix ( show se ) 2 - | otherwise = lenFix ( show hr ) 2 ++ ":" ++ - lenFix ( show mi ) 2 ++ ":" ++ - lenFix ( show se ) 2 ++ "." ++ - lenFix ( show ms ) 3 - -showDate :: DateTime -> String -showDate ( DateTime yr mo da hr mi se ms tz ) - = lenFix ( show yr ) 4 ++ "-" ++ - lenFix ( show mo ) 2 ++ "-" ++ - lenFix ( show da ) 2 - -dtShow :: DateTime -> String -- return string form -dtShow ( DateTime yr mo da hr mi se ms tz ) - = showDate ( DateTime yr mo da hr mi se ms tz ) ++ "T" ++ - showTime ( DateTime yr mo da hr mi se ms tz ) ++ showTZ tz - -carryMins :: DateTime -> DateTime -carryMins ( DateTime yr mo da hr mi se ms tz ) - | newhrs >= 24 = carryHours ( DateTime yr mo da newhrs (mi`mod`60) se ms tz ) - | otherwise = ( DateTime yr mo da newhrs (mi`mod`60) se ms tz ) - where - newhrs = (hr+(mi`div`60)) - -carryHours :: DateTime -> DateTime -carryHours ( DateTime yr mo da hr mi se ms tz ) - = ( DateTime y m d (hr`mod`24) mi se ms tz ) - where - (DateTime y m d _ _ _ _ _) = fromJulianDate ((toJulianDate yr mo da)+ (hr`div`24)) - -normTZ :: DateTime -> DateTime -normTZ ( DateTime yr mo da hr mi se ms tz ) - = carryMins ( DateTime yr mo da hr (mi-tz) se ms 0 ) --- = addMinutes (-tz) ( DateTime yr mo da hr mi se ms tz ) - -{- another way -} - -addMilliSecs addms ( DateTime yr mo da hr mi se ms tz ) - | totms < 1000 = DateTime yr mo da hr mi se totms tz - | otherwise = addSeconds addse ( DateTime yr mo da hr mi se newms tz ) - where - totms = (ms+addms) - newms = totms `mod` 1000 - addse = totms `div` 1000 - -addSeconds addse ( DateTime yr mo da hr mi se ms tz ) - | totse < 60 = DateTime yr mo da hr mi totse ms tz - | otherwise = addMinutes addmi ( DateTime yr mo da hr mi newse ms tz ) - where - totse = (se+addse) - newse = totse `mod` 60 - addmi = totse `div` 60 - -addMinutes addmi ( DateTime yr mo da hr mi se ms tz ) - | totmi < 60 = DateTime yr mo da hr totmi se ms tz - | otherwise = addHours addhr ( DateTime yr mo da hr newmi se ms tz ) - where - totmi = (mi+addmi) - newmi = totmi `mod` 60 - addhr = totmi `div` 60 - -addHours addhr ( DateTime yr mo da hr mi se ms tz ) - | tothr < 24 = DateTime yr mo da tothr mi se ms tz - | otherwise = addDays addda ( DateTime yr mo da newhr mi se ms tz ) - where - tothr = (hr+addhr) - newhr = tothr `mod` 24 - addda = tothr `div` 24 - -addDays addda ( DateTime yr mo da hr mi se ms tz ) - = DateTime newyr newmo newda hr mi se ms tz - where - -- newdate = fromJulianDate (toJulianDate yr mo (da+addda) ) - -- newyr = dtYear newdate - -- newmo = dtMonth newdate - -- newda = dtDay newdate - DateTime newyr newmo newda _ _ _ _ _ = fromJulianDate ( (toJulianDate yr mo da)+addda ) - -{- another way -} - -simpleEq :: DateTime -> DateTime -> Bool ---simpleEq ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) = ( ( yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) == ( yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) ) -simpleEq ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) = ( ( yr1 == yr2 ) && ( mo1 == mo2 ) && ( da1 == da2 ) && ( hr1 == hr2 ) && ( mi1 == mi2 ) && ( se1 == se2 ) && ( ms1 == ms2 ) && ( tz1 == tz2 ) ) - -simpleLT :: DateTime -> DateTime -> Bool -simpleLT ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) - | (yr1>= f = f a - (Error e) >>= _ = Error e - return = Result - fail e = Error e - --- |MonadPlus instance for Error -instance MonadPlus ErrorM where - mzero = Error "No result" - mplus (Error _) r = r - mplus r _ = r - ------------------------------------------------------------- --- Either ------------------------------------------------------------- - --- |Monad instance for (Either String b) -instance Monad (Either String) where - (Left a) >>= _ = Left a - (Right b) >>= f = f b - return = Right - fail a = Left a - --- |MonadPlus instance for (Either String b) -instance MonadPlus (Either String) where - mzero = Left "No result" - mplus (Left _) r = r - mplus b _ = b - --- |Map maybe to (Either String) error monad -eitherErrMaybe :: String -> (a->b) -> Maybe a -> Either String b -eitherErrMaybe err f mv = case mv of - Nothing -> Left err - Just v -> Right (f v) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ErrorM.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ErrorM.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.5 2003/12/10 03:48:57 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/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.2 2003/12/03 15:42:53 graham --- Add instance declaration for MonadPlus --- --- Revision 1.1 2003/12/01 21:14:39 graham --- Added module ErrorM --- diff --git a/Swish/HaskellUtils/FunctorM.hs b/Swish/HaskellUtils/FunctorM.hs deleted file mode 100644 --- a/Swish/HaskellUtils/FunctorM.hs +++ /dev/null @@ -1,105 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: FunctorM.hs,v 1.2 2004/01/13 17:12:08 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : FunctorM --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a monadic functor class, that allows a monadic --- computation to be performed, functor-style, over some container --- structure. The advantage of this compared with a normal functor --- is that it allows values to be accumulated from the computation --- (in a Monad instance) at the same time as (optionally) applying --- transformations to each of the contained values. --- --- Acknowledgement: based on a message by Tomasz Zielonka sent to --- the Haskell mailing list on 4 June 2003. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.FunctorM - ( FunctorM(..) - ) -where - -class FunctorM t where - fmapM :: Monad m => (a -> m b) -> (t a -> m (t b)) - -- Try to generalise accumulating values? - -- fmapQM :: Monad m => m b -> (b -> a -> m b) -> (t a -> m b) - fmapM_ :: Monad m => (a -> m b) -> (t a -> m ()) - fmapM_ f t = fmapM f t >> return () - -instance FunctorM [] where - fmapM = mapM - fmapM_ = mapM_ - -{- Another example: - -data Arc lb = Arc { asubj, apred, aobj :: lb } - deriving (Eq, Show) - -instance Functor Arc where - fmap f (Arc s p o) = Arc (f s) (f p) (f o) - -instance FunctorM Arc where - -- fmapM :: (lb -> m l2) -> Arc lb -> m (Arc l2) - fmapM f (Arc s p o) = - do { s' <- f s - ; p' <- f p - ; o' <- f o - ; return $ Arc s' p' o' - } - --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/FunctorM.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: FunctorM.hs,v $ --- Revision 1.2 2004/01/13 17:12:08 graham --- Complete functionality of AccumulateM, using functional dependencies --- in the MonadAccum type class. --- --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.3 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.2 2003/06/12 00:49:04 graham --- Basic query processor runs test cases OK. --- Proof framework compiles, not yet tested. --- --- Revision 1.1 2003/06/10 17:34:29 graham --- Create FunctorM module --- diff --git a/Swish/HaskellUtils/ListHelpers.hs b/Swish/HaskellUtils/ListHelpers.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ListHelpers.hs +++ /dev/null @@ -1,495 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ListHelpers.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ListHelpers --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines some generic list and related helper functions. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.ListHelpers - ( select, mapset, deleteIndex - , subset, equiv, hasPartitions, addSetElem - , headOrNothing - , pairUngroup, pairsUngroup, pairSort, pairGroup - , breakAll - , powerSet, combinations - , permutations, listProduct - , powerSequences, powerSequences_len, powerSequences_inf - , flist, ffold, allf, anyf, allp, anyp ) -where - -import Data.List( union, intersect, sortBy, groupBy ) - ------------------------------------------------------------- --- Generic helpers ------------------------------------------------------------- - --- |Select is like filter, except that it tests one list to select --- elements from a second list. -select :: ( a -> Bool ) -> [a] -> [b] -> [b] -select _ [] [] = [] -select f (e1:l1) (e2:l2) - | f e1 = e2:(select f l1 l2) - | otherwise = (select f l1 l2) -select _ _ _ = error "select supplied with different length lists" - --- |Collect set of values from list under supplied mapping function -mapset :: Eq b => ( a -> b ) -> [a] -> [b] -mapset _ [] = [] -mapset f (e:l) = [f e] `union` (mapset f l) - --- |Delete the n'th element of a list, returning the result --- --- If the list doesn't have an n'th element, return the list unchanged. --- -deleteIndex :: [a] -> Int -> [a] -deleteIndex [] _ = [] -deleteIndex xxs@(x:xs) n - | n < 0 = xxs - | n == 0 = xs - | otherwise = x:deleteIndex xs (n-1) - -{- -testdi1 = deleteIndex [1,2,3,4] 0 == [2,3,4] -testdi2 = deleteIndex [1,2,3,4] 1 == [1,3,4] -testdi3 = deleteIndex [1,2,3,4] 2 == [1,2,4] -testdi4 = deleteIndex [1,2,3,4] 3 == [1,2,3] -testdi5 = deleteIndex [1,2,3,4] 4 == [1,2,3,4] -testdi6 = deleteIndex [1,2,3,4] (-1) == [1,2,3,4] -testdi = and - [ testdi1, testdi2, testdi3, testdi4, testdi5, testdi6 ] --} - ------------------------------------------------------------- --- Set functions ------------------------------------------------------------- - --- |Subset test - -subset :: (Eq a) => [a] -> [a] -> Bool -a `subset` b = and [ ma `elem` b | ma <- a ] - --- |Set equivalence test - -equiv :: (Eq a) => [a] -> [a] -> Bool -a `equiv` b = (a `subset` b) && (b `subset` a) - --- |Set partition test --- --- Is it possible to be more efficient here? --- Maybe something like sort/merge/compare? -hasPartitions :: (Eq a) => [a] -> ([a],[a]) -> Bool -a `hasPartitions` (b1,b2) = - (null (b1 `intersect` b2)) && (a `equiv` (b1 `union` b2)) - --- |Add element to set - -addSetElem :: (Eq a) => a -> [a] -> [a] -addSetElem e es = if e `elem` es then es else e:es - ------------------------------------------------------------- --- Lists and Maybes ------------------------------------------------------------- - --- |Return head of a list of Maybe's, or Nothing if list is empty --- --- Use with 'filter isJust' to select a non-Nothing value from a --- list when such a value is present. --- -headOrNothing :: [Maybe a] -> Maybe a -headOrNothing [] = Nothing -headOrNothing (a:_) = a - ------------------------------------------------------------- --- Filter, ungroup, sort and group pairs by first member ------------------------------------------------------------- - -pairSelect :: ((a,b) -> Bool) -> ((a,b) -> c) -> [(a,b)] -> [c] -pairSelect p f as = map f (filter p as) - -pairUngroup :: (a,[b]) -> [(a,b)] -pairUngroup (a,bs) = [ (a,b) | b <- bs ] - -pairsUngroup :: [(a,[b])] -> [(a,b)] -pairsUngroup ps = [ (a,b) | (a,bs) <- ps, b <- bs ] - -pairSort :: (Ord a) => [(a,b)] -> [(a,b)] -pairSort ps = sortBy compareFirst ps - where - compareFirst (a1,_) (a2,_) = compare a1 a2 - -pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])] -pairGroup ps = map (factor . unzip) $ groupBy eqFirst $ pairSort ps - where - factor ((a:_),bs) = (a,bs) - eqFirst (a1,_) (a2,_) = a1 == a2 - ------------------------------------------------------------- --- Separate list into sublists ------------------------------------------------------------- - --- |Break list into a list of sublists, separated by element --- satisfying supplied condition. -breakAll :: (a -> Bool) -> [a] -> [[a]] -breakAll _ [] = [] -breakAll p s = let (h,s') = break p s - in h : breakAll p (drop 1 s') - ------------------------------------------------------------- --- Powerset ------------------------------------------------------------- - --- [[[TBD... there's a much better implementation in my email, --- from Christopher Hendrie. This is the raw code.]]] -{- ->ranked_powerset :: [a] -> [[[a]]] ->ranked_powerset = takeWhile (not . null) . foldr next_powerset ([[]] : -repeat []) -> ->next_powerset :: a -> [[[a]]] -> [[[a]]] ->next_powerset x r = zipWith (++) ([] : map (map (x:)) r) r -> ->powerset :: [a] -> [[a]] ->powerset = tail . concat . ranked_powerset --} - --- |Powerset of a list, in ascending order of size. --- Assumes the supplied list has no duplicate elements. -powerSet :: [a] -> [[a]] -powerSet as = - concatMap (flip combinations as) [1..length as] - --- |Combinations of n elements from a list, each being returned in the --- order that they appear in the list. -combinations :: Int -> [a] -> [[a]] -combinations _ [] = [] -- Don't include empty combinations -combinations n as@(ah:at) - | n <= 0 = [[]] - | n > length as = [] - | n == length as = [as] - | otherwise = (map (ah:) $ combinations (n-1) at) ++ - (combinations n at) - -{- --- |Return list of integers from lo to hi. -intRange :: Int -> Int -> [Int] -intRange lo hi = take (hi-lo+1) (iterate (+1) 1) --} - -{- --- Tests -testcomb0 = combinations 0 "abcd" -- [] -testcomb1 = combinations 1 "abcd" -- ["a","b","c","d"] -testcomb2 = combinations 2 "abcd" -- ["ab","ac","ad","bc","bd","cd"] -testcomb3 = combinations 3 "abcd" -- ["abc","abd","acd","bcd"] -testcomb4 = combinations 4 "abcd" -- ["abcd"] -testcomb5 = combinations 5 "abcd" -- [] -testpower = powerSet "abc" -- ["a","b","c","ab","ac","bc","abc"] --} - ------------------------------------------------------------- --- Permutations of a list ------------------------------------------------------------- - --- This algorithm is copied from an email by S.D.Mechveliani --- http://www.dcs.gla.ac.uk/mail-www/haskell/msg01936.html -permutations :: [a] -> [[a]] -permutations [] = [[]] -permutations (j:js) = addOne $ permutations js - where - addOne [] = [] - addOne (ks:pms) = (ao ks)++(addOne pms) - ao [] = [[j]] - ao (k:ks) = (j:k:ks):(map (k:) $ ao ks) - -{- -testperm = permutations [1,2,3] == - [[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]] --} - ------------------------------------------------------------- --- List product ------------------------------------------------------------- - --- |Given a list of lists, construct a new list of lists where --- each member of the new list is the same length as the original --- list, and each member corresponds to a different choice of --- one element from each of the original members in the --- corresponding position. Thus: --- --- listProduct [[a1,a2],[b1],[c1,c2]] = --- [ [a1,b1,c1], [a1,b1,c2], [a2,b1,c1], [a2,b1,c2] ] --- --- Note: The length of the resulting list is the prodicty of --- lengths of the components of the original list. Thus, if --- any member of the original list is empty then so is the --- resulting list: --- --- listProduct [[a1,a2],[],[c1,c2]] = [] --- --- NOTE: this is subsumed by 'sequence' --- -listProduct :: [[a]] -> [[a]] -listProduct [] = [[]] -listProduct (as:ass) = concat [ map (a:) (listProduct ass) | a <- as ] - -{- -test1 = listProduct [["a1","a2"],["b1"],["c1","c2"]] -test2 = listProduct [["a1","a2"],[],["c1","c2"]] - -lp [] = [[]] -lp (as:ass) = concatMap (\a -> (map (a:) (lp ass))) as --} - ------------------------------------------------------------- --- Powersequence (?) -- all sequences from some base values ------------------------------------------------------------- - --- |Function to choose all sequences of any length --- from a supplied set of values, returned in --- increasing length. -powerSequences :: [a] -> [[a]] -powerSequences rs = concat $ powerSeq_bylen rs [[]] - --- |Construct list of lists of sequences of increasing length -powerSeq_bylen :: [a] -> [[a]] -> [[[a]]] -powerSeq_bylen rs ps = (ps:powerSeq_bylen rs ns) where ns = powerSeq_next rs ps - --- |Return sequences of length n+1 given original sequence --- and list of all sequences of length n -powerSeq_next :: [a] -> [[a]] -> [[a]] -powerSeq_next rs rss = [ h:t | t <- rss, h <- rs ] - --- |Return all powersequences of a given length -powerSequences_len :: Int -> [a] -> [[a]] -powerSequences_len len rs = head $ drop len $ powerSeq_bylen rs [[]] - --- |Return all powersequences of indefinite length --- Observe that any such powersequence will consist of a sequence --- of a finite length sequence followed by an indefinite number of --- copies of the head of the base set. To prevent duplicates, the --- generator constructs only sequences that do not end in the first --- member of the base set. -powerSequences_inf :: [a] -> [[a]] -powerSequences_inf rs = - map (++pst) $ []:(concat $ powerSeq_bylen rs psh) - where - psh = map (:[]) (tail rs) - pst = repeat $ head rs - -{- Powersequence tests -t0 = [1,2,3,4,5,6] -t1 = powerSequences t0 -t2 = take 15 t1 -t3 = powerSequences_len 3 t0 -t4 = powerSequences_inf t0 -t5 = map (take 6) $ take 15 t4 -t6 = take 15 (powerSequences_len 6 t0) -t7 = t5 == t6 -t8 = powerSequences_len1 3 t0 -t9 = t8 == t3 --} - ------------------------------------------------------------- --- Functions, lists and monads ------------------------------------------------------------- - --- |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] --} - --- |Fold result from list of functions applied to some value, --- returning the result of the fold. --- --- This is similar to the 'ap' function in the Monad library. --- -ffold :: (b->c->c) -> c -> [a->b] -> a -> c -ffold rf ri fs v = foldr rf ri (flist fs v) - -{- -ffoldtest0 = ffold ge4and True [(1+),(2+),(3+)] 0 -- False -ffoldtest1 = ffold ge4and True [(1+),(2+),(3+)] 1 -- False -ffoldtest2 = ffold ge4and True [(1+),(2+),(3+)] 2 -- False -ffoldtest3 = ffold ge4and True [(1+),(2+),(3+)] 3 -- True -ge4and v b = (v>=4 && b) -ffoldtest = and [not ffoldtest0,not ffoldtest1,not ffoldtest2,ffoldtest3] --} - --- |Test if application of all functions in list to a given value --- satisfies a given condition --- -allf :: (b->Bool) -> [a->b] -> a -> Bool -allf pf fs a = all pf (flist fs a) - -{- -allftest0 = allf (>=4) [(1+),(2+),(3+)] 0 -- False -allftest1 = allf (>=4) [(1+),(2+),(3+)] 1 -- False -allftest2 = allf (>=4) [(1+),(2+),(3+)] 2 -- False -allftest3 = allf (>=4) [(1+),(2+),(3+)] 3 -- True -allftest = and [not allftest0,not allftest1,not allftest2,allftest3] --} - --- |Test if application of any functions in list to a given value --- satisfies a given condition --- -anyf :: (b->Bool) -> [a->b] -> a -> Bool -anyf pf fs a = any pf (flist fs a) - -{- -anyftest0 = anyf (>=4) [(1+),(2+),(3+)] 0 -- False -anyftest1 = anyf (>=4) [(1+),(2+),(3+)] 1 -- True -anyftest2 = anyf (>=4) [(1+),(2+),(3+)] 2 -- True -anyftest3 = anyf (>=4) [(1+),(2+),(3+)] 3 -- True -anyftest = and [not anyftest0,anyftest1,anyftest2,anyftest3] --} - --- |Test if a value satisfies all predicates in a list --- -allp :: [a->Bool] -> a -> Bool -allp ps a = and (flist ps a) - -{- -allptest0 = allp [(>=1),(>=2),(>=3)] 0 -- False -allptest1 = allp [(>=1),(>=2),(>=3)] 1 -- False -allptest2 = allp [(>=1),(>=2),(>=3)] 2 -- False -allptest3 = allp [(>=1),(>=2),(>=3)] 3 -- True -allptest = and [not allptest0,not allptest1,not allptest2,allptest3] --} - --- |Test if a value satisfies any predicate in a list --- -anyp :: [a->Bool] -> a -> Bool -anyp ps a = or (flist ps a) - -{- -anyptest0 = anyp [(>=1),(>=2),(>=3)] 0 -- False -anyptest1 = anyp [(>=1),(>=2),(>=3)] 1 -- True -anyptest2 = anyp [(>=1),(>=2),(>=3)] 2 -- True -anyptest3 = anyp [(>=1),(>=2),(>=3)] 3 -- True -anyptest = and [not anyptest0,anyptest1,anyptest2,anyptest3] --} - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ListHelpers.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ListHelpers.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.16 2003/11/28 00:17:55 graham --- Datatype constraint test cases all passed. --- --- Revision 1.15 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.14 2003/10/24 21:05:09 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.13 2003/10/16 16:01:49 graham --- Reworked RDFProof and RDFProofContext to use new query binding --- framework. Also fixed a bug in the variable binding filter code that --- caused failures when a variable used was not bound. --- --- Revision 1.12 2003/10/14 20:31:21 graham --- Add separate module for generic variable binding functions. --- --- Revision 1.11 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.10 2003/06/27 20:46:00 graham --- Coded initial version of RDF simple entailment rule. --- New rule still needs testing, but other test cases still OK. --- --- Revision 1.9 2003/06/18 14:59:27 graham --- Augmented query variable binding structure. --- RDFQuery tests OK. --- --- Revision 1.8 2003/06/18 01:29:29 graham --- Fixed up some problems with backward chaining queries. --- Query test cases still to complete. --- Proof incomplete. --- --- Revision 1.7 2003/06/10 01:04:46 graham --- Proof framework in progress; compiles, incomplete --- --- Revision 1.6 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.5 2003/05/29 00:57:37 graham --- Resolved swish performance problem, which turned out to an inefficient --- method used by the parser to add arcs to a graph. --- --- Revision 1.4 2003/05/20 17:28:51 graham --- Added 'breakAll' function --- --- Revision 1.3 2003/05/14 02:01:59 graham --- GraphMatch recoded and almost working, but --- there are a couple of --- obscure bugs that are proving rather stubborn to squash. --- --- Revision 1.2 2003/05/09 00:28:48 graham --- Added partitionBy to ListHelpers (may want to remove since --- it's also in the standard List module). --- Added mapSelect and mapMerge to LookupMap, and test cases. --- --- Revision 1.1 2003/04/11 18:12:10 graham --- Renamed GraphHelpers to ListHelpers --- LookupMapTest, GraphTest, RDFGraphTest all run OK --- diff --git a/Swish/HaskellUtils/LookupMap.hs b/Swish/HaskellUtils/LookupMap.hs deleted file mode 100644 --- a/Swish/HaskellUtils/LookupMap.hs +++ /dev/null @@ -1,564 +0,0 @@ -{-# OPTIONS -XMultiParamTypeClasses #-} -{-# OPTIONS -XFunctionalDependencies #-} -{-# OPTIONS -XFlexibleContexts #-} -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XTypeSynonymInstances #-} --------------------------------------------------------------------------------- --- $Id: LookupMap.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : LookupMap --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98, class dependencies --- --- This module defines a lookup table format and associated functions --- used by the graph matching code. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Generic list-of-pairs lookup functions ------------------------------------------------------------- - -module Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap, makeLookupMap, listLookupMap - , reverseLookupMap - , keyOrder - , mapFind, mapFindMaybe, mapContains - , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap - , mapAdd, mapAddIfNew - , mapDelete, mapDeleteAll - , mapApplyToAll, mapTranslate - , mapEq, mapKeys, mapVals - , mapSelect, mapMerge - , mapSortByKey, mapSortByVal - , mapTranslateKeys, mapTranslateVals - , mapTranslateEntries, mapTranslateEntriesM - ) -where - -import Data.List( nub, sortBy ) - -import Swish.HaskellUtils.ListHelpers ( equiv ) - ------------------------------------------------------------- --- Class for lookup map entries ------------------------------------------------------------- - --- |LookupEntryClass defines essential functions of any datatype --- that can be used to make a LookupMap. --- --- Minimal definition: newEntry and keyVal --- -class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v - where - newEntry :: (k,v) -> a - keyVal :: a -> (k,v) - entryKey :: a -> k - entryKey e = k where (k,_) = keyVal e - entryVal :: a -> v - entryVal e = v where (_,v) = keyVal e - entryEq :: (Eq v) => a -> a -> Bool - entryEq e1 e2 = (keyVal e1) == (keyVal e2) - entryShow :: (Show v) => a -> String - entryShow e = (show k)++":"++(show v) where (k,v) = keyVal e - kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2 - kmap f e = newEntry (f $ entryKey e,entryVal e) - vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2 - vmap f e = newEntry (entryKey e,f $ entryVal e) - --- |Predefine a pair of appropriate values as a valid lookup table entry --- (i.e. an instance of LookupEntryClass). --- -instance (Eq k, Show k) => LookupEntryClass (k,v) k v where - newEntry = id - keyVal = id - --- |Define a lookup map based on a list of values. --- --- Note: the class constraint that a is an instance of LookupEntryClass --- is not defined here, for good reasons (which I forget right now, but --- something to do with the method disctionary being superfluous on --- an algebraic data type). --- -data LookupMap a = LookupMap [a] - --- |Define eqiality of LookupMap values based on equality of entries. --- --- (This is possibly a poor definition, as it is dependent on ordering --- of list members. But it passes all current test cases, and is used --- only for testing.) --- --- See also mapEq --- (why not just use that here? I don't know: it's probably historic.) --- -instance (Eq a) => Eq (LookupMap a) where - LookupMap es1 == LookupMap es2 = es1 == es2 - --- |Define Show instance for LookupMap based on Showing the --- list of entries. --- -instance (Show a ) => Show (LookupMap a) where - show (LookupMap es) = "LookupMap " ++ show es - --- |Empty lookup map of arbitrary (i.e. polymorphic) type. --- -emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a -emptyLookupMap = LookupMap [] - --- |Function to create a LookupMap from a list of entries. --- --- Currently, this is trivial but future versions could be --- more substantial. --- -makeLookupMap :: (LookupEntryClass a k v) => [a] -> LookupMap a -makeLookupMap es = LookupMap es - --- |Return list of lookup map entries. --- --- Currently, this is trivial but future versions could be --- more substantial. --- -listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a] -listLookupMap (LookupMap es) = es - --- |Given a lookup map entry, return a new entry that can be used --- in the reverse direction of lookup. This is used to construct --- a reverse LookupMap. --- -reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k) - => a1 -> a2 -reverseEntry e = newEntry (v,k) where (k,v) = keyVal e - --- |Given a lookup map, return a new map that can be used --- in the opposite direction of lookup. --- -reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b) - => LookupMap a1 -> LookupMap a2 -reverseLookupMap (LookupMap es) = LookupMap (map reverseEntry es) - --- |Given a pair of lookup entry values, return the ordering of their --- key values. --- -keyOrder :: (LookupEntryClass a k v, Ord k) - => a -> a -> Ordering -keyOrder e1 e2 = compare k1 k2 - where - (k1,_) = keyVal e1 - (k2,_) = keyVal e2 - --- Local helper function to build a new LookupMap from --- a new entry and an exiting map. --- -mapCons :: (LookupEntryClass a k v) => - a -> LookupMap a -> LookupMap a -mapCons e (LookupMap es) = LookupMap (e:es) - --- |Find key in lookup map and return corresponding value, --- otherwise return default supplied. --- -mapFind :: (LookupEntryClass a k v) => v -> k -> LookupMap a -> v -mapFind def key (LookupMap es) = foldr match def es where - match ent alt - | key == (entryKey ent) = entryVal ent - | otherwise = alt - --- |Find key in lookup map and return Just the corresponding value, --- otherwise return Nothing. --- -mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v -mapFindMaybe key (LookupMap es) = foldr match Nothing es where - match ent alt - | key == (entryKey ent) = Just (entryVal ent) - | otherwise = alt - --- |Test to see if key is present in the supplied map --- -mapContains :: (LookupEntryClass a k v) => - LookupMap a -> k -> Bool -mapContains (LookupMap es) key = or (map match es) where - match ent = key == (entryKey ent) - --- |Replace an existing occurrence of a key a with a new key-value pair --- The resulting lookup map has the same form as the original in all --- other respects. Assumes exactly one occurrence of the supplied key. --- -mapReplace :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplace (LookupMap (e:es)) newe - | (entryKey e) == (entryKey newe) = LookupMap (newe:es) - | otherwise = mapAdd more e where - more = mapReplace (LookupMap es) newe -mapReplace _ newe = - error ("mapReplace: Key value not found in lookup table: "++ - (Prelude.show (entryKey newe))) - --- |Replace an existing occurrence of a key a with a new key-value pair, --- or add a new key-value pair if the supplied key is not already present. --- -mapReplaceOrAdd :: (LookupEntryClass a k v) => - a -> LookupMap a -> LookupMap a -mapReplaceOrAdd newe (LookupMap (e:es)) - | (entryKey e) == (entryKey newe) = LookupMap (newe:es) - | otherwise = mapCons e more where - more = mapReplaceOrAdd newe (LookupMap es) -mapReplaceOrAdd newe (LookupMap []) = LookupMap [newe] - --- |Replace any occurrence of a key a with a new key-value pair --- The resulting lookup map has the same form as the original in all --- other respects. --- -mapReplaceAll :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplaceAll (LookupMap (e:es)) newe = mapCons e' more where - more = mapReplaceAll (LookupMap es) newe - e' = if (entryKey e) == (entryKey newe) then newe else e -mapReplaceAll (LookupMap []) _ = (LookupMap []) - --- |Replace any occurrence of a key in the first argument with a --- corresponding key-value pair from the second argument, if present. --- --- This could be implemented by multiple applications of mapReplaceAll, --- but is arranged differently so that only one new LookupMap value is --- created. --- --- Note: keys in the new map that are not present in the old map --- are not included in the result map --- -mapReplaceMap :: (LookupEntryClass a k v) => - LookupMap a -> LookupMap a -> LookupMap a -mapReplaceMap (LookupMap (e:es)) newmap = mapCons e' more where - more = mapReplaceMap (LookupMap es) newmap - e' = newEntry (k,mapFind v k newmap) - (k,v) = keyVal e -mapReplaceMap (LookupMap []) _ = (LookupMap []) - --- |Add supplied key-value pair to the lookup map. --- --- This is effectively an optimized case of MapReplaceOrAdd or mapAddIfNew, --- where the caller guarantees to avoid duplicate key values. --- -mapAdd :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapAdd emap e = mapCons e emap - --- |Add supplied key-value pair to the lookup map, --- only if the key value is not already present. --- -mapAddIfNew :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapAddIfNew emap e = if mapContains emap (entryKey e) - then emap - else mapCons e emap - --- ADelete supplied key value from the lookup map. --- This function assumes exactly one occurrence. --- -mapDelete :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDelete (LookupMap (e:es)) k - | k == (entryKey e) = LookupMap es - | otherwise = mapCons e more where - more = mapDelete (LookupMap es) k -mapDelete _ k = - error ("mapDelete: Key value not found in lookup table: "++(Prelude.show k)) - --- |Delete any occurrence of a supplied key value from the lookup map. --- -mapDeleteAll :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDeleteAll (LookupMap (e:es)) k = - if (entryKey e) == k then more else mapCons e more where - more = mapDeleteAll (LookupMap es) k -mapDeleteAll (LookupMap []) _ = (LookupMap []) - --- |Return a list of values obtained by applying a function to each key --- in the map. Creates an alternative set of values that can be --- retrieved using mapTranslate. --- -mapApplyToAll :: (LookupEntryClass a k v) => - LookupMap a -> (k -> w) -> [w] -mapApplyToAll (LookupMap es) f = [ f (entryKey e) | e <- es ] - --- |Find a node in a lookup map list, and returns the --- corresponding value from a supplied list. The appropriate ordering --- of the list is not specified here, but an appropriately ordered list --- may be obtained by mapApplyToAll. --- -mapTranslate :: (LookupEntryClass a k v) => - LookupMap a -> [w] -> k -> w -> w -mapTranslate (LookupMap (e:es)) (w:ws) k def - | k == (entryKey e) = w - | otherwise = mapTranslate (LookupMap es) ws k def -mapTranslate _ _ _ def = def - --- |Compare two lookup maps for equality. --- --- Two maps are equal if they have the same set of keys, and if --- each key maps to an equivalent value. --- -mapEq :: (LookupEntryClass a k v, Eq v) => - LookupMap a -> LookupMap a -> Bool -mapEq es1 es2 = - ( ks1 `equiv` ks2 ) && - and [ (mapFindMaybe k es1) == (mapFindMaybe k es2) | k <- ks1 ] - where - ks1 = mapKeys es1 - ks2 = mapKeys es2 - --- |Return the list of keys in a supplied LookupMap --- -mapKeys :: (LookupEntryClass a k v) => - LookupMap a -> [k] -mapKeys (LookupMap es) = nub $ map (fst . keyVal) es - --- |Return list of distinct values in a supplied LookupMap --- -mapVals :: (Eq v, LookupEntryClass a k v) => - LookupMap a -> [v] -mapVals (LookupMap es) = nub $ map (snd . keyVal) es - --- |Select portion of a lookup map that corresponds to --- a supplied list of keys --- -mapSelect :: (LookupEntryClass a k v) => - LookupMap a -> [k] -> LookupMap a -mapSelect (LookupMap es) ks = - LookupMap $ filter (keyIn ks) es - where - keyIn ks e = k `elem` ks where (k,_) = keyVal e - --- |Merge two lookup maps, ensuring that if the same key appears --- in both maps it is associated with the same value. --- -mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) => - LookupMap a -> LookupMap a -> LookupMap a -mapMerge (LookupMap es1) (LookupMap es2) = - LookupMap $ merge (sortBy keyOrder es1) (sortBy keyOrder es2) - where - merge es1 [] = es1 - merge [] es2 = es2 - merge es1@(e1:et1) es2@(e2:et2) = - case keyOrder e1 e2 of - LT -> e1:(merge et1 es2) - GT -> e2:(merge es1 et2) - EQ -> if e1 /= e2 - then error ("mapMerge key conflict: " ++ (show e1) - ++ " with " ++ (show e2)) - else e1:(merge et1 et2) - --- |Creates a new map that is the same as the supplied map, except --- that its entries are sorted by key value. --- --- (What's this used for? It should be redundant.) --- -mapSortByKey :: (LookupEntryClass a k v, Ord k) => - LookupMap a -> LookupMap a -mapSortByKey (LookupMap es) = - LookupMap $ sortBy keyCompare es - where - keyCompare e1 e2 = compare (entryKey e1) (entryKey e2) - --- |Creates a new map that is the same as the supplied map, except --- that its entries are sorted by key value. --- --- (What's this used for? It should be redundant.) --- -mapSortByVal :: (LookupEntryClass a k v, Ord v) => - LookupMap a -> LookupMap a -mapSortByVal (LookupMap es) = - LookupMap $ sortBy valCompare es - where - valCompare e1 e2 = compare (entryVal e1) (entryVal e2) - --- |An fmap-like function that returns a new lookup map that is a --- copy of the supplied map with entry keys replaced according to --- a supplied function. --- -mapTranslateKeys :: (LookupEntryClass a1 k1 v, LookupEntryClass a2 k2 v) => - (k1 -> k2) -> LookupMap a1 -> LookupMap a2 -mapTranslateKeys f (LookupMap es) = - LookupMap $ map (kmap f) es - --- |An fmap-like function that returns a new lookup map that is a --- copy of the supplied map with entry values replaced according to --- a supplied function. --- -mapTranslateVals :: (LookupEntryClass a1 k v1, LookupEntryClass a2 k v2) => - (v1 -> v2) -> LookupMap a1 -> LookupMap a2 -mapTranslateVals f = mapTranslateEntries (vmap f) - --- |A function that returns a new lookup map that is a copy of the --- supplied map with complete entries replaced according to --- a supplied function. --- -mapTranslateEntries :: - (a1 -> a2) -> LookupMap a1 -> LookupMap a2 -mapTranslateEntries f (LookupMap es) = - LookupMap $ map f es - --- |A monadic form of mapTranslateEntries --- -mapTranslateEntriesM :: (Monad m) - => (a1 -> m (a2)) -> LookupMap a1 -> m (LookupMap a2) -mapTranslateEntriesM f (LookupMap es) = - do { m2 <- mapM f es - ; return $ LookupMap m2 - } - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/LookupMap.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: LookupMap.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.29 2003/12/07 19:10:35 graham --- Cleaned up LookupMap code comments. --- --- Revision 1.28 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.27 2003/12/03 22:04:00 graham --- Re-ordered mapFind (again), to simplify currying of default value. --- --- Revision 1.26 2003/12/03 22:02:09 graham --- Re-ordered mapFind, to simplify currying of default value. --- --- Revision 1.25 2003/11/24 15:46:03 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.24 2003/11/13 01:13:48 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.23 2003/10/24 21:02:42 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.22 2003/10/23 18:54:00 graham --- Moved context requirements for using LookupMap. --- Some context requirements are now applied to individual --- LoopkupMap routines that depend upon them. --- --- Revision 1.21 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.20 2003/06/30 19:07:00 graham --- Instance entailment, subgraph entailment and simple entailment --- tests now working. --- --- Revision 1.19 2003/06/13 21:40:08 graham --- Graph closure forward chaining works. --- Backward chaining generates existentials. --- Some problems with query logic for backward chaining. --- --- Revision 1.18 2003/06/11 14:07:53 graham --- Added mapTranslateEntriesM, which performs monadic translation of --- LookupMap entries. (Tested using Maybe monad.) --- --- Revision 1.17 2003/06/10 17:38:34 graham --- Remove some unneeded calss constraints from data type declarations --- Reworked NSGraph to be an instance of Functor, replacing function --- gmap with fmap. Graph formulae are still not handled well: the data types --- will need re-working so that a "Formula lb" type constructor can be --- introduced having the correct (* -> *) kind to be a Functor. --- --- Revision 1.16 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.15 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.14 2003/05/23 19:33:36 graham --- Added and tested RDF graph label translation functions --- --- Revision 1.13 2003/05/14 19:38:32 graham --- Simple formatter tests all working with reworked graph and lookup structures. --- More complex formatter tests still to be coded. --- --- Revision 1.12 2003/05/14 02:01:59 graham --- GraphMatch recoded and almost working, but --- there are a couple of --- obscure bugs that are proving rather stubborn to squash. --- --- Revision 1.11 2003/05/09 00:28:48 graham --- Added partitionBy to ListHelpers (may want to remove since --- it's also in the standard List module). --- Added mapSelect and mapMerge to LookupMap, and test cases. --- --- Revision 1.10 2003/05/07 23:58:09 graham --- More restructuring. --- RDFGraphTest runs OK. --- N3ParserTest needs to be updated to use new structure for formulae. --- --- Revision 1.9 2003/05/07 19:25:26 graham --- Added mapFindMaybe to LookupMap export list --- --- Revision 1.8 2003/05/07 18:50:38 graham --- Add LookupMap functions: mapFindMaybe, mapKeys, mapEq --- --- Revision 1.7 2003/05/01 23:15:44 graham --- GraphTest passes all tests using refactored LookupMap --- Extensive changes to GraphMatch were required. --- --- Revision 1.6 2003/05/01 19:14:26 graham --- LookupMap refactored to use class for entry, so that it can be --- applied to a variety of different types with identifiable key and value --- components. All tests pass. --- --- Revision 1.5 2003/05/01 00:21:41 graham --- Started refactoring LookupMap. --- Revised module compiles OK. --- Working on test module. --- --- Revision 1.4 2003/04/29 22:07:10 graham --- Some refactoring of N3 formatter. --- N3 formatter now handles trivial cases. --- More complex formatter test cases still to be developed. --- --- Revision 1.3 2003/04/24 23:41:39 graham --- Added Ord class membership to graph nodes --- Added empty lookup table definition --- Started on N3 formatter module --- --- Revision 1.2 2003/04/11 18:04:49 graham --- Rename GraphLookupMap to LookupMap: --- GraphTest runs OK. --- --- Revision 1.1 2003/04/11 17:38:33 graham --- Rename GraphLookupMap to LookupMap --- diff --git a/Swish/HaskellUtils/LookupMapTest.hs b/Swish/HaskellUtils/LookupMapTest.hs deleted file mode 100644 --- a/Swish/HaskellUtils/LookupMapTest.hs +++ /dev/null @@ -1,660 +0,0 @@ -{-# OPTIONS -XFlexibleInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} - --------------------------------------------------------------------------------- --- $Id: LookupMapTest.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : LookupMapTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module defines test cases for module Parse parsing functions. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellUtils.LookupMapTest where - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap, makeLookupMap, listLookupMap - , reverseLookupMap - , keyOrder - , mapFind, mapFindMaybe, mapContains - , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap - , mapAdd, mapAddIfNew - , mapDelete, mapDeleteAll - , mapApplyToAll, mapTranslate - , mapEq, mapKeys, mapVals - , mapSelect, mapMerge - , mapSortByKey, mapSortByVal - , mapTranslateKeys, mapTranslateVals - , mapTranslateEntries, mapTranslateEntriesM - ) - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Data.List ( sort ) - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertEqual, runTestTT, runTestText, putTextToHandle ) - ------------------------------------------------------------- --- Declare lookup entry for testing ------------------------------------------------------------- - -data GenMapEntry a b = E a b - -instance (Eq a, Show a, Eq b, Show b) - => LookupEntryClass (GenMapEntry a b) a b - where - keyVal (E k v) = (k,v) - newEntry (k,v) = (E k v) - -instance (Eq a, Show a, Eq b, Show b) => Show (GenMapEntry a b) where - show = entryShow - -instance (Eq a, Show a, Eq b, Show b) => Eq (GenMapEntry a b) where - (==) = entryEq - -type TestEntry = GenMapEntry Int String -type TestMap = LookupMap (GenMapEntry Int String) -type RevTestMap = LookupMap (GenMapEntry String Int) -type MayTestMap = Maybe RevTestMap -type StrTestMap = LookupMap (GenMapEntry String String) - ------------------------------------------------------------- --- Test class helper ------------------------------------------------------------- - -testeq :: (Show a, Eq a) => String -> a -> a -> Test -testeq lab req got = - TestCase ( assertEqual ("test"++lab) req got ) - -testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test -testeqv lab req got = - TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) - ------------------------------------------------------------- --- LookupMap functions ------------------------------------------------------------- - -newMap :: [(Int,String)] -> TestMap -newMap es = makeLookupMap (map newEntry es) - -testLookupMap :: String -> TestMap -> [(Int,String)] -> Test -testLookupMap lab m1 m2 = testeq ("LookupMap"++lab ) (newMap m2) m1 - -testLookupMapFind :: String -> TestMap -> Int -> String -> Test -testLookupMapFind lab lm k res = - testeq ("LookupMapFind"++lab ) res (mapFind "" k lm) - -lm00 = newMap [] -testLookupMap00 = testLookupMap "00" lm00 [] -testLookupMapFind00 = testLookupMapFind "00" lm00 2 "" - -lm01 = mapAdd lm00 $ newEntry (1,"aaa") -testLookupMap01 = testLookupMap "01" lm01 [(1,"aaa")] -testLookupMapFind01 = testLookupMapFind "01" lm01 2 "" - -lm02 = mapAdd lm01 $ newEntry (2,"bbb") -testLookupMap02 = testLookupMap "02" lm02 [(2,"bbb"),(1,"aaa")] -testLookupMapFind02 = testLookupMapFind "02" lm02 2 "bbb" - -lm03 = mapAdd lm02 $ newEntry (3,"ccc") -testLookupMap03 = testLookupMap "03" lm03 [(3,"ccc"),(2,"bbb"),(1,"aaa")] -testLookupMapFind03 = testLookupMapFind "03" lm03 2 "bbb" - -lm04 = mapAdd lm03 $ newEntry (2,"bbb") -testLookupMap04 = testLookupMap "04" lm04 [(2,"bbb"),(3,"ccc"),(2,"bbb"),(1,"aaa")] -testLookupMapFind04 = testLookupMapFind "04" lm04 2 "bbb" - -lm05 = mapReplaceAll lm04 $ newEntry (2,"bbb1") -testLookupMap05 = testLookupMap "05" lm05 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] -testLookupMapFind05 = testLookupMapFind "05" lm05 2 "bbb1" - -lm06 = mapReplaceAll lm05 $ newEntry (9,"zzzz") -testLookupMap06 = testLookupMap "06" lm06 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] -testLookupMapFind06 = testLookupMapFind "06" lm06 2 "bbb1" - -lm07 = mapReplace lm06 $ newEntry (2,"bbb") -testLookupMap07 = testLookupMap "07" lm07 [(2,"bbb"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] -testLookupMapFind07 = testLookupMapFind "07" lm07 2 "bbb" -testLookupMapFind0x = testLookupMapFind "0x" lm07 9 "" - -lm08 = mapDelete lm07 3 -testLookupMap08 = testLookupMap "08" lm08 [(2,"bbb"),(2,"bbb1"),(1,"aaa")] -testLookupMapFind08 = testLookupMapFind "08" lm08 2 "bbb" - -lm09 = mapDeleteAll lm08 2 -testLookupMap09 = testLookupMap "09" lm09 [(1,"aaa")] -testLookupMapFind09 = testLookupMapFind "09" lm09 2 "" - -la10 = mapApplyToAll lm03 (flip replicate '*') -testLookupMapApp10 = testeq "LookupMapApplyToAll10" ["***","**","*"] la10 - -lt11 = mapTranslate lm03 la10 1 "****" -testLookupMapTran11 = testeq "LookupMapTranslate11" "*" lt11 - -lt12 = mapTranslate lm03 la10 2 "****" -testLookupMapTran12 = testeq "LookupMapTranslate12" "**" lt12 - -lt13 = mapTranslate lm03 la10 3 "****" -testLookupMapTran13 = testeq "LookupMapTranslate13" "***" lt13 - -lt14 = mapTranslate lm03 la10 4 "****" -testLookupMapTran14 = testeq "LookupMapTranslate14" "****" lt14 - -lm20 = mapReplaceMap lm05 $ newMap [(2,"bbb20"),(3,"ccc20")] -testLookupMap20 = testLookupMap "20" lm20 [(2,"bbb20"),(3,"ccc20"),(2,"bbb20"),(1,"aaa")] -testLookupMapFind20 = testLookupMapFind "20" lm20 2 "bbb20" - -lm21 = mapReplaceMap lm05 $ newMap [] -testLookupMap21 = testLookupMap "21" lm21 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] -testLookupMapFind21 = testLookupMapFind "21" lm21 2 "bbb1" - -lm22 = mapReplaceMap lm05 $ newMap [(9,"zzz22"),(1,"aaa22")] -testLookupMap22 = testLookupMap "22" lm22 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] -testLookupMapFind22 = testLookupMapFind "22" lm22 1 "aaa22" - -testLookupContains31 = testeq "LookupContains31" True (mapContains lm22 2) -testLookupContains32 = testeq "LookupContains32" False (mapContains lm22 9) - -lm33 = mapAddIfNew lm22 $ newEntry (1,"aaa33") -testLookupMap33 = testLookupMap "33" lm33 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] -testLookupMapFind33a = testLookupMapFind "33a" lm33 1 "aaa22" -testLookupMapFind33b = testLookupMapFind "33b" lm33 4 "" - -lm34 = mapAddIfNew lm22 $ newEntry (4,"ddd34") -testLookupMap34 = testLookupMap "34" lm34 [(4,"ddd34"),(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] -testLookupMapFind34a = testLookupMapFind "34a" lm34 1 "aaa22" -testLookupMapFind34b = testLookupMapFind "34b" lm34 4 "ddd34" - -lm35 = mapReplaceOrAdd (newEntry (1,"aaa35")) lm22 -testLookupMap35 = testLookupMap "35" lm35 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa35")] -testLookupMapFind35a = testLookupMapFind "35a" lm35 1 "aaa35" -testLookupMapFind35b = testLookupMapFind "35b" lm35 4 "" - -lm36 = mapReplaceOrAdd (newEntry (4,"ddd36")) lm22 -testLookupMap36 = testLookupMap "36" lm36 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22"),(4,"ddd36")] -testLookupMapFind36a = testLookupMapFind "36a" lm36 1 "aaa22" -testLookupMapFind36b = testLookupMapFind "36b" lm36 4 "ddd36" - -testLookupMapSuite = TestList - [ - testLookupMap01, testLookupMapFind01, - testLookupMap02, testLookupMapFind02, - testLookupMap03, testLookupMapFind03, - testLookupMap04, testLookupMapFind04, - testLookupMap05, testLookupMapFind05, - testLookupMap06, testLookupMapFind06, - testLookupMap07, testLookupMapFind07, testLookupMapFind0x, - testLookupMap08, testLookupMapFind08, - testLookupMap09, testLookupMapFind09, - testLookupMapApp10, - testLookupMapTran11, testLookupMapTran12, - testLookupMapTran13, testLookupMapTran14, - testLookupMap20, testLookupMapFind20, - testLookupMap21, testLookupMapFind21, - testLookupMap22, testLookupMapFind22, - testLookupContains31, - testLookupContains32, - testLookupMap33, testLookupMapFind33a, testLookupMapFind33b, - testLookupMap34, testLookupMapFind34a, testLookupMapFind34b, - testLookupMap35, testLookupMapFind35a, testLookupMapFind35b, - testLookupMap36, testLookupMapFind36a, testLookupMapFind36b - ] - ------------------------------------------------------------- --- Reverse lookup map test tests ------------------------------------------------------------- - -revdef = -1 :: Int - -newRevMap :: [(String,Int)] -> RevTestMap -newRevMap es = makeLookupMap (map newEntry es) - -testRevLookupMap :: String -> RevTestMap -> [(String,Int)] -> Test -testRevLookupMap lab m1 m2 = - testeq ("RevLookupMap"++lab) (newRevMap m2) m1 - -testRevLookupMapFind :: String -> RevTestMap -> String -> Int -> Test -testRevLookupMapFind lab lm k res = - testeq ("RevLookupMapFind"++lab) res (mapFind revdef k lm) - -rlm00 :: RevTestMap -rlm00 = reverseLookupMap lm00 -testRevLookupMap00 = testRevLookupMap "00" rlm00 [] -testRevLookupMapFind00 = testRevLookupMapFind "00" rlm00 "" revdef - -rlm01 :: RevTestMap -rlm01 = reverseLookupMap lm01 -testRevLookupMap01 = testRevLookupMap "01" rlm01 [("aaa",1)] -testRevLookupMapFind01 = testRevLookupMapFind "01" rlm01 "bbb" revdef - -rlm02 :: RevTestMap -rlm02 = reverseLookupMap lm02 -testRevLookupMap02 = testRevLookupMap "02" rlm02 [("bbb",2),("aaa",1)] -testRevLookupMapFind02 = testRevLookupMapFind "02" rlm02 "bbb" 2 - -rlm03 :: RevTestMap -rlm03 = reverseLookupMap lm03 -testRevLookupMap03 = testRevLookupMap "03" rlm03 [("ccc",3),("bbb",2),("aaa",1)] -testRevLookupMapFind03 = testRevLookupMapFind "03" rlm03 "bbb" 2 - -rlm04 :: RevTestMap -rlm04 = reverseLookupMap lm04 -testRevLookupMap04 = testRevLookupMap "04" rlm04 [("bbb",2),("ccc",3),("bbb",2),("aaa",1)] -testRevLookupMapFind04 = testRevLookupMapFind "04" rlm04 "bbb" 2 - -rlm05 :: RevTestMap -rlm05 = reverseLookupMap lm05 -testRevLookupMap05 = testRevLookupMap "05" rlm05 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] -testRevLookupMapFind05 = testRevLookupMapFind "05" rlm05 "bbb1" 2 - -rlm06 :: RevTestMap -rlm06 = reverseLookupMap lm06 -testRevLookupMap06 = testRevLookupMap "06" rlm06 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] -testRevLookupMapFind06 = testRevLookupMapFind "06" rlm06 "bbb1" 2 - -rlm07 :: RevTestMap -rlm07 = reverseLookupMap lm07 -testRevLookupMap07 = testRevLookupMap "07" rlm07 [("bbb",2),("ccc",3),("bbb1",2),("aaa",1)] -testRevLookupMapFind07 = testRevLookupMapFind "07" rlm07 "bbb" 2 -testRevLookupMapFind0w = testRevLookupMapFind "07" rlm07 "bbb1" 2 -testRevLookupMapFind0x = testRevLookupMapFind "0x" rlm07 "*" revdef - -rlm08 :: RevTestMap -rlm08 = reverseLookupMap lm08 -testRevLookupMap08 = testRevLookupMap "08" rlm08 [("bbb",2),("bbb1",2),("aaa",1)] -testRevLookupMapFind08 = testRevLookupMapFind "08" rlm08 "bbb" 2 - -rlm09 :: RevTestMap -rlm09 = reverseLookupMap lm09 -testRevLookupMap09 = testRevLookupMap "09" rlm09 [("aaa",1)] -testRevLookupMapFind09 = testRevLookupMapFind "09" rlm09 "" revdef - -testRevLookupMapSuite = TestList - [ - testRevLookupMap01, testRevLookupMapFind01, - testRevLookupMap02, testRevLookupMapFind02, - testRevLookupMap03, testRevLookupMapFind03, - testRevLookupMap04, testRevLookupMapFind04, - testRevLookupMap05, testRevLookupMapFind05, - testRevLookupMap06, testRevLookupMapFind06, - testRevLookupMap07, testRevLookupMapFind07, - testRevLookupMapFind0w, - testRevLookupMapFind0x, - testRevLookupMap08, testRevLookupMapFind08, - testRevLookupMap09, testRevLookupMapFind09 - ] - ------------------------------------------------------------- --- mapKeys ------------------------------------------------------------- - -testMapKeys :: String -> TestMap -> [Int] -> Test -testMapKeys lab m1 mk = - testeq ("testMapKeys:"++lab) mk (sort $ mapKeys m1) - -testMapKeys00 = testMapKeys "00" lm00 [] -testMapKeys01 = testMapKeys "01" lm01 [1] -testMapKeys02 = testMapKeys "02" lm02 [1,2] -testMapKeys03 = testMapKeys "03" lm03 [1,2,3] -testMapKeys04 = testMapKeys "04" lm04 [1,2,3] -testMapKeys05 = testMapKeys "05" lm05 [1,2,3] -testMapKeys06 = testMapKeys "06" lm06 [1,2,3] -testMapKeys07 = testMapKeys "07" lm07 [1,2,3] -testMapKeys08 = testMapKeys "08" lm08 [1,2] -testMapKeys09 = testMapKeys "09" lm09 [1] - -testMapKeysSuite = TestList - [ testMapKeys00 - , testMapKeys01 - , testMapKeys02 - , testMapKeys03 - , testMapKeys04 - , testMapKeys05 - , testMapKeys06 - , testMapKeys07 - , testMapKeys08 - , testMapKeys09 - ] - ------------------------------------------------------------- --- mapVals ------------------------------------------------------------- - -testMapVals :: String -> TestMap -> [String] -> Test -testMapVals lab m1 mv = - testeq ("MapVals:"++lab) mv (sort $ mapVals m1) - -testMapVals00 = testMapVals "00" lm00 [] -testMapVals01 = testMapVals "01" lm01 ["aaa"] -testMapVals02 = testMapVals "02" lm02 ["aaa","bbb"] -testMapVals03 = testMapVals "03" lm03 ["aaa","bbb","ccc"] -testMapVals04 = testMapVals "04" lm04 ["aaa","bbb","ccc"] -testMapVals05 = testMapVals "05" lm05 ["aaa","bbb1","ccc"] -testMapVals06 = testMapVals "06" lm06 ["aaa","bbb1","ccc"] -testMapVals07 = testMapVals "07" lm07 ["aaa","bbb","bbb1","ccc"] -testMapVals08 = testMapVals "08" lm08 ["aaa","bbb","bbb1"] -testMapVals09 = testMapVals "09" lm09 ["aaa"] - -testMapValsSuite = TestList - [ testMapVals00 - , testMapVals01 - , testMapVals02 - , testMapVals03 - , testMapVals04 - , testMapVals05 - , testMapVals06 - , testMapVals07 - , testMapVals08 - , testMapVals09 - ] - ------------------------------------------------------------- --- mapEq ------------------------------------------------------------- - -maplist = - [ ("lm00",lm00) - , ("lm01",lm01) - , ("lm02",lm02) - , ("lm03",lm03) - , ("lm04",lm04) - , ("lm05",lm05) - , ("lm06",lm06) - , ("lm07",lm07) - , ("lm08",lm08) - , ("lm09",lm09) - ] - -mapeqlist = - [ ("lm01","lm09") - , ("lm02","lm08") - , ("lm03","lm04") - , ("lm03","lm07") - , ("lm04","lm07") - , ("lm05","lm06") - ] - -testMapEq :: String -> Bool -> TestMap -> TestMap -> Test -testMapEq lab eq m1 m2 = - testeq ("testMapEq:"++lab) eq (mapEq m1 m2) - -testMapEqSuite = TestList - [ testMapEq (testLab l1 l2) (testEq l1 l2) m1 m2 - | (l1,m1) <- maplist , (l2,m2) <- maplist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` mapeqlist || - (l2,l1) `elem` mapeqlist - ------------------------------------------------------------- --- mapSelect and mapMerge ------------------------------------------------------------- - -lm101 = mapAdd lm03 $ newEntry (4,"ddd") -testLookupMap101 = testLookupMap "101" lm101 [(4,"ddd"),(3,"ccc"),(2,"bbb"),(1,"aaa")] - -lm102 = mapSelect lm101 [1,3] -testLookupMap102 = testLookupMap "102" lm102 [(3,"ccc"),(1,"aaa")] - -lm103 = mapSelect lm101 [2,4] -testLookupMap103 = testLookupMap "103" lm103 [(4,"ddd"),(2,"bbb")] - -lm104 = mapSelect lm101 [2,3] -testLookupMap104 = testLookupMap "104" lm104 [(3,"ccc"),(2,"bbb")] - -mapSelectSuite = TestList - [ testLookupMap101 - , testLookupMap102 - , testLookupMap103 - , testLookupMap104 - ] - -lm105 = mapMerge lm102 lm103 -testLookupMap105 = testLookupMap "105" lm105 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] - -lm106 = mapMerge lm102 lm104 -testLookupMap106 = testLookupMap "106" lm106 [(1,"aaa"),(2,"bbb"),(3,"ccc")] - -lm107 = mapMerge lm103 lm104 -testLookupMap107 = testLookupMap "107" lm107 [(2,"bbb"),(3,"ccc"),(4,"ddd")] - -lm108 = mapMerge lm101 lm102 -testLookupMap108 = testLookupMap "108" lm108 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] - -mapMergeSuite = TestList - [ testLookupMap105 - , testLookupMap106 - , testLookupMap107 - , testLookupMap108 - ] - ------------------------------------------------------------- --- Tranlation tests ------------------------------------------------------------- - --- Rather late in the day, generic versions of the testing functions used earlier -type TestMapG a b = LookupMap (GenMapEntry a b) -newMapG :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> (TestMapG a b) -newMapG es = makeLookupMap (map newEntry es) -testLookupMapG :: (Eq a, Show a, Eq b, Show b) => String -> (TestMapG a b) -> [(a,b)] -> Test -testLookupMapG lab m1 m2 = testeq ("LookupMapG"++lab ) (newMapG m2) m1 -testLookupMapM :: - (Eq a, Show a, Eq b, Show b, Monad m, - Eq (m (TestMapG a b)), Show (m (TestMapG a b))) - => String -> m (TestMapG a b) -> m (TestMapG a b) -> Test -testLookupMapM lab m1 m2 = testeq ("LookupMapM"++lab ) m2 m1 - -tm101 = newMap [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] -testTranslateMap101 = testLookupMapG "tm101" tm101 [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] - -tf102 = (flip replicate '*') :: Int -> String -tm102 :: StrTestMap -tm102 = mapTranslateKeys tf102 tm101 -testTranslateMap102 = testLookupMapG "tm102" tm102 [("*","a"),("**","bb"),("***","ccc"),("****","dddd")] - -tf103 = length -tm103 :: RevTestMap -tm103 = mapTranslateVals tf103 tm102 -testTranslateMap103 = testLookupMapG "tm103" tm103 [("*",1),("**",2),("***",3),("****",4)] - -tf104 e = newEntry ( (flip replicate '#') k, 5-(length v) ) where (k,v) = keyVal e -tm104 :: RevTestMap -tm104 = mapTranslateEntries tf104 tm101 -testTranslateMap104 = testLookupMapG "tm104" tm104 [("#",4),("##",3),("###",2),("####",1)] - --- Test monadic translation, using Maybe monad --- (Note that if Nothing is generated at any step, --- it propagates to the result) -tf105 e = Just $ tf104 e -tm105 :: MayTestMap -tm105 = mapTranslateEntriesM tf105 tm101 -testTranslateMap105 = testLookupMapM "tm105" tm105 (Just tm104) - -tf106 e = if k == 2 then Nothing else tf105 e where (k,_) = keyVal e -tm106 :: MayTestMap -tm106 = mapTranslateEntriesM tf106 tm101 -testTranslateMap106 = testLookupMapM "tm106" tm106 Nothing - -mapTranslateSuite = TestList - [ testTranslateMap101 - , testTranslateMap102 - , testTranslateMap103 - , testTranslateMap104 - , testTranslateMap105 - , testTranslateMap106 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testLookupMapSuite - , testRevLookupMapSuite - , testMapKeysSuite - , testMapValsSuite - , testMapEqSuite - , mapSelectSuite - , mapMergeSuite - , mapTranslateSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/LookupMapTest.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: LookupMapTest.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.20 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.19 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.18 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.17 2003/12/03 22:04:00 graham --- Re-ordered mapFind (again), to simplify currying of default value. --- --- Revision 1.16 2003/12/03 22:02:09 graham --- Re-ordered mapFind, to simplify currying of default value. --- --- Revision 1.15 2003/10/24 21:02:42 graham --- Changed kind-structure of LookupMap type classes. --- --- Revision 1.14 2003/10/14 20:31:21 graham --- Add separate module for generic variable binding functions. --- --- Revision 1.13 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.12 2003/06/11 14:07:53 graham --- Added mapTranslateEntriesM, which performs monadic translation of --- LookupMap entries. (Tested using Maybe monad.) --- --- Revision 1.11 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.10 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.9 2003/05/26 22:30:36 graham --- Working on graph merge. --- Added methods to Graph class for manipulating variable node. --- Need to get RDFGraph to compile. And test. --- --- Revision 1.8 2003/05/23 19:33:36 graham --- Added and tested RDF graph label translation functions --- --- Revision 1.7 2003/05/09 00:28:48 graham --- Added partitionBy to ListHelpers (may want to remove since --- it's also in the standard List module). --- Added mapSelect and mapMerge to LookupMap, and test cases. --- --- Revision 1.6 2003/05/07 18:50:38 graham --- Add LookupMap functions: mapFindMaybe, mapKeys, mapEq --- --- Revision 1.5 2003/05/01 23:15:44 graham --- GraphTest passes all tests using refactored LookupMap --- Extensive changes to GraphMatch were required. --- --- Revision 1.4 2003/05/01 19:14:26 graham --- LookupMap refactored to use class for entry, so that it can be --- applied to a variety of different types with identifiable key and value --- components. All tests pass. --- --- Revision 1.3 2003/05/01 00:21:41 graham --- Started refactoring LookupMap. --- Revised module compiles OK. --- Working on test module. --- --- Revision 1.2 2003/04/11 18:12:10 graham --- Renamed GraphHelpers to ListHelpers --- LookupMapTest, GraphTest, RDFGraphTest all run OK --- --- Revision 1.1 2003/04/11 18:05:57 graham --- Add separate LookupMap test harness --- Added mapReplaceOrAdd function --- LookupMapTest runs OK --- --- Revision 1.7 2003/04/10 13:41:22 graham --- More graph code tidying --- Graph test cases still run OK --- --- Revision 1.6 2003/04/10 13:35:34 graham --- Separated GraphMatch logic from GraphMem --- --- Revision 1.5 2003/04/10 08:36:06 graham --- Graph matching passes battery of new tests --- Started work on RDF graph --- --- Revision 1.4 2003/03/31 22:18:08 graham --- Simple graph equality tests all pass --- --- Revision 1.3 2003/03/31 20:52:23 graham --- Restructure graph matching to deal with same unbound node names in --- different graphs. It shows signs that it might be working now. --- More testing is needed. --- --- Revision 1.2 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- --- Revision 1.1 2003/03/12 23:00:43 graham --- Graph model coded and working, except for graph isomorphism test. --- diff --git a/Swish/HaskellUtils/MiscHelpers.hs b/Swish/HaskellUtils/MiscHelpers.hs deleted file mode 100644 --- a/Swish/HaskellUtils/MiscHelpers.hs +++ /dev/null @@ -1,137 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: MiscHelpers.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : MiscHelpers --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines some generic list and related helper functions --- used by the graph handling code. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.MiscHelpers - ( assert, lower, stricmp, quote, hash, hashModulus ) -where - -import Data.Char - ( toLower ) - ------------------------------------------------------------- --- assert test ------------------------------------------------------------- - -assert :: Bool -> String -> a -> a -assert cond msg expr = if not cond then error msg else expr - ------------------------------------------------------------- --- Generate lowercase form of supplied string ------------------------------------------------------------- - -lower (c:st) = (toLower c):(lower st) -lower [] = "" - ------------------------------------------------------------- --- Case insensitive compare. ------------------------------------------------------------- --- --- Should be used only for values using just the US ASCII --- character set. Use with richer character sets can yield --- surprising results. - -stricmp :: String -> String -> Bool -stricmp (c1:s1) (c2:s2) = (toLower c1) == (toLower c2) && (stricmp s1 s2) -stricmp [] [] = True -stricmp _ _ = False - ------------------------------------------------------------- --- Generate quoted form of supplied string: ------------------------------------------------------------- --- --- [[[TODO: The list of quoting options here is incomplete]]] - -quote st = ['"'] ++ (quote1 st) ++ ['"'] -quote1 ('"': st) = '\\':'"' :(quote1 st) -quote1 ('\\':st) = '\\':'\\':(quote1 st) -quote1 ('\n':st) = '\\':'n':(quote1 st) -quote1 ('\r':st) = '\\':'r':(quote1 st) -quote1 (c:st) = c:(quote1 st) -quote1 [] = "" - ------------------------------------------------------------- --- Hash function and values ------------------------------------------------------------- --- --- Simple hash function based on Sedgewick, Algorithms in C, p 233 --- (choose mx*cm+255 < maxBound) --- 'seed' is an additional parameter that allows the function --- to be varied for re-hashing. - -hashModulus = 16000001::Int - -hash :: Int -> String -> Int -hash seed str = hash1 seed (64+seed) hashModulus str - -hash1 :: Int -> Int -> Int -> String -> Int -hash1 sofar cm mx (c:str) = hash1 (( (sofar*cm) + (fromEnum c) ) `rem` mx) cm mx str -hash1 sofar _ _ [] = sofar - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/MiscHelpers.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: MiscHelpers.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.6 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.5 2004/01/07 14:29:15 graham --- Move stricmp to MiscHelpers --- --- Revision 1.4 2003/12/04 02:53:27 graham --- More changes to LookupMap functions. --- SwishScript logic part complete, type-checks OK. --- --- Revision 1.3 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.2 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.1 2003/05/20 17:29:44 graham --- Split original helper functions module into ListHelpers and MiscHelpers --- diff --git a/Swish/HaskellUtils/Namespace.hs b/Swish/HaskellUtils/Namespace.hs deleted file mode 100644 --- a/Swish/HaskellUtils/Namespace.hs +++ /dev/null @@ -1,244 +0,0 @@ -{-# OPTIONS -XTypeSynonymInstances #-} -{-# OPTIONS -XMultiParamTypeClasses #-} --------------------------------------------------------------------------------- --- $Id: Namespace.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Namespace --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- 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.HaskellUtils.Namespace - ( Namespace(..) - , makeNamespaceQName - , nullNamespace - , ScopedName(..) - , getScopePrefix, getScopeURI - , getQName, getScopedNameURI - , matchName - , makeScopedName, makeQNameScopedName, makeUriScopedName - , nullScopedName - ) -where - -import Swish.HaskellUtils.QName - ( QName(..), getQNameURI ) - -import Swish.HaskellUtils.LookupMap - ( LookupEntryClass(..) ) - -{- in Prelude??? -import Maybe - ( Maybe(..), fromJust ) --} - ------------------------------------------------------------- --- Namespace, having a prefix and a URI ------------------------------------------------------------- - --- |A NameSpace value consists of a prefix and a corresponding URI. --- The prefix may be Nothing, in which case it is assumed to be inknown. --- -data Namespace = Namespace { nsPrefix :: String, nsURI :: String } - -{- -getNamespacePrefix :: Namespace -> String -getNamespacePrefix = nsPrefix - -getNamespaceURI :: Namespace -> String -getNamespaceURI = nsURI --} - -instance Eq Namespace where - (==) = nsEq - -instance Show Namespace where - show (Namespace p u) = - (if p == "?" then "" else p ++ ":") ++ "<" ++ u ++ ">" - -instance LookupEntryClass Namespace String String where - keyVal (Namespace pre uri) = (pre,uri) - newEntry (pre,uri) = (Namespace pre uri) - -nsEq :: Namespace -> Namespace -> Bool -nsEq (Namespace _ u1) (Namespace _ u2) = u1 == u2 - -makeNamespaceQName :: Namespace -> String -> QName -makeNamespaceQName ns loc = QName (nsURI ns) loc - -nullNamespace :: Namespace -nullNamespace = Namespace "?" "" - ------------------------------------------------------------- --- 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 { snScope :: Namespace, snLocal :: String } - -getScopePrefix :: ScopedName -> String -getScopePrefix = nsPrefix . snScope - -getScopeURI :: ScopedName -> String -getScopeURI = nsURI . snScope - -instance Eq ScopedName where - (==) = snEq - -instance Ord ScopedName where - (<=) = snLe - -instance Show ScopedName where - show (ScopedName n l) = - if pre == "?" then "<"++uri++l++">" else pre++":"++l - where - pre = nsPrefix n - uri = nsURI n - --- Scoped names are equal of ther corresponding QNames are equal -snEq :: ScopedName -> ScopedName -> Bool -snEq s1 s2 = (getQName s1) == (getQName s2) - --- Scoped names are ordered by their QNames -snLe :: ScopedName -> ScopedName -> Bool -snLe s1 s2 = (getQName s1) <= (getQName s2) - --- |Get QName corresponding to a scoped name -getQName :: ScopedName -> QName -getQName n = QName (getScopeURI n) (snLocal n) - --- |Get URI corresponding to a scoped name (using RDF conventions) -getScopedNameURI :: ScopedName -> String -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 from prefix, URI and local name -makeScopedName :: String -> String -> String -> ScopedName -makeScopedName pre nsuri loc = - ScopedName (Namespace pre nsuri) loc - --- |Construct a ScopedName from a QName -makeQNameScopedName :: QName -> ScopedName -makeQNameScopedName (QName u l) = makeScopedName "?" u l - --- |Construct a ScopedName for a bare URI -makeUriScopedName :: String -> ScopedName -makeUriScopedName u = makeScopedName "?" u "" - --- |Null scoped name: this should never appear as a valid name -nullScopedName :: ScopedName -nullScopedName = makeScopedName "?" "" "" - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/Namespace.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: Namespace.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.13 2004/01/07 19:49:12 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.12 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.11 2003/12/03 17:07:24 graham --- Replace occurrences of QName in N3Parser with ScopedName. --- --- Revision 1.10 2003/11/24 17:20:34 graham --- Separate module Vocabulary from module Namespace. --- --- Revision 1.9 2003/11/24 15:46:03 graham --- Rationalize N3Parser and N3Formatter to use revised vocabulary --- terms defined in Namespace.hs --- --- Revision 1.8 2003/11/14 21:48:35 graham --- First cut cardinality-checked datatype-constraint rules to pass test cases. --- Backward chaining is still to do. --- --- Revision 1.7 2003/11/13 01:13:47 graham --- Reworked ruleset to use ScopedName lookup. --- Various minor fixes. --- --- Revision 1.6 2003/11/12 20:44:24 graham --- Added some vocabulary to Namespace. --- Enhaced ScopedName to allow null namespace prefixes, --- following N3 display conventions. --- --- Revision 1.5 2003/10/24 21:05:08 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.4 2003/10/22 16:18:37 graham --- Move common namespace definitions into Namespace module --- (May later move these into separate modules.) --- --- Revision 1.3 2003/10/02 13:41:26 graham --- Supporting changes for RDF axioms and rules defined as Rulesets, --- and moved out of module RDFProofCheck. --- Datatype named using ScopedName rather than QName --- (Datatype framework is still work in progress). --- --- Revision 1.2 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.1 2003/09/24 18:51:36 graham --- Add module Namespace and test cases. --- --- Revision 1.1 2003/09/24 12:51:00 graham --- Add separate QName module and test suite --- diff --git a/Swish/HaskellUtils/Network/URI.hs b/Swish/HaskellUtils/Network/URI.hs deleted file mode 100644 --- a/Swish/HaskellUtils/Network/URI.hs +++ /dev/null @@ -1,754 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: URI.hs,v 1.2 2004/02/02 14:00:39 graham Exp $ --- --- Copyright (c) 2004, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Network.URI --- Copyright : (c) 2004, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- --- This module defines functions for handling URIs. It presents the same --- interface as the GHC Network.URI module, but is implemented using Parsec --- rather than a Regex library that is not available with Hugs. --- --- In addition, four methods are provided for classifying different --- kinds of URI string (as noted in RFC2396bis): --- isURI --- isURIReference --- isRelativeURI --- isAbsoluteURI --- --- The current official reference for URI handling is RFC2396 [1], --- as updated by RFC 2732 [2]. --- --- These are being merged into RFC2396bis [3], a work-in-progress copy of --- which is available at the URI indicated. This document has been used --- as the primary reference for constructing the URI parser implemented --- here, and it is intended that there is a direct relationship between --- the syntax definition in that document and the parser implementation. --- --- [1] http://www.ietf.org/rfc/rfc2396.txt --- [2] http://www.ietf.org/rfc/rfc2732.txt --- [3] http://gbiv.com/protocols/uri/rev-2002/rfc2396bis.html --- (This implementation based on a version dated Sep-2003, --- also available as CVS revision 1.64 from --- http://cvs.apache.org/viewcvs.cgi/ietf-uri/rev-2002/) --- --- Some of the code has been copied from the GHC implementation, but --- the parser is replaced with one that performs more complete --- syntax checking of the URI itself, according to RFC2396bis [3]. --- --------------------------------------------------------------------------------- - -module {-Network.-} Swish.HaskellUtils.Network.URI - ( -- * The @URI@ type - URI(..) - -- * Parsing a @URI@ - , parseURI -- :: String -> Maybe URI - -- * Testing URI categories - , isURI, isURIReference, isRelativeURI, isAbsoluteURI - , isIPv6address, isIPv4address - , testURIReference - -- * Computing relative @URI@s - , relativeTo -- :: URI -> URI -> Maybe URI - -- * Operations on @URI@ strings - -- | support for putting strings into URI-friendly - -- escaped format and getting them back again. - -- This can't be done transparently, because certain characters - -- have different meanings in different kinds of URI. - , reserved, unreserved - , isAllowedInURI, unescapedInURI -- :: Char -> Bool - , escapeChar -- :: (Char->Bool) -> Char -> String - , escapeString -- :: String -> (Char->Bool) -> String - , unEscapeString -- :: String -> String - ) -where - -import Numeric( showIntAtBase ) - -import Data.Char( ord, chr, isHexDigit, isSpace ) - -{- in Prelude??? -import Text.Parsec - ( GenParser(..), ParseError(..) - , parse, (<|>), (), try - , option, many, count, notFollowedBy, lookAhead - , char, satisfy, oneOf, string, letter, digit, hexDigit, eof - ) --} -import Text.ParserCombinators.Parsec - ------------------------------------------------------------- --- The URI datatype ------------------------------------------------------------- - --- |Represents a general universal resource identifier using --- its component parts. --- --- For example, for the URI --- --- > http://www.haskell.org/ghc?query#frag --- --- the components are: --- -data URI = URI - { scheme :: String -- ^ @http@ - , authority :: String -- ^ @www.haskell.org@ - , path :: String -- ^ @\/ghc@ - , query :: String -- ^ @query@ - , fragment :: String -- ^ @frag@ - } - -instance Show URI where - showsPrec _ uri = uriToString uri - ------------------------------------------------------------- --- Parse a URI ------------------------------------------------------------- - --- |Turn a string into a @URI@. --- Returns @Nothing@ if the string is not a valid URI. --- -parseURI :: String -> Maybe URI -parseURI uristr = case parseAll uriReference "" uristr of - Left _ -> Nothing - Right u -> Just u - -isURI :: String -> Bool -isURI = isValidParse uri - -isURIReference :: String -> Bool -isURIReference = isValidParse uriReference - -isRelativeURI :: String -> Bool -isRelativeURI = isValidParse relativeUri - -isAbsoluteURI :: String -> Bool -isAbsoluteURI = isValidParse absoluteUri - -isIPv6address :: String -> Bool -isIPv6address = isValidParse ipv6address - -isIPv4address :: String -> Bool -isIPv4address = isValidParse ipv4address - -isValidParse :: UriParser a -> String -> Bool -isValidParse parser uristr = case parseAll parser "" uristr of - -- Left e -> error (show e) - Left _ -> False - Right u -> True - -testURIReference :: String -> String -testURIReference uristr = show (parseAll uriReference "" uristr) - -parseAll :: UriParser a -> String -> String -> Either ParseError a -parseAll parser filename uristr = parse newparser filename uristr - where - newparser = - do { res <- parser - ; eof - ; return res - } - ------------------------------------------------------------- --- URI parser body based on Parsec elements and combinators ------------------------------------------------------------- - --- Parser parser type. --- Currently -type UriParser a = GenParser Char () a - --- Relative and absolute forms --- --- (Note, per RFC2396bis, fragment id is part of the full URI form) --- --- RFC2396bis, section 4.1 - -uriReference :: UriParser URI -uriReference = uri <|> relativeUri - --- RFC2396bis, section 4.2 - -relativeUri :: UriParser URI -relativeUri = - do { (ua,up) <- hierPart - ; uq <- option "" ( do { string "?" ; uquery } ) - ; uf <- option "" ( do { string "#" ; ufragment } ) - ; return $ URI - { scheme = "" - , authority = ua - , path = up - , query = uq - , fragment = uf - } - } - --- RFC2396bis, section 4.3 - -absoluteUri :: UriParser URI -absoluteUri = - do { us <- uscheme - ; (ua,up) <- hierPart - ; uq <- option "" ( do { string "?" ; uquery } ) - ; return $ URI - { scheme = us - , authority = ua - , path = up - , query = uq - , fragment = "" - } - } - --- RFC2396bis, section 3 - -uri :: UriParser URI -uri = - do { us <- try uscheme - ; (ua,up) <- hierPart - ; uq <- option "" ( do { string "?" ; uquery } ) - ; uf <- option "" ( do { string "#" ; ufragment } ) - ; return $ URI - { scheme = us - , authority = ua - , path = up - , query = uq - , fragment = uf - } - } - -hierPart :: UriParser (String,String) -hierPart = netPath <|> absPath <|> relPath - -netPath :: UriParser (String,String) -netPath = - do { try (string "//") - ; ua <- uauthority - ; (_,up) <- option ("","") absPath - ; return (ua,up) - } - -absPath :: UriParser (String,String) -absPath = - do { char '/' - ; up <- pathSegments - ; return ("",'/':up) - } - -relPath :: UriParser (String,String) -relPath = - do { try uscheme -- RFC2356bis, section 4.1 - ; fail "Scheme name in relative path" - } - <|> - do { up <- pathSegments - ; return ("",up) - } - --- RFC2396bis, section 3.1 - -uscheme :: UriParser String -uscheme = - do { s <- oneThenMany uriAlphaChar (alphanum <|> oneOf "+-.") - ; char ':' - ; return s - } - --- RFC2396bis, section 3.2 - -uauthority :: UriParser String -uauthority = - do { uu <- option "" (try userinfo) - ; uh <- option "" host - ; up <- option "" port - ; return $ uu++uh++up - } - -userinfo :: UriParser String -userinfo = - do { uu <- many (uchar ";:&=+$,") - ; char '@' - ; return (concat uu ++"@") - } - -host :: UriParser String -host = ipv6reference <|> try ipv4address <|> hostname - -ipv6reference :: UriParser String -ipv6reference = - do { char '[' - ; ua <- ipv6address - ; char ']' - ; return $ "[" ++ ua ++ "]" - } - -ipv6address :: UriParser String -ipv6address = - try ( do - { a2 <- count 6 h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ concat a2 ++ a3 - } ) - <|> try ( do - { string "::" - ; a2 <- count 5 h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 0 - ; string "::" - ; a2 <- count 4 h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 1 - ; string "::" - ; a2 <- count 3 h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 2 - ; string "::" - ; a2 <- count 2 h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ concat a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 3 - ; string "::" - ; a2 <- h4c - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ a2 ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 4 - ; string "::" - ; a3 <- ls32 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 5 - ; string "::" - ; a3 <- h4 - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" ++ a3 - } ) - <|> try ( do - { a1 <- opt_n_h4c_h4 6 - ; string "::" - -- ; lookAhead $ char ']' - ; return $ a1 ++ "::" - } ) - "IPv6 address" - -opt_n_h4c_h4 :: Int -> UriParser String -opt_n_h4c_h4 n = option "" $ - do { a1 <- countMinMax 0 n h4c - ; a2 <- h4 - ; return $ concat a1 ++ a2 - } - -ls32 :: UriParser String -ls32 = try ( do - { a1 <- h4c - ; a2 <- h4 - ; return (a1++a2) - } ) - <|> ipv4address - -h4c :: UriParser String -h4c = try $ - do { a1 <- h4 - ; char ':' - ; notFollowedBy (char ':') - ; return $ a1 ++ ":" - } - -h4 :: UriParser String -h4 = countMinMax 1 4 uriHexDigitChar - -ipv4address :: UriParser String -ipv4address = - do { a1 <- decOctet ; char '.' - ; a2 <- decOctet ; char '.' - ; a3 <- decOctet ; char '.' - ; a4 <- decOctet - ; return $ a1++"."++a2++"."++a3++"."++a4 - } - -decOctet :: UriParser String -decOctet = - do { a1 <- countMinMax 1 3 uriDigitChar - ; if read a1 > 255 then - fail "Decimal octet value too large" - else - return a1 - } - -hostname :: UriParser String -hostname = - do { a1 <- domainlabel - ; a2 <- dqualified - ; return $ a1 ++ a2 - } - -dqualified :: UriParser String -dqualified = - do { a1 <- many $ try ( - do { char '.' - ; a2 <- domainlabel - ; return ('.':a2) - } ) - ; a3 <- option "" (string ".") - ; return $ concat a1 ++ a3 - } - -domainlabel :: UriParser String -domainlabel = - do { a1 <- alphanum - ; a2 <- countMinMax 0 62 (alphanum <|> char '-') - ; if (not $ null a2) && (last a2 == '-') then - fail "Domain label ends with '-'" - else - return $ a1:a2 - } - "Domain label" - -alphanum :: UriParser Char -alphanum = uriAlphaChar <|> uriDigitChar - -port :: UriParser String -port = - do { char ':' - ; p <- many uriDigitChar - ; return (':':p) - } - --- RFC2396bis, section 3.3 - -pathSegments :: UriParser String -pathSegments = - do { s1 <- segment - ; s2 <- many $ - do { char '/' - ; s3 <- segment - ; return ('/':s3) - } - ; return $ s1 ++ concat s2 - } - -segment :: UriParser String -segment = - do { ps <- many pchar - ; return $ concat ps - } - -pchar :: UriParser String -pchar = uchar ";:@&=+$," - --- helper function for pchar and friends -uchar :: String -> UriParser String -uchar extras = - do { c <- satisfy unreserved ; return [c] } - <|> escaped - <|> do { c <- oneOf extras ; return [c] } - - --- RFC2396bis, section 3.4 - -uquery :: UriParser String -uquery = - do { ss <- many $ uchar (";:@&=+$,"++"/?") - ; return $ concat ss - } - --- RFC2396bis, section 3.5 - -ufragment :: UriParser String -ufragment = - do { ss <- many $ uchar (";:@&=+$,"++"/?") - ; return $ concat ss - } - --- RFC2396bis, section 2.4.1 - -escaped :: UriParser String -escaped = - do { char '%' - ; h1 <- uriHexDigitChar - ; h2 <- uriHexDigitChar - ; return $ ['%',h1,h2] - } - --- Imports from RFC 2234 - -uriAlphaChar :: UriParser Char -uriAlphaChar = letter - -uriDigitChar :: UriParser Char -uriDigitChar = digit - -uriHexDigitChar :: UriParser Char -uriHexDigitChar = hexDigit - --- Additional parser combinators for common patterns - -oneThenMany :: GenParser t s a -> GenParser t s a -> GenParser t s [a] -oneThenMany p1 pr = - do { a1 <- p1 - ; ar <- many pr - ; return (a1:ar) - } - -countMinMax :: Int -> Int -> GenParser t s a -> GenParser t s [a] -countMinMax m n p | m > 0 = - do { a1 <- p - ; ar <- countMinMax (m-1) (n-1) p - ; return (a1:ar) - } -countMinMax _ n _ | n <= 0 = return [] -countMinMax _ n p = option [] $ - do { a1 <- p - ; ar <- countMinMax 0 (n-1) p - ; return (a1:ar) - } - ------------------------------------------------------------- --- Reconstruct a URI string ------------------------------------------------------------- --- --- Turn a URI into a string. --- --- Algorithm from part 7, sec 5.2, RFC 2396 --- -uriToString :: URI -> ShowS -uriToString URI { scheme=scheme - , authority=authority - , path=path - , query=query - , fragment=fragment - } = - append ":" scheme . - prepend "//" authority . - append "" path . - prepend "?" query . - prepend "#" fragment - where - prepend pre "" rest = rest - prepend pre s rest = pre ++ s ++ rest - append post "" rest = rest - append post s rest = s ++ post ++ rest - ------------------------------------------------------------- --- Character classes ------------------------------------------------------------- - --- |Returns 'True' if the character is a \"reserved\" character in a --- URI. To include a literal instance of one of these characters in a --- component of a URI, it must be escaped. --- --- RDF2396bis: section 2.2 --- -reserved :: Char -> Bool -reserved c = c `elem` "/?#[];:@&=+$," - --- |Returns 'True' if the character is an \"unreserved\" character in --- a URI. These characters do not need to be escaped in a URI. The --- only characters allowed in a URI are either 'reserved', --- 'unreserved', or an escape sequence (@%@ followed by two hex digits). --- --- RDF2396bis: section 2.3 --- -unreserved :: Char -> Bool -unreserved c = (c >= 'A' && c <= 'Z') - || (c >= 'a' && c <= 'z') - || (c >= '0' && c <= '9') - || mark c - -- NOTE: can't use isAlphaNum etc. because these deal with ISO 8859 - -- (and possibly Unicode!) chars. - -- [[[Above was a comment originally in GHC Network/URI.hs: - -- when IRIs are introduced then most codepoints above 128(?) should - -- be treated as unreserved, and higher codepoints for letters should - -- certainly be allowed. - -- ]]] - --- |Returns 'True' if the character is a \"mark\" character. --- --- RDF2396bis: section 2.3 --- -mark :: Char -> Bool -mark c = c `elem` "-_.!~*'()" - --- | Returns 'True' if the character is allowed in a URI. --- -isAllowedInURI :: Char -> Bool -isAllowedInURI c = reserved c || unreserved c || c == '%' -- escape char - --- | Returns 'True' if the character is allowed unescaped in a URI. --- -unescapedInURI :: Char -> Bool -unescapedInURI c = reserved c || unreserved c - ------------------------------------------------------------- --- Escape sequence handling ------------------------------------------------------------- - --- |Escape character if supplied predicate is not satisfied, --- otherwise return character as singleton string. --- -escapeChar :: (Char->Bool) -> Char -> String -escapeChar p c - | p c = [c] - | otherwise = '%' : myShowHex (ord c) "" - where - myShowHex :: Int -> ShowS - myShowHex n r = case showIntAtBase 16 (toChrHex) n r of - [] -> "00" - [c] -> ['0',c] - cs -> cs - toChrHex d - | d < 10 = chr (ord '0' + fromIntegral d) - | otherwise = chr (ord 'A' + fromIntegral (d - 10)) - --- |Can be used to make a string valid for use in a URI. --- -escapeString - :: String -- ^ the string to process - -> (Char->Bool) -- ^ a predicate which returns 'False' - -- if the character should be escaped - -> String -- the resulting URI string -escapeString s p = concatMap (escapeChar p) s - --- |Turns all instances of escaped characters in the string back --- into literal characters. -unEscapeString :: String -> String -unEscapeString [] = "" -unEscapeString ('%':x1:x2:s) | isHexDigit x1 && isHexDigit x2 = - chr (hexDigit x1 * 16 + hexDigit x2) : unEscapeString s - where - hexDigit c - | c >= 'A' && c <= 'F' = ord c - ord 'A' + 10 - | c >= 'a' && c <= 'f' = ord c - ord 'a' + 10 - | otherwise = ord c - ord '0' -unEscapeString (c:s) = c : unEscapeString s - ------------------------------------------------------------- --- Resolving a relative URI relative to a base URI ------------------------------------------------------------- - --- |Returns a new @URI@ which represents the value of the --- first @URI@ interpreted as relative to the second @URI@. --- For example: --- --- > "foo" `relativeTo` "http://bar.org/" = "http://bar.org/foo" --- --- Algorithm from sec 5.2, RFC 2396 --- -relativeTo :: URI -> URI -> Maybe URI -ref `relativeTo` base = - -- ref has a scheme name, use it in its entirety. Otherwise inherit - -- the scheme name from base. - if ref_scheme /= "" then Just ref else - - -- ref has an authority - we're done. Otherwise inherit the authority. - if ref_authority /= "" then Just ref{scheme = base_scheme} else - - -- ref has an absolute path, we're done. - if not (null ref_path) && head ref_path == '/' - then Just ref{scheme = base_scheme, - authority = base_authority} else - - -- relative path... - let new_path = munge (dropLastComponent base_path ++ ref_path) [] - in if isErrorPath new_path - then Nothing - else Just ref{scheme = base_scheme, - authority = base_authority, - path = new_path} - where - URI{ - scheme = ref_scheme, - authority = ref_authority, - path = ref_path, - query = _ref_query, - fragment = _ref_fragment - } = ref - - URI{ - scheme = base_scheme, - authority = base_authority, - path = base_path, - query = _base_query, - fragment = _base_fragment - } = base - - munge [] [] = "" - munge [] ps = concat (reverse ps) - munge ('.':'/':s) ps = munge s ps - munge ['.'] ps = munge [] ps - munge ('.':'.':'/':s) (p:ps) | p /= "/" = munge s ps - munge ['.','.'] (p:ps) = munge [] ps - munge s ps = munge rest' (p':ps) - where (p,rest) = break (=='/') s - (p',rest') = case rest of - '/':r -> (p++"/",r) - r -> (p,r) - - dropLastComponent = reverse . dropWhile (/= '/') . reverse - - isErrorPath ('/':'.':'.':'/':_) = True - isErrorPath _ = False - -stripLeadingWS, stripTrailingWS, stripWS :: String -> String -stripLeadingWS = dropWhile isSpace -stripTrailingWS = reverse . stripLeadingWS . reverse -stripWS = stripLeadingWS . stripTrailingWS - --------------------------------------------------------------------------------- --- --- Copyright (c) 2004, G. KLYNE. All rights reserved. --- --- This 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 this software; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/Network/URI.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: URI.hs,v $ --- Revision 1.2 2004/02/02 14:00:39 graham --- Fix optional host name in URI. Add test cases. --- --- Revision 1.1 2004/01/27 21:13:45 graham --- New URI module and test suite added, --- implementing the GHC Network.URI interface. --- --- diff --git a/Swish/HaskellUtils/Parse.hs b/Swish/HaskellUtils/Parse.hs deleted file mode 100644 --- a/Swish/HaskellUtils/Parse.hs +++ /dev/null @@ -1,249 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: Parse.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : Parse --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This Module defines a collection of parsing functions. --- --- The approach used is based on that in Simon Thompson's book --- The Craft of Functional Programming, pages 354 et seq. --- --- The function type for a parser is given by Parser a b (see below) --- where a is the type of token to be parsed (e.g. Char), and the --- result is a list of pairs (b,[a]), each corresponding to possible parse, --- where the first memeber of the pair is the value parsed, and the --- second is the remaining input sequence following the parsed value. --- --- A successful parse will generally return a list of one, and an --- unsuccessful parse returns an empty list. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.Parse - ( module Swish.HaskellUtils.Parse, isSpace, isAlpha, isDigit, isAlphaNum, isHexDigit ) -where - -import Data.Char - ( isSpace, isAlpha, isDigit, isAlphaNum, isHexDigit ) - -type Parser a b = [a] -> [(b,[a])] -- e.g. [Char] -> [(Result,[Char])] - -alpha :: String -alpha = ['a'..'z']++['A'..'Z'] - -digit :: String -digit = ['0'..'9'] - -alphanum :: String -alphanum = alpha++digit - -hexdigit :: String -hexdigit = digit++['a'..'f']++['A'..'F'] - -isOneOf :: Eq a => [a] -> a -> Bool -isOneOf s c = c `elem` s - --- Assemble alternative parses -parseAlt :: Parser a b -> Parser a b -> Parser a b -parseAlt p1 p2 input = p1 input ++ p2 input - - --- Select one of two parses, prefering the first. -parseOne :: Parser a b -> Parser a b -> Parser a b -parseOne p1 p2 input - | not (null first) = first - | otherwise = p2 input - where first = p1 input - --- Parse optional item returning single list, or empty list if absent -parseOptional :: Parser a [b] -> Parser a [b] -parseOptional p1 = parseOne p1 ( parseReturn [] ) - --- Parse sequence of values, returning list of pairs -infixr 5 >*> -(>*>) :: Parser a b -> Parser a c -> Parser a (b,c) -(>*>) p1 p2 input = - [ ((val1,val2),rem2) | (val1,rem1) <- p1 input, (val2,rem2) <- p2 rem1 ] - --- Apply function to raw result of parse to get required value --- The supplied function must take account of all the possible parse values -parseApply :: Parser a b -> ( b -> c ) -> Parser a c -parseApply p f input = [ (f val,rem) | (val,rem) <- p input ] - --- Function used with parseApply to flatten the pairs returned by --- >*> into a list --- e.g. toList (item,list) = item:list -toList :: (a,[a]) -> [a] -toList = uncurry (:) - --- Function used with parseApply to return a value as a singleton list --- e.g. makeList item = [item] -makeList :: a -> [a] -makeList x = [x] - --- Function used with parseApply to return a value that is a --- concatenation of the members of a list. --- e.g. catList ["ab","cd","ef"] = "abcdef" -catList :: [[a]] -> [a] -catList = foldl (++) [] - --- Indicate completion of expression (or sub-expression), --- returning given value -parseReturn :: b -> Parser a b -parseReturn value input = [(value,input)] - --- Parse any number of tokens matching a supplied parse, --- returning a list of values parsed --- type Parser a b = [a] -> [(b,[a])] -- e.g. [Char] -> [(Result,[Char])] -parseMany :: Parser a b -> Parser a [b] -parseMany p = - parseOne ( ( p >*> (parseMany p) ) `parseApply` toList ) - ( parseReturn [] ) - --- Parse a sequence of a token matching t1 followed by --- any number of tokens matching t2, returning a list of --- tokens thus matched -parseSequence :: ( a -> Bool , a -> Bool) -> Parser a [a] -parseSequence ( t1, t2 ) = - ( parseItem t1 >*> parseMany ( parseItem t2 ) ) - `parseApply` toList - --- Parse a single token matching selector t, returning that value -parseItem :: ( a -> Bool ) -> Parser a a -parseItem t (next:more) - | t next = [(next,more)] - | otherwise = [] -parseItem t [] = [] - -parseWS :: Parser Char String -parseWS = parseMany (parseItem isSpace) - -parseAlpha :: Parser Char Char -parseAlpha = parseItem isAlpha - -parseDigit :: Parser Char Char -parseDigit = parseItem isDigit - -parseAlphaNum :: Parser Char Char -parseAlphaNum = parseItem isAlphaNum - -parseHexDigit :: Parser Char Char -parseHexDigit = parseItem isHexDigit - --- Parse input, returning list of values (all parsers must be same type) -infixr 5 >:> -(>:>) :: Parser a b -> Parser a [b] -> Parser a [b] -(p1 >:> p2) input = - [ (val1:val2,rem2) | (val1,rem1) <- p1 input, (val2,rem2) <- p2 rem1 ] - --- concatenate lists returned by parsers p1 p2 -infixr 5 >++> -(>++>) :: Parser a [b] -> Parser a [b] -> Parser a [b] -(p1 >++> p2) input = - [ (val1++val2,rem2) | (val1,rem1) <- p1 input, (val2,rem2) <- p2 rem1 ] - --- skip token matching p1, then use supplied parser p2 -skipToken :: Parser a b -> Parser a c -> Parser a c -skipToken p1 p2 input = - [ res | (_,rem1) <- p1 input, res <- p2 rem1 ] - --- Fail if end of input not here, otherwise return supplied value -parseEnd :: b -> Parser a b -parseEnd v [] = ( parseReturn v ) [] -parseEnd _ _ = [] - --- Match null input (returning value ()) -parseNull :: Parser a () -parseNull [] = [((),[])] -parseNull _ = [] - --- Test if supplied string matches given parser -isValid :: Parser a b -> [a] -> Bool -isValid parser input = - not ( null ( ( parser >*> parseNull ) input ) ) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/Parse.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: Parse.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.14 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.13 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.12 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.11 2003/03/28 21:50:22 graham --- Graph equality coded and nearly working --- --- Revision 1.10 2003/02/27 13:54:30 graham --- ParseURI module passes unit test --- --- Revision 1.9 2003/02/27 00:29:53 graham --- Add additional parse functions for lists of values --- --- Revision 1.8 2003/02/20 19:44:37 graham --- Added isValid and parseNull to Pase module. --- All tests pass. --- --- Revision 1.7 2003/02/19 20:20:50 graham --- Some small parser enhancements --- --- Revision 1.6 2003/02/19 18:45:00 graham --- Parser unit tests done. --- Worked out some details for simplified parser construction. --- --- Revision 1.5 2003/02/13 16:14:14 graham --- >*> function works --- --- Revision 1.4 2003/02/13 15:09:47 graham --- Initial parser tests all pass. --- --- Revision 1.3 2003/02/13 11:31:18 graham --- Separate parser tests from parser code --- --- Revision 1.2 2003/02/07 18:46:07 graham --- Add new date/time modules --- Update copyright year --- --- Revision 1.1 2003/02/02 15:11:15 graham --- Created new Parsing module --- --- diff --git a/Swish/HaskellUtils/ParseTest.hs b/Swish/HaskellUtils/ParseTest.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ParseTest.hs +++ /dev/null @@ -1,309 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ParseTest.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ParseTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test cases for module Parse functions. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellUtils.ParseTest where - -import Test.HUnit - -import Swish.HaskellUtils.Parse - -testParser :: ( Show a, Show b, Eq a, Eq b ) => String -> Parser a b -> [a] -> [(b,[a])] -> Test -testParser s p i r = - TestCase ( assertEqual s r ( p i ) ) - -noResult :: [ ( (),[Char] ) ] -noResult = [] - -testParseReturn1 = testParser "parseReturn1" (parseReturn "FOO") "" [("FOO","")] -testParseReturn2 = testParser "parseReturn2" (parseReturn "BAR") "**" [("BAR","**")] - -testParseItem1 = testParser "parseItem1" (parseItem (=='1')) "2" [] -testParseItem2 = testParser "parseItem2" (parseItem (=='2')) "abc" [] -testParseItem3 = testParser "parseItem3" (parseItem (=='3')) "3" [('3',"")] -testParseItem4 = testParser "parseItem4" (parseItem (=='4')) "456" [('4',"56")] -testParseItem5 = testParser "parseItem5" (parseItem (=='5')) "" [] - -testParseAlpha1 = testParser "parseAlpha1" parseAlpha "123" [] -testParseAlpha2 = testParser "parseAlpha2" parseAlpha "a**" [('a',"**")] -testParseAlpha3 = testParser "parseAlpha3" parseAlpha "z//" [('z',"//")] -testParseAlpha4 = testParser "parseAlpha4" parseAlpha "Abc" [('A',"bc")] -testParseAlpha5 = testParser "parseAlpha5" parseAlpha "Zyx" [('Z',"yx")] - -testParseDigit1 = testParser "parseDigit1" parseDigit "ab" [] -testParseDigit2 = testParser "parseDigit2" parseDigit "1ab" [('1',"ab")] -testParseDigit3 = testParser "parseDigit3" parseDigit "9ab" [('9',"ab")] -testParseDigit4 = testParser "parseDigit4" parseDigit "55ab" [('5',"5ab")] - -testParseAlphaNum1 = testParser "parseAlphaNum1" parseAlphaNum "..." [] -testParseAlphaNum2 = testParser "parseAlphaNum2" parseAlphaNum "a**" [('a',"**")] -testParseAlphaNum3 = testParser "parseAlphaNum3" parseAlphaNum "z//" [('z',"//")] -testParseAlphaNum4 = testParser "parseAlphaNum4" parseAlphaNum "Abc" [('A',"bc")] -testParseAlphaNum5 = testParser "parseAlphaNum5" parseAlphaNum "Zyx" [('Z',"yx")] -testParseAlphaNum6 = testParser "parseAlphaNum6" parseAlphaNum "123" [('1',"23")] -testParseAlphaNum7 = testParser "parseAlphaNum7" parseAlphaNum "987" [('9',"87")] - -parseAltParser = parseAlt parseDigit parseAlpha -testParseAlt1 = testParser "parseAlt1" parseAltParser "..." [] -testParseAlt2 = testParser "parseAlt2" parseAltParser "123" [('1',"23")] -testParseAlt3 = testParser "parseAlt3" parseAltParser "ABC" [('A',"BC")] - -parseOneParser = parseOne parseDigit parseAlpha -testParseOne1 = testParser "parseOne1" parseOneParser "###" [] -testParseOne2 = testParser "parseOne2" parseOneParser "123" [('1',"23")] -testParseOne3 = testParser "parseOne3" parseOneParser "ABC" [('A',"BC")] - -parseOptParser = parseOptional ( parseDigit `parseApply` makeList ) -testParseOpt1 = testParser "parseOpt1" parseOptParser "###" [([],"###")] -testParseOpt2 = testParser "parseOpt2" parseOptParser "123" [(['1'],"23")] -testParseOpt3 = testParser "parseOpt3" parseOptParser "ABC" [([],"ABC")] - -parseSeqParser - = ( parseAlpha >*> p1 ) `parseApply` toList - where - p1 = ( ( parseItem (== '-') ) >*> p2 ) `parseApply` toList - p2 = ( parseDigit >*> (parseReturn []) ) `parseApply` toList - -testParseSeq1 = testParser "parseSeq1" parseSeqParser "???" [] -testParseSeq2 = testParser "parseSeq2" parseSeqParser "A-1>>>" [("A-1",">>>")] -testParseSeq3 = testParser "parseSeq3" parseSeqParser "Z-9" [("Z-9","")] -testParseSeq4 = testParser "parseSeq4" parseSeqParser "1-A>>>" [] -testParseSeq5 = testParser "parseSeq5" parseSeqParser "A#1>>>" [] - --- parseMany :: Parser a b -> Parser a [b] -parseManyParser = parseMany parseDigit - -testParseMany1 = testParser "parseMany1" parseManyParser "ab" [("","ab")] -testParseMany2 = testParser "parseMany2" parseManyParser "2ab" [("2","ab")] -testParseMany3 = testParser "parseMany3" parseManyParser "3" [("3","")] -testParseMany4 = testParser "parseMany4" parseManyParser "444" [("444","")] -testParseMany5 = testParser "parseMany5" parseManyParser "54321ab" [("54321","ab")] -testParseMany6 = testParser "parseMany6" parseManyParser "" [("","")] - --- parseSequence :: ( a -> Bool , a -> Bool) -> Parser a [a] -parseIdParser = parseSequence ( isAlpha, isAlphaNum ) - -testParseId1 = testParser "parseId1" parseIdParser "123" [] -testParseId2 = testParser "parseId2" parseIdParser "b2z9" [("b2z9","")] -testParseId3 = testParser "parseId3" parseIdParser "c" [("c","")] -testParseId4 = testParser "parseId4" parseIdParser "d444**" [("d444","**")] -testParseId5 = testParser "parseId5" parseIdParser "efg55.6" [("efg55",".6")] -testParseId6 = testParser "parseId6" parseIdParser "" [] - --- infixr 5 >:> --- (>:>) :: Parser a b -> Parser a [b] -> Parser a [b] - --- skip whitespace then use supplied parser -skipWS :: Parser Char a -> Parser Char a -skipWS = skipToken parseWS - -parseIdent :: Parser Char String -parseIdent = parseSequence ( isAlpha, isAlphaNum ) - -parseNumber :: Parser Char String -parseNumber = parseSequence ( isDigit, isDigit ) - --- type Parser a b = [a] -> [(b,[a])] -- e.g. [Char] -> [(Result,[Char])] -parseOp :: String -> Parser Char String -parseOp op = foldr (>:>) (parseReturn "") [ parseItem (==c) | c <- op ] - -parseExprParser = (skipWS parseIdent) >:> - (skipWS (parseOp ":=")) >:> - (skipWS parseNumber) >:> - (skipWS (parseOp "+")) >:> - (skipWS parseNumber ) >:> - (skipWS (parseOp ";")) >:> - (skipWS (parseReturn [])) - -testParseExpr1 = testParser "parseExpr1" parseExprParser "// yyy" [] -testParseExpr2 = testParser "parseExpr2" parseExprParser "A:=1+1;" - [(["A",":=","1","+","1",";"],"")] -testParseExpr3 = testParser "parseExpr3" parseExprParser " B := 2 + 2 ; " - [(["B",":=","2","+","2",";"],"")] -testParseExpr4 = testParser "parseExpr4" parseExprParser "CCC := 33+34 ; // xxx" - [(["CCC",":=","33","+","34",";"],"// xxx")] -testParseExpr5 = testParser "parseExpr5" parseExprParser "D5 := 5 + 55 ;//yyy" - [(["D5",":=","5","+","55",";"],"//yyy")] -testParseExpr6 = testParser "parseExpr6" parseExprParser "D5 :* 5 + 55 ;//yyy" [] -testParseExpr7 = testParser "parseExpr7" parseExprParser "" [] - -parseExprLstParser = (skipWS parseIdent) >++> - (skipWS (parseOp ":=")) >++> - (skipWS parseNumber) >++> - (skipWS (parseOp "+")) >++> - (skipWS parseNumber ) >++> - (skipWS (parseOp ";")) >++> - (skipWS (parseReturn [])) - -testParseExprLst1 = testParser "parseExprLst1" parseExprLstParser - "// yyy" - [] -testParseExprLst2 = testParser "parseExprLst2" parseExprLstParser - "A:=1+1;" - [("A:=1+1;","")] -testParseExprLst3 = testParser "parseExprLst3" parseExprLstParser - " B := 2 + 2 ; " - [("B:=2+2;","")] -testParseExprLst4 = testParser "parseExprLst4" parseExprLstParser - "CCC := 33+34 ; // xxx" - [("CCC:=33+34;","// xxx")] -testParseExprLst5 = testParser "parseExprLst5" parseExprLstParser - "D5 := 5 + 55 ;//yyy" - [("D5:=5+55;","//yyy")] -testParseExprLst6 = testParser "parseExprLst6" parseExprLstParser - "D5 :* 5 + 55 ;//yyy" - [] -testParseExprLst7 = testParser "parseExprLst7" parseExprLstParser - "" - [] - -makeListParser = parseManyParser `parseApply` makeList - -testMakeList1 = testParser "testMakeList1" makeListParser "ab" [([""],"ab")] -testMakeList2 = testParser "testMakeList2" makeListParser "2ab" [(["2"],"ab")] - -catListParser = makeListParser `parseApply` catList -catExprParser = parseExprParser `parseApply` catList - -testCatList1 = testParser "testCatList1" catListParser "ab" [("","ab")] -testCatList2 = testParser "testCatList2" catListParser "2ab" [("2","ab")] -testCatList3 = testParser "testCatList3" catExprParser - "D5 := 5 + 55 ;//yyy" [("D5:=5+55;","//yyy")] -testCatList4 = testParser "testCatList4" catExprParser - "D5 :* 5 + 55 ;//yyy" [] -testCatList5 = testParser "testCatList5" catExprParser - "" [] - -testParseNull1 = testParser "parseNull1" - parseNull "a" noResult -testParseNull2 = testParser "parseNull2" - parseNull "" [((),"")] - -testIsValid :: String -> Parser a b -> Bool -> [a] -> Test -testIsValid label parser match input = - TestCase ( assertEqual label match ( (isValid parser) input ) ) - -testParseEnd1 = testParser "parseEnd1" (parseEnd "") "" [("",[])] -testParseEnd2 = testParser "parseEnd2" (parseEnd "") "xx" [] - -testIsValid1 = testIsValid "testIsValid1" parseExprParser False "// yyy" -testIsValid2 = testIsValid "testIsValid2" parseExprParser True "A:=1+1;" -testIsValid3 = testIsValid "testIsValid3" parseExprParser True " B := 2 + 2 ; " -testIsValid4 = testIsValid "testIsValid4" parseExprParser False "CCC := 33+34 ; // xxx" -testIsValid5 = testIsValid "testIsValid5" parseExprParser False "D5 := 5 + 55 ;//yyy" -testIsValid6 = testIsValid "testIsValid6" parseExprParser False "D5 :* 5 + 55 ;//yyy" -testIsValid7 = testIsValid "testIsValid7" parseExprParser False "" - -allTests = TestList - [ testParseReturn1, testParseReturn2, - testParseItem1, testParseItem2, testParseItem3, testParseItem4, testParseItem5, - testParseAlpha1, testParseAlpha2, testParseAlpha3, testParseAlpha4, testParseAlpha5, - testParseDigit1, testParseDigit2, testParseDigit3, testParseDigit4, - testParseAlphaNum1, testParseAlphaNum2, testParseAlphaNum3, testParseAlphaNum4, - testParseAlphaNum5, testParseAlphaNum6, testParseAlphaNum7, - testParseAlt1, testParseAlt2, testParseAlt3, - testParseOne1, testParseOne2, testParseOne3, - testParseOpt1, testParseOpt2, testParseOpt3, - testParseSeq1, testParseSeq2, testParseSeq3, testParseSeq4, testParseSeq5, - testParseMany1, testParseMany2, testParseMany3, testParseMany4, - testParseMany5, testParseMany6, - testParseId1, testParseId2, testParseId3, testParseId4, - testParseId5, testParseId6, - testParseExpr1, testParseExpr2, testParseExpr3, testParseExpr4, - testParseExpr5, testParseExpr6, testParseExpr7, - testParseExprLst1, testParseExprLst2, testParseExprLst3, - testParseExprLst4, testParseExprLst5, - testParseExprLst6, testParseExprLst7, - testMakeList1, testMakeList2, - testCatList1, testCatList2, testCatList3, testCatList4, - testCatList5, - testParseNull1, testParseNull2, - testIsValid1, testIsValid2, testIsValid3, testIsValid4, - testIsValid5, testIsValid6, testIsValid7, - testParseEnd1, testParseEnd2 ] - -main = runTestTT allTests - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ParseTest.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ParseTest.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.12 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.11 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.10 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.9 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.8 2003/02/27 13:54:30 graham --- ParseURI module passes unit test --- --- Revision 1.7 2003/02/27 00:29:53 graham --- Add additional parse functions for lists of values --- --- Revision 1.6 2003/02/20 19:44:37 graham --- Added isValid and parseNull to Pase module. --- All tests pass. --- --- Revision 1.5 2003/02/19 20:20:50 graham --- Some small parser enhancements --- --- Revision 1.4 2003/02/19 18:45:00 graham --- Parser unit tests done. --- Worked out some details for simplified parser construction. --- --- Revision 1.3 2003/02/13 16:14:14 graham --- >*> function works --- --- Revision 1.2 2003/02/13 15:09:47 graham --- Initial parser tests all pass. --- --- Revision 1.1 2003/02/13 11:31:18 graham --- Separate parser tests from parser code --- diff --git a/Swish/HaskellUtils/ParseURI.hs b/Swish/HaskellUtils/ParseURI.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ParseURI.hs +++ /dev/null @@ -1,503 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ParseURI.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ParseURI --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a collection of functions for parsing URIs. --- --- These are used mainly as helper functions by the module URI. --- --- The current official reference for URI handling is RFC2396 [1], --- as updated by RFC 2732 [2]. --- --- These are being merged into RFC2396bis [3], a work-in-progress copy of --- which is available at the URI indicated. This document has been used --- as the primary reference for constructing the URI parser implemented --- here, and it is intended that there is a direct relationship between --- the syntax definition in that document and the parser implementation. --- --- [1] http://www.ietf.org/rfc/rfc2396.txt --- [2] http://www.ietf.org/rfc/rfc2732.txt --- [3] http://www.apache.org/~fielding/uri/rev-2002/rfc2396bis.html --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.ParseURI - ( URI(URI), - absoluteUri, relativeUri, uriReference, absoluteUriReference, - uriToString, - hostname, ipv4address, ipv6address, relSegmentWithColon - ) where - - -- absoluteUri :: Parser Char URI -- no fragment - -- relativeUri :: Parser Char URI -- no fragment - -- uriReference :: Parser Char URI -- optional fragment - -- absoluteUriReference :: Parser Char URI -- absolute with opt frag - -- uriToString :: URI -> String - -- hostname :: Parser Char String - -- ipv4address :: Parser Char String - -- ipv6address :: Parser Char String - - -- Declare imports used from Parser module - import qualified Swish.HaskellUtils.Parse as Parse - - type Parser a b = Parse.Parser a b - - isOneOf :: Eq a => [a] -> a -> Bool - isOneOf = Parse.isOneOf - - isAlpha :: Char -> Bool - isAlpha = Parse.isAlpha - - isDigit :: Char -> Bool - isDigit = Parse.isDigit - - isAlphaNum :: Char -> Bool - isAlphaNum = Parse.isAlphaNum - - isHexDigit :: Char -> Bool - isHexDigit = Parse.isHexDigit - - parseApply = Parse.parseApply - parseReturn = Parse.parseReturn - parseOne = Parse.parseOne - parseAlt = Parse.parseAlt - parseOptional = Parse.parseOptional - parseSequence = Parse.parseSequence - parseMany = Parse.parseMany - parseItem = Parse.parseItem - catList = Parse.catList - makeList = Parse.makeList - (>++>) = (Parse.>++>) - (>:>) = (Parse.>:>) - (>*>) = (Parse.>*>) - - alphanumCh :: String - alphanumCh = Parse.alphanum - - -- Generic URI parser - -- Each parser rule is a local function definition, - -- mostly based on the function type: Parser Char String - -- e.g. parseURI :: Parser Char URI - - -- Internal data type for URI - -- Components are: - -- scheme authority [segments] query fragment - -- e.g. - -- "http:" "//example.org" ["/","dir/","file"] "?q" "#f" - -- "mailto:" "" ["local@domain"] "" "#f" - -- - -- Note: opaque paths are presented as an authority string with - -- empty list of segments and query values. I think (?) this - -- yields the correct behaviour when working with relative URIs - -- Note: if the final path segment ends with a "/", an empty segment - -- is appended to the segment list. Thus, the final element - -- of the list corresponds (roughly) to a filename rather than - -- a directory name. - -- - data URI = URI String String [String] String String - deriving ( Eq, Show ) - type URIPath = (String,[String],String) - - makeAbsUri (s,(a,p,q)) = URI s a p q "" - makeRelUri (a,p,q) = URI "" a p q "" - setFragment (URI s a p q _, f1) = URI s a p q f1 - makeHierPath ((a,p),q) = (a,p,q) - makeOpaqPath s = (s,[],"") - - nullURI :: URI - nullURI = URI "" "" [] "" "" - - uriToString :: URI -> String - uriToString (URI sch aut seg qry frag) = - sch++aut++(foldl (++) [] seg)++qry++frag - - -- Local helper functions - nullStr = parseReturn [] - alt = parseAlt - one = parseOne - oneOf = foldr1 one - anyOf = foldr1 alt - opt p = alt p nullStr - rep p = alt ( p >++> (rep p) ) ( parseReturn [] ) - no p inp = if null (p inp) then [([],inp)] else [] - -- optG and repG are "greedy" versions of opt and rep - optG p = one p nullStr - repG p = one ( p >++> (repG p) ) ( parseReturn [] ) - - char c = cclass (==c) - cclass t = (parseItem t ) `parseApply` makeList - - count (mn,mx) p = ( ( countEq mn p ) >++> ( countMax (mx-mn) p ) ) - countEq n p - | n > 0 = ( p >++> ( countEq (n-1) p ) ) - | otherwise = parseReturn [] - countMax n p - | n > 0 = opt ( p >++> ( countMax (n-1) p ) ) - | otherwise = parseReturn [] - - -- Syntax copied almost verbatim from RFC2396bis: - -- http://www.apache.org/~fielding/uri/rev-2002/rfc2396bis.html - - -- Character parsers - - -- misc - alpha :: String -> [(String, String)] - alpha = (cclass isAlpha) - - alphanum :: String -> [(String, String)] - alphanum = (cclass isAlphaNum) - - alnumhyp :: String -> [(String, String)] - alnumhyp = alt (cclass isAlphaNum) (char '-') - - digit :: String -> [(String, String)] - digit = (cclass isDigit) - - hexdigit :: String -> [(String, String)] - hexdigit = (cclass isHexDigit) - - dot :: String -> [(String, String)] - dot = (char '.') - - slash :: String -> [(String, String)] - slash = (char '/') - - colon :: String -> [(String, String)] - colon = (char ':') - - - -- sect 2 - uric :: String -> [(String, String)] - uric = oneOf [ reserved, unreserved, escaped ] - - -- sect 3 - uricNoSlash :: String -> [(String, String)] - uricNoSlash = oneOf - [ unreserved, - (char '['), - (char ']'), - (char ';'), - (char '?'), - (char ':'), - (char '@'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ','), - escaped ] - -- sect 2.2 - reserved :: String -> [(String, String)] - reserved = oneOf - [ (char '['), - (char ']'), - (char ';'), - (char '/'), - (char '?'), - (char ':'), - (char '@'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ',') ] - -- sect 2.3 - unreserved :: String -> [(String, String)] - unreserved = oneOf - [ (cclass isAlpha), - (cclass isDigit), - mark ] - mark :: String -> [(String, String)] - mark = oneOf - [ (char '-'), - (char '_'), - (char '.'), - (char '!'), - (char '~'), - (char '*'), - (char '\''), - (char '('), - (char ')') ] - -- sect 2.4.1 - escaped :: String -> [(String, String)] - escaped = (char '%') >++> hexdigit >++> hexdigit - -- sect 3.3 - pchar :: String -> [(String, String)] - pchar = oneOf - [ unreserved, - (char ';'), - (char ':'), - (char '@'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ','), - escaped ] - - -- URI parser - - -- sect 3 (see also section 4.3) - -- absoluteUri -> URI scheme: Path "" - absoluteUri :: Parser Char URI - absoluteUri = (scheme >++> colon) >*> (alt hierPart opaquePart) - `parseApply` makeAbsUri - - hierPart :: Parser Char URIPath - hierPart = (one netPath absPath) >*> optG ((char '?') >++> query) - `parseApply` makeHierPath - netPath :: Parser Char (String,[String]) - netPath = (slash >++> slash >++> authority) >*> (optG absPath1) - absPath :: Parser Char (String,[String]) - absPath = nullStr >*> absPath1 - absPath1 :: Parser Char [String] - absPath1 = slash >:> pathSegments - - opaquePart :: Parser Char URIPath - opaquePart = uricNoSlash >++> ( repG uric ) - `parseApply` makeOpaqPath - - -- sect 3.1 - scheme :: Parser Char String - scheme = parseSequence ( isAlpha, (isOneOf (alphanumCh++"+-.")) ) - - -- sect 3.2 - authority :: Parser Char String - authority = oneOf [ server, regName, nullStr ] - - -- sect 3.2.1 - regName :: Parser Char String - regName = regChar >++> ( repG regChar ) - regChar :: String -> [(String, String)] - regChar = oneOf - [ unreserved, - (char ';'), - (char ':'), - (char '@'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ','), - escaped ] - - -- sect 3.2.2 - -- NOTE: blank server option is handled by 'authority' production - server :: Parser Char String - server = opt ( userinfo >++> (char '@') ) >++> hostport - userinfo :: String -> [(String, String)] - userinfo = uinfoCh >++> ( repG uinfoCh ) - uinfoCh :: String -> [(String, String)] - uinfoCh = oneOf - [ unreserved, -- regChar without '@' - (char ';'), - (char ':'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ','), - escaped ] - hostport :: String -> [(String, String)] - hostport = host >++> ( optG ( colon >++> port ) ) - host :: String -> [(String, String)] - host = oneOf [ ipv6reference, ipv4address, hostname ] - port :: String -> [(String, String)] - port = repG digit - - hostname :: Parser Char String - hostname = domainlabel >++> ( optG qualified ) - qualified :: String -> [(String, String)] - qualified = ( rep ( dot >++> domainlabel ) ) >++> - ( opt ( dot >++> toplabel >++> dot >++> (no alphanum) ) ) >++> - ( no dot ) -- force all available domain labels to be taken - domainlabel :: String -> [(String, String)] - domainlabel = alphanum >++> morelabel - toplabel :: String -> [(String, String)] - toplabel = alpha >++> morelabel - morelabel :: String -> [(String, String)] - morelabel = optG ( ( countMax 61 alnumhyp ) >++> alphanum - >++> (no alnumhyp) ) - - ipv4address :: String -> [(String, String)] - ipv4address = decoctet >++> dot >++> decoctet - >++> dot >++> decoctet - >++> dot >++> decoctet - decoctet :: String -> [(String, String)] - decoctet = anyOf - [ digit, - digit19 >++> digit, - (char '1') >++> digit >++> digit, - (char '2') >++> digit04 >++> digit, - (char '2') >++> (char '5') >++> digit05 ] - digit19 :: String -> [(String, String)] - digit19 = (cclass (isOneOf "123456789") ) - digit12 :: String -> [(String, String)] - digit12 = (cclass (isOneOf "12") ) - digit04 :: String -> [(String, String)] - digit04 = (cclass (isOneOf "01234") ) - digit05 :: String -> [(String, String)] - digit05 = (cclass (isOneOf "012345") ) - - ipv6reference :: String -> [(String, String)] - ipv6reference = (char '[') >++> ipv6address >++> (char ']') - ipv6address :: String -> [(String, String)] - ipv6address = anyOf - [ (countEq 6 h4c) >++> ls32, - cc >++> (countEq 5 h4c) >++> ls32, - opt h4 >++> cc >++> (countEq 4 h4c) >++> ls32, - (n_h4c_h4 1) >++> cc >++> (countEq 3 h4c) >++> ls32, - (n_h4c_h4 2) >++> cc >++> (countEq 2 h4c) >++> ls32, - (n_h4c_h4 3) >++> cc >++> h4c >++> ls32, - (n_h4c_h4 4) >++> cc >++> ls32, - (n_h4c_h4 5) >++> cc >++> h4, - (n_h4c_h4 5) >++> cc ] - h4c = h4 >++> colon - n_h4c_h4 n = opt ( (countMax n h4c) >++> h4 ) - cc :: String -> [(String, String)] - cc = colon >++> colon - h4 :: String -> [(String, String)] - h4 = count (1,4) hexdigit - ls32 :: String -> [(String, String)] - ls32 = alt (h4c >++> h4) ipv4address - - -- sect 3.3 - pathSegments :: Parser Char [String] - pathSegments = one ( (segment >++> slash) >:> pathSegments ) - ( segment `parseApply` makeList ) - segment :: String -> [(String, String)] - segment = repG pchar - - -- sect 3.4 - query :: Parser Char String - query = repG ( oneOf [ pchar, slash, (char '?') ] ) - - -- sect 4 - uriReference :: Parser Char URI - uriReference = ( ( oneOf [ absoluteUri, relativeUri, emptyURI ] ) - >*> optfrag ) - `parseApply` setFragment - emptyURI = parseReturn nullURI - optfrag :: String -> [(String, String)] - optfrag = optG ( (char '#') >++> fragment ) - - absoluteUriReference :: Parser Char URI - absoluteUriReference = ( absoluteUri >*> optfrag ) - `parseApply` setFragment - - -- sect 4.1 - fragment :: Parser Char String - fragment = repG ( oneOf [ pchar, slash, (char '?') ] ) - - -- sect 5 - relativeUri :: Parser Char URI - relativeUri = ( oneOf [ netPath, absPath, relPath, nulPath ] >*> - optG ((char '?') >++> query) - `parseApply` makeHierPath ) - `parseApply` makeRelUri - - nulPath :: Parser Char (String,[String]) - nulPath = parseReturn ("",[]) - - relPath :: Parser Char (String,[String]) --- relPath = nullStr >*> (relSegment >:> optG absPath1) - relPath = nullStr >*> one ( relSegment >++> slash >:> pathSegments ) - ( relSegment `parseApply` makeList ) - -- [[[TODO: factor higher order function - -- for relPath and pathSegments]]] - - relSegment :: Parser Char String - relSegment = relSegCh >++> (repG relSegCh) - relSegCh :: String -> [(String, String)] - relSegCh = oneOf - [ unreserved, -- pchar without ':' - (char ';'), - (char '@'), - (char '&'), - (char '='), - (char '+'), - (char '$'), - (char ','), - escaped ] - - relSegmentWithColon :: Parser Char String - relSegmentWithColon = relSegment >++> colon >++> segment - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ParseURI.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ParseURI.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.11 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.10 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.9 2003/05/20 23:35:28 graham --- Modified code to compile with GHC hierarchical libraries --- --- Revision 1.8 2003/03/05 22:16:23 graham --- URI code passes all unit tests --- --- Revision 1.7 2003/03/05 14:47:45 graham --- Relative URI code complete, not tested --- Fixed a URI parser bug --- --- Revision 1.6 2003/02/27 20:29:53 graham --- Fixed some more parser bugs. --- All parser tests pass. --- QName and relative path handling to do. --- --- Revision 1.5 2003/02/27 18:48:05 graham --- Fix URI parser bug. --- Add more URI parser test cases. --- --- Revision 1.4 2003/02/27 15:28:45 graham --- Updated internal structure of parsed URI. --- Passes parser unit tests --- --- Revision 1.3 2003/02/27 13:54:30 graham --- ParseURI module passes unit test --- --- Revision 1.2 2003/02/27 09:50:25 graham --- Add URI parser test cases, some name changes --- --- Revision 1.1 2003/02/27 08:59:53 graham --- Separate URI parser from main URI module --- diff --git a/Swish/HaskellUtils/ParseURITest.hs b/Swish/HaskellUtils/ParseURITest.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ParseURITest.hs +++ /dev/null @@ -1,491 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ParseURITest.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ParseURITest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines test cases for module ParseURI. --- --- The tests here are intended to be confidence-setting rather than --- exhaustive: the module URITest exercises a far wider range of --- URI forms, via the URI module which uses this parser to break a --- URI into its component parts. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellUtils.ParseURITest where - -import Test.HUnit -import Swish.HaskellUtils.Parse -import Swish.HaskellUtils.ParseURI -import System.IO ( Handle, openFile, IOMode(WriteMode), hClose, hPutStr, hPutStrLn ) - -testParser :: ( Show a, Show b, Eq a, Eq b ) => - String -> Parser a b -> [a] -> [(b,[a])] -> Test -testParser lab parser inp res = - TestCase ( assertEqual lab res (pend inp) ) - where - pend = ( parser >*> (parseEnd []) ) `parseApply` fst - --- hostname - -hostnameTest lab inp res = - testParser ("hostnameTest"++lab) hostname inp res - -hostnameTest01 = hostnameTest "01" "example.org" [ ("example.org","") ] - -hostnameTests = TestList - [ hostnameTest01 --, hostnameTest02, hostnameTest03, hostnameTest04, - ] - --- ipv6 - -ipv6Test lab inp res = - testParser ("ipv6Test"++lab) ipv6address inp res - -ipv6Test01 = ipv6Test "01" "FEDC:BA98:7654:3210:FEDC:BA98:7654:3210" - [ ("FEDC:BA98:7654:3210:FEDC:BA98:7654:3210","") ] - -ipv6Test02 = ipv6Test "02" "FEDC:BA98:7654:3210:FEDC:BA98:192.9.5.5" - [ ("FEDC:BA98:7654:3210:FEDC:BA98:192.9.5.5","") ] - -ipv6Test03 = ipv6Test "03" "1080:0:0:0:8:800:200C:417A" - [ ("1080:0:0:0:8:800:200C:417A","") ] - -ipv6Test04 = ipv6Test "04" "3ffe:2a00:100:7031::1" - [ ("3ffe:2a00:100:7031::1","") ] - -ipv6Test05 = ipv6Test "05" "1080::8:800:200C:417A" - [ ("1080::8:800:200C:417A","") ] - -ipv6Test06 = ipv6Test "06" "::192.9.5.5" - [ ("::192.9.5.5","") ] - -ipv6Test07 = ipv6Test "07" "::FFFF:129.144.52.38" - [ ("::FFFF:129.144.52.38","") ] - -ipv6Test08 = ipv6Test "08" "2010:836B:4179::836B:4179" - [ ("2010:836B:4179::836B:4179","") ] - -ipv6Test09 = ipv6Test "09" "::200C:417A" - [ ("::200C:417A","") ] - -ipv6Test10 = ipv6Test "10" "::417A" - [ ("::417A","") ] - -ipv6Test11 = ipv6Test "11" "3ffe:2a00::417A" - [ ("3ffe:2a00::417A","") ] - -ipv6Tests = TestList - [ ipv6Test01, ipv6Test02, ipv6Test03, ipv6Test04, - ipv6Test05, ipv6Test06, ipv6Test07, ipv6Test08, - ipv6Test09, ipv6Test10, ipv6Test11 - ] - --- absoluteUri :: Parser Char URI - -absoluteUriTest lab inp res = - testParser ("absoluteUriTest"++lab++": "++inp) absoluteUri inp res - -absoluteUriTest01 = absoluteUriTest "01" - "http://example.org/aaa/bbb" - [ ( URI "http:" "//example.org" ["/","aaa/","bbb"] "" "", "" ) ] - -absoluteUriTest02 = absoluteUriTest "02" - "mailto:local@domain.org" - [ ( URI "mailto:" "local@domain.org" [] "" "", "" ) ] - -absoluteUriTest03 = absoluteUriTest "03" - "mailto:local@domain.org" - [ ( URI "mailto:" "local@domain.org" [] "" "", "" ) ] - -absoluteUriTest04 = absoluteUriTest "04" - "HTTP://EXAMPLE.ORG/AAA/BBB" - [ ( URI "HTTP:" "//EXAMPLE.ORG" ["/","AAA/","BBB"] "" "", "" ) ] - -absoluteUriTest05 = absoluteUriTest "05" - "http://example.org/aaa/bbb?qqq/rrr" - [ ( URI "http:" "//example.org" ["/","aaa/","bbb"] "?qqq/rrr" "", "" ) ] - -absoluteUriTest06 = absoluteUriTest "06" - "//example.org/aaa/bbb" - [] - -absoluteUriTest07 = absoluteUriTest "07" - "/aaa/bbb" - [] - -absoluteUriTest08 = absoluteUriTest "08" - "bbb" - [] - -absoluteUriTest09 = absoluteUriTest "09" - "#ccc" - [] - -absoluteUriTest10 = absoluteUriTest "10" - "#" - [] - -absoluteUriTest11 = absoluteUriTest "11" - "/" - [] - -absoluteUriTest12 = absoluteUriTest "12" - "http://[1080::8:800:200C:417A]/foo" - [ ( URI "http:" "//[1080::8:800:200C:417A]" ["/","foo"] "" "", "" ) ] - -absoluteUriTest13 = absoluteUriTest "13" - "http://[::192.9.5.5]/ipng" - [ ( URI "http:" "//[::192.9.5.5]" ["/","ipng"] "" "", "" ) ] - -absoluteUriTest14 = absoluteUriTest "14" - "http://[1080::8:800:192.9.5.5]/foo" - [ ( URI "http:" "//[1080::8:800:192.9.5.5]" ["/","foo"] "" "", "" ) ] - -absoluteUriTest15 = absoluteUriTest "15" - "http://[::200C:417A]/ipng" - [ ( URI "http:" "//[::200C:417A]" ["/","ipng"] "" "", "" ) ] - -absoluteUriTest16 = absoluteUriTest "16" - "http://[::417A]/ipng" - [ ( URI "http:" "//[::417A]" ["/","ipng"] "" "", "" ) ] - -absoluteUriTest17 = absoluteUriTest "17" - "http://192.9.5.5/ipng" - [ ( URI "http:" "//192.9.5.5" ["/","ipng"] "" "", "" ) ] - -absoluteUriTest18 = absoluteUriTest "18" - "http://example.org:/aaa/bbb" - [ ( URI "http:" "//example.org:" ["/","aaa/","bbb"] "" "", "" ) ] - -absoluteUriTests = TestList - [ absoluteUriTest01, absoluteUriTest02, absoluteUriTest03, - absoluteUriTest04, absoluteUriTest05, absoluteUriTest06, - absoluteUriTest07, absoluteUriTest08, absoluteUriTest09, - absoluteUriTest10, absoluteUriTest11, absoluteUriTest12, - absoluteUriTest13, absoluteUriTest14, absoluteUriTest15, - absoluteUriTest16, absoluteUriTest17, absoluteUriTest18 ] - --- relativeUri :: Parser Char URI - -relativeUriTest lab inp res = - testParser ("relativeUriTest"++lab) relativeUri inp res - -relativeUriTest01 = relativeUriTest "01" - "//example.org/aaa/bbb" - [ ( URI "" "//example.org" ["/","aaa/","bbb"] "" "", "" ) ] - -relativeUriTest02 = relativeUriTest "02" - "local@domain.org" - [ ( URI "" "" ["local@domain.org"] "" "", "" ) ] - -relativeUriTest03 = relativeUriTest "03" - "mailto:local@domain.org" - [] - -relativeUriTest04 = relativeUriTest "04" - "//EXAMPLE.ORG/AAA/BBB" - [ ( URI "" "//EXAMPLE.ORG" ["/","AAA/","BBB"] "" "", "" ) ] - -relativeUriTest05 = relativeUriTest "05" - "//example.org/aaa/bbb?qqq/rrr" - [ ( URI "" "//example.org" ["/","aaa/","bbb"] "?qqq/rrr" "", "" ) ] - -relativeUriTest06 = relativeUriTest "06" - "//example.org/aaa/bbb" - [ ( URI "" "//example.org" ["/","aaa/","bbb"] "" "", "" ) ] - -relativeUriTest07 = relativeUriTest "07" - "/aaa/bbb" - [ ( URI "" "" ["/","aaa/","bbb"] "" "", "" ) ] - -relativeUriTest08 = relativeUriTest "08" - "bbb" - [ ( URI "" "" ["bbb"] "" "", "" ) ] - -relativeUriTest09 = relativeUriTest "09" - "#ccc" - [] - -relativeUriTest10 = relativeUriTest "10" - "#" - [] - -relativeUriTest11 = relativeUriTest "11" - "/" - [ ( URI "" "" ["/",""] "" "", "" ) ] - -relativeUriTest12 = relativeUriTest "12" - "/aaa/" - [ ( URI "" "" ["/","aaa/",""] "" "", "" ) ] - -relativeUriTest13 = relativeUriTest "13" - "/aaa/?bbb" - [ ( URI "" "" ["/","aaa/",""] "?bbb" "", "" ) ] - -relativeUriTest14 = relativeUriTest "14" - "?y" - [ ( URI "" "" [] "?y" "", "" ) ] - -relativeUriTest15 = relativeUriTest "15" - "g?y" - [ ( URI "" "" ["g"] "?y" "", "" ) ] - -relativeUriTest16 = relativeUriTest "16" - "g;x?y#s" - [] - - -relativeUriTests = TestList - [ relativeUriTest01, relativeUriTest02, relativeUriTest03, - relativeUriTest04, relativeUriTest05, relativeUriTest06, - relativeUriTest07, relativeUriTest08, relativeUriTest09, - relativeUriTest10, relativeUriTest11, relativeUriTest12, - relativeUriTest13, relativeUriTest14, relativeUriTest15, - relativeUriTest16 ] - - --- uriReference :: Parser Char URI - -uriReferenceTest lab inp res = - testParser ("uriReferenceTest"++lab) uriReference inp res - -uriReferenceTest01 = uriReferenceTest "01" - "http://example.org/aaa/bbb#ccc" - [ ( URI "http:" "//example.org" ["/","aaa/","bbb"] "" "#ccc", "" ) ] - -uriReferenceTest02 = uriReferenceTest "02" - "mailto:local@domain.org" - [ ( URI "mailto:" "local@domain.org" [] "" "", "" ) ] - -uriReferenceTest03 = uriReferenceTest "03" - "mailto:local@domain.org#frag" - [ ( URI "mailto:" "local@domain.org" [] "" "#frag", "" ) ] - -uriReferenceTest04 = uriReferenceTest "04" - "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" - [ ( URI "HTTP:" "//EXAMPLE.ORG" ["/","AAA/","BBB"] "" "#CCC", "" ) ] - -uriReferenceTest05 = uriReferenceTest "05" - "http://example.org/aaa/bbb?qqq/rrr#ccc" - [ ( URI "http:" "//example.org" ["/","aaa/","bbb"] "?qqq/rrr" "#ccc", "" ) ] - -uriReferenceTest06 = uriReferenceTest "06" - "//example.org/aaa/bbb#ccc" - [ ( URI "" "//example.org" ["/","aaa/","bbb"] "" "#ccc", "" ) ] - -uriReferenceTest07 = uriReferenceTest "07" - "/aaa/bbb#ccc" - [ ( URI "" "" ["/","aaa/","bbb"] "" "#ccc", "" ) ] - -uriReferenceTest08 = uriReferenceTest "08" - "bbb#ccc" - [ ( URI "" "" ["bbb"] "" "#ccc", "" ) ] - -uriReferenceTest09 = uriReferenceTest "09" - "#ccc" - [ ( URI "" "" [] "" "#ccc", "" ) ] - -uriReferenceTest10 = uriReferenceTest "10" - "#" - [ ( URI "" "" [] "" "#", "" ) ] - -uriReferenceTest11 = uriReferenceTest "11" - "/" - [ ( URI "" "" ["/",""] "" "", "" ) ] - -uriReferenceTest12 = uriReferenceTest "12" - "/aaa/#fff/ggg" - [ ( URI "" "" ["/","aaa/",""] "" "#fff/ggg", "" ) ] - -uriReferenceTest13 = uriReferenceTest "13" - "/aaa/?bbb/ccc#fff/ggg" - [ ( URI "" "" ["/","aaa/",""] "?bbb/ccc" "#fff/ggg", "" ) ] - -uriReferenceTest14 = uriReferenceTest "14" - "?y" - [ ( URI "" "" [] "?y" "", "" ) ] - -uriReferenceTest15 = uriReferenceTest "15" - "g?y" - [ ( URI "" "" ["g"] "?y" "", "" ) ] - -uriReferenceTest16 = uriReferenceTest "16" - "g;x?y#s" - [ ( URI "" "" ["g;x"] "?y" "#s", "" ) ] - -uriReferenceTest17 = uriReferenceTest "17" - "http://example.123./aaa/bbb#ccc" - [ ] - -uriReferenceTest18 = uriReferenceTest "18" - "http://example.org:/aaa/bbb#ccc" - [ ( URI "http:" "//example.org:" ["/","aaa/","bbb"] "" "#ccc", "" ) ] - -uriReferenceTest19 = uriReferenceTest "19" - "http://example/Andrȷ" - [ ( URI "http:" "//example" ["/","Andr&"] "" "#567;", "" ) ] - -uriReferenceTest20 = uriReferenceTest "20" - "abc/def" - [ ( URI "" "" ["abc/", "def"] "" "", "" ) ] - -uriReferenceTest21 = uriReferenceTest "21" - "../abc#def" - [ ( URI "" "" ["../","abc"] "" "#def", "" ) ] - -uriReferenceTest22 = uriReferenceTest "22" - "file://meetings.example.com/cal#m1" - [ ( URI "file:" "//meetings.example.com" ["/","cal"] "" "#m1", "" ) ] - - -uriReferenceTests = TestList - [ uriReferenceTest01, uriReferenceTest02, uriReferenceTest03, - uriReferenceTest04, uriReferenceTest05, uriReferenceTest06, - uriReferenceTest07, uriReferenceTest08, uriReferenceTest09, - uriReferenceTest10, uriReferenceTest11, uriReferenceTest12, - uriReferenceTest13, uriReferenceTest14, uriReferenceTest15, - uriReferenceTest16, uriReferenceTest17, uriReferenceTest18, - uriReferenceTest19, uriReferenceTest20, uriReferenceTest21, - uriReferenceTest22 ] - --- Check for ambiguous parse: --- These tests don't force end-of-input, so potential ambiguous parses can be detected, - -uriAmbiguousTest lab inp res = - TestCase ( assertEqual ("uriAmbiguousTest"++lab++": "++inp) res (uriReference inp) ) - -uriAmbiguousTest01 = uriAmbiguousTest "01" - "http://example.org/aaa/bbb#ccc" - [ ( URI "http:" "//example.org" ["/","aaa/","bbb"] "" "#ccc", "" ) ] - -uriAmbiguousTest02 = uriAmbiguousTest "02" - "mailto:local@domain.org" - [ ( URI "mailto:" "local@domain.org" [] "" "", "" ) ] - -uriAmbiguousTest03 = uriAmbiguousTest "03" - "mailto:local@domain.org#frag" - [ ( URI "mailto:" "local@domain.org" [] "" "#frag", "" ) ] - -uriAmbiguousTest04 = uriAmbiguousTest "04" - "file://meetings.example.com/cal#m1" - [ ( URI "file:" "//meetings.example.com" ["/","cal"] "" "#m1", "" ) ] - - -uriAmbiguousTests = TestList - [ uriAmbiguousTest01, uriAmbiguousTest02, uriAmbiguousTest03, uriAmbiguousTest04 ] - - --- All tests - -allTests = TestList - [ hostnameTests, - ipv6Tests, - absoluteUriTests, - relativeUriTests, - uriReferenceTests, - uriAmbiguousTests - ] - -main = runTestTT allTests - -hn = hostnameTests -ipv6 = ipv6Tests -absu = absoluteUriTests -absu01 = absoluteUriTest01 -relu = relativeUriTests -uref = uriReferenceTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT -tp p s = runTestTT ( testParser "tp" p s [("<",">")] ) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ParseURITest.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ParseURITest.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.13 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.12 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.11 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.10 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.9 2003/03/05 22:16:23 graham --- URI code passes all unit tests --- --- Revision 1.8 2003/03/05 14:47:45 graham --- Relative URI code complete, not tested --- Fixed a URI parser bug --- --- Revision 1.7 2003/02/28 14:02:52 graham --- A few new test cases --- --- Revision 1.6 2003/02/27 23:33:54 graham --- QName splitting tested OK --- --- Revision 1.5 2003/02/27 20:29:53 graham --- Fixed some more parser bugs. --- All parser tests pass. --- QName and relative path handling to do. --- --- Revision 1.4 2003/02/27 18:48:05 graham --- Fix URI parser bug. --- Add more URI parser test cases. --- --- Revision 1.3 2003/02/27 15:28:45 graham --- Updated internal structure of parsed URI. --- Passes parser unit tests --- --- Revision 1.2 2003/02/27 13:54:30 graham --- ParseURI module passes unit test --- --- Revision 1.1 2003/02/20 19:45:07 graham --- Add URI module and unit tests. --- Code incomplete. --- diff --git a/Swish/HaskellUtils/PartOrderedCollection.hs b/Swish/HaskellUtils/PartOrderedCollection.hs deleted file mode 100644 --- a/Swish/HaskellUtils/PartOrderedCollection.hs +++ /dev/null @@ -1,392 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: PartOrderedCollection.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : PartOrderedCollection --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- 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 --- Tom Pledger --- who suggested key ideas on which some of the code in this module is based. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.PartOrderedCollection - ( PartCompare - , minima, maxima - , partCompareEq, partCompareOrd, partComparePair - , partCompareListPartOrd, partCompareListOrd - , partCompareMaybe, partCompareListMaybe - , partCompareListSubset - ) -where - -{- in Prelude???? -import Maybe - ( Maybe(..) ) --} - ------------------------------------------------------------- --- Type of partial compare function ------------------------------------------------------------- - -type PartCompare a = a -> a -> Maybe Ordering - ------------------------------------------------------------- --- Functions for minima and maxima of a part-ordered list ------------------------------------------------------------- - --- |This function finds the maxima in a list of partially --- ordered values, preserving the sequence of retained --- values from the supplied list. --- --- It returns all those values in the supplied list --- for which there is no larger element in the list. --- -maxima :: PartCompare a -> [a] -> [a] -maxima cmp as = foldl add [] as - where - add [] e = [e] - add ms@(m:mr) e = case cmp m e of - Nothing -> m:(add mr e) - Just GT -> ms - Just EQ -> ms - Just LT -> add mr e - --- |This function finds the minima in a list of partially --- ordered values, preserving the sequence of retained --- values from the supplied list. --- --- It returns all those values in the supplied list --- for which there is no smaller element in the list. --- -minima :: PartCompare a -> [a] -> [a] -minima cmp = maxima (flip cmp) - ------------------------------------------------------------- --- Partial ordering comparison functions ------------------------------------------------------------- - --- |Partial ordering for Eq values -partCompareEq :: (Eq a) => a -> a -> Maybe Ordering -partCompareEq a1 a2 = if a1 == a2 then Just EQ else Nothing - --- |Partial ordering for Ord values -partCompareOrd :: (Ord a) => a -> a -> Maybe Ordering -partCompareOrd a1 a2 = Just $ compare a1 a2 - --- |Part-ordering comparison on pairs of values, --- where each has a part-ordering relationship -partComparePair :: - (a->a->Maybe Ordering) -> (b->b->Maybe Ordering) -> (a,b) -> (a,b) - -> Maybe Ordering -partComparePair cmpa cmpb (a1,b1) (a2,b2) = case (cmpa a1 a2,cmpb b1 b2) of - (_,Nothing) -> Nothing - (jc1,Just EQ) -> jc1 - (Nothing,_) -> Nothing - (Just EQ,jc2) -> jc2 - (Just c1,Just c2) -> if c1 == c2 then Just c1 else Nothing - --- |Part-ordering comparison on lists of partially ordered values, where: --- --- as==bs if members of as are all equal to corresponding members of bs --- as<=bs if members of as are all less than or equal to corresponding --- members of bs --- as>=bs if members of as are all greater than or equal to corresponding --- members of bs --- otherwise as and bs are unrelated --- -partCompareListPartOrd :: PartCompare a -> [a] -> [a] -> Maybe Ordering -partCompareListPartOrd cmp as bs = pcomp as bs EQ - where - pcomp [] [] ordp = Just ordp - pcomp (a:as) (b:bs) ordp = case cmp a b of - Just rel -> pcomp1 as bs rel ordp - _ -> Nothing - pcomp1 as bs ordn EQ = pcomp as bs ordn - pcomp1 as bs EQ ordp = pcomp as bs ordp - pcomp1 as bs ordn ordp = - if ordn == ordp then pcomp as bs ordp else Nothing - --- |Part-ordering comparison on lists of Ord values, where: --- --- as==bs if members of as are all equal to corresponding members of bs --- as<=bs if members of as are all less than or equal to corresponding --- members of bs --- as>=bs if members of as are all greater than or equal to corresponding --- members of bs --- otherwise as and bs are unrelated --- -partCompareListOrd :: (Ord a) => [a] -> [a] -> Maybe Ordering -partCompareListOrd = partCompareListPartOrd (Just `c2` compare) - where c2 = (.) . (.) - --- |Part-ordering comparison for Maybe values. -partCompareMaybe :: (Eq a) => Maybe a -> Maybe a -> Maybe Ordering -partCompareMaybe Nothing Nothing = Just EQ -partCompareMaybe (Just _) Nothing = Just GT -partCompareMaybe Nothing (Just _) = Just LT -partCompareMaybe (Just a) (Just b) = if a == b then Just EQ else Nothing - --- |Part-ordering comparison on lists of Maybe values. -partCompareListMaybe :: (Eq a) => [Maybe a] -> [Maybe a] -> Maybe Ordering -partCompareListMaybe = partCompareListPartOrd partCompareMaybe - --- |Part-ordering comparison on lists based on subset relationship -partCompareListSubset :: (Eq a) => [a] -> [a] -> Maybe Ordering -partCompareListSubset a b - | aeqvb = Just EQ - | asubb = Just LT - | bsuba = Just GT - | otherwise = Nothing - where - asubb = a `subset` b - bsuba = b `subset` a - aeqvb = asubb && bsuba - a `subset` b = and [ ma `elem` b | ma <- a ] - ------------------------------------------------------------- --- 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, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/PartOrderedCollection.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: PartOrderedCollection.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.4 2003/11/20 18:35:59 graham --- Compacted maxima code by use of foldl --- (per further suggestion by Tom Pledger). --- --- Revision 1.3 2003/11/20 17:58:09 graham --- Class-constraint backward chaining: all test cases passed. --- --- Revision 1.2 2003/11/19 22:13:03 graham --- Some backward chaining tests passed --- --- Revision 1.1 2003/11/19 15:21:26 graham --- Add PartOrderedCollection module --- diff --git a/Swish/HaskellUtils/ProcessURI.hs b/Swish/HaskellUtils/ProcessURI.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ProcessURI.hs +++ /dev/null @@ -1,342 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ProcessURI.hs,v 1.1 2004/01/22 19:52:27 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ProcessURI --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines a collection of functions for manipulating URIs. --- --- Functions provided deal with: --- Validating and parsing URI syntax --- Separating a fragment from a URI --- Separating URI into QName and local name --- Relative URI computations --- --- The primary reference for URI handling is RFC2396 [1], --- as updated by RFC 2732 [2]. --- RFC 1808 [3] contains a number of test cases for relative URI handling. --- Dan Connolly's Python module 'uripath.py' [4] also contains useful details --- and test cases. --- --- [1] http://www.ietf.org/rfc/rfc2396.txt --- [2] http://www.ietf.org/rfc/rfc2732.txt --- [3] http://www.ietf.org/rfc/rfc1808.txt --- [4] http://www.w3.org/2000/10/swap/uripath.py --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.ProcessURI - ( URI(URI) - , isValidURIRef, isAbsoluteURIRef, isAbsoluteURI - , parseURIRef, parseAbsoluteURIRef, parseAbsoluteURI - , getURIRef, normalizeURI, compareURI, normSeg, normSeg1, mergeSeg - , splitURIFragment, makeURIWithFragment -- , splitQName - , relativeRefPart, absoluteUriPart - ) -where - -import Swish.HaskellUtils.ParseURI -import Swish.HaskellUtils.Parse --- type Parser a b = Parse.Parser a b --- isValid = Parse.isValid --- parseApply = Parse.parseApply - - --- Test supplied string for valid URI syntax -isValidURIRef :: String -> Bool -isValidURIRef = isValid parseURIRef - --- Test supplied string for valid absolute URI reference syntax -isAbsoluteURIRef :: String -> Bool -isAbsoluteURIRef = isValid parseAbsoluteURIRef - --- Test supplied string for valid absolute URI syntax -isAbsoluteURI :: String -> Bool -isAbsoluteURI = isValid parseAbsoluteURI - --- URI parser (see Parse and ParseURI modules) -parseURIRef :: Parser Char String -parseURIRef = uriReference `parseApply` uriToString - --- Absolute URI reference parser (see Parse module) -parseAbsoluteURIRef :: Parser Char String -parseAbsoluteURIRef = absoluteUriReference `parseApply` uriToString - --- Absolute URI parser (see Parse module) -parseAbsoluteURI :: Parser Char String -parseAbsoluteURI = absoluteUri `parseApply` uriToString - --- Parse and return URI reference as URI value -getURIRef :: String -> URI -getURIRef s = extractURIRef (uriReference s) - where - extractURIRef [(u,"")] = u - extractURIRef [(_,_)] = ( URI "" "" [""] "" "" ) - extractURIRef _ = ( URI "" "" [""] "" "" ) - --- Normalize URI string -normalizeURI :: String -> String -normalizeURI str = uriToString (URI sc au (normSeg se) qu fr) - where - URI sc au se qu fr = getURIRef str - --- Compare two URIs --- Takes account of normalizations that can be applied to all URIs --- (2003-02-20, currently subject to W3C TAG debate) -compareURI :: String -> String -> Bool -compareURI u1 u2 = ( u1 == u2 ) - --- Separate URI-with-fragment into URI and fragment ID -splitURIFragment :: String -> ( String, Maybe String ) - -- splitURIFragment "http://example.org/aaa#bbb" = - -- ("http://example.org/aaa",Just "bbb") - -- splitURIFragment "http://example.org/aaa" = - -- ("http://example.org/aaa",Nothing) -splitURIFragment inp = - case (uriReference inp) of - [(URI s a p q f,"")] -> (uriToString (URI s a p q ""),pickFrag f) - _ -> error ("splitURIFragment, Invalid URI: "++inp) - where - pickFrag ('#':f) = Just f - pickFrag _ = Nothing - --- Construct URI-with-fragment using URI and supplied fragment id -makeURIWithFragment :: String -> Maybe String -> String - -- makeURIWithFragment "http://example.org/aaa" (Just "fff") = - -- "http://example.org/aaa#fff" - -- makeURIWithFragment "http://example.org/aaa#bbb" (Just "fff") = - -- "http://example.org/aaa#fff" - -- makeURIWithFragment "http://example.org/aaa" Nothing - -- "http://example.org/aaa" - -- makeURIWithFragment "http://example.org/aaa#bbb" Nothing - -- "http://example.org/aaa" -makeURIWithFragment base frag = - case frag of - Just f -> b ++ "#" ++ f - Nothing -> b - where - (b,_) = splitURIFragment base - --- Separate URI into QName URI and local name -splitQName :: String -> ( String, String ) - -- 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/","") -splitQName qn = splitAt (scanQName qn (-1) 0) qn - --- helper function for splitQName --- Takes 3 arguments: --- QName to scan --- index of last name-start char, or (-1) --- number of characters scanned so far --- Returns index of start of name, or length of list --- -scanQName :: String -> Int -> Int -> Int -scanQName (nextch:more) (-1) nc - | isNameStartChar nextch = scanQName more nc (nc+1) - | otherwise = scanQName more (-1) (nc+1) -scanQName (nextch:more) ns nc - | not (isNameChar nextch) = scanQName more (-1) (nc+1) - | otherwise = scanQName more ns (nc+1) -scanQName "" (-1) nc = nc -scanQName "" ns _ = ns - --- Definitions here per XML namespaces, NCName production, --- restricted to characters used in URIs. --- cf. http://www.w3.org/TR/REC-xml-names/ -isNameStartChar c = ( isAlpha c ) || ( c == '_' ) -isNameChar c = ( isAlpha c ) || ( isDigit c ) || ( any (==c) ".-_" ) - --- Get reference relative to given base -relativeRefPart :: String -> String -> String - -- relativeRefPart "base:" "base:relativeRef" = "relativeRef" - -- relativeRefPart "base:" "another:URI" = "another:URI" -relativeRefPart base full = - uriToString ( relPartRef ( getURIRef base ) ( getURIRef full ) ) - where - relPartRef u1@(URI sc1 au1 se1 _ _) u2@( URI sc2 au2 se2 qu2 fr2 ) - | sc1 /= sc2 = URI sc2 au2 (normSeg se2) qu2 fr2 -- different schemes - | opaque au1 = URI "" au2 (normSeg se2) qu2 fr2 -- same scheme, base is opaque - | au1 /= au2 = URI "" au2 (normSeg se2) qu2 fr2 -- same scheme, different authority - | otherwise = URI "" "" (relPath (normSeg se1) (normSeg se2) ) qu2 fr2 - -- If paths share a leading segment (other than "/") then compute a path relative - -- to the base URI, otherwise return a root-relative path - relPath s1 [] = ["/"] - relPath [] s2 = s2 - relPath ("/":s1h:s1t) s2@("/":s2h:s2t) - | s1h == s2h = relPartSeg s1t s2t - | otherwise = s2 - relPath (s1h:s1t) s2@(s2h:s2t) - | s1h == s2h = relPartSeg s1t s2t - | otherwise = s2 - {- relPath s1@(_:_) s2@(_:_) = relPartSeg s1 s2 [[[REDUNDANT?]]] -} - -- Path-segment relative to base: - -- (An alternative would be descendent relative to base, otherwise relative to root) - -- relPartSeg a/b a/c -> c (case 1: common leading segments) - -- relPartSeg a/b a/ -> ./ (case 1a: identical paths with empty name) - -- relPartSeg a b/c -> b/c (case 2: all base path segments used) - -- relPartSeg b c -> c (case 2) - -- relPartSeg a c/ -> c/ (case 2) - -- relPartSeg "" c -> c (case 2) - -- relPartSeg a "" -> "" (case 2) - -- relPartSeg a c:d -> ./c:d (case 2a: bare name looks like URI - -- relPartSeg a/b c -> ../c (case 3: unused base path segments) - -- relPartSeg a/b "" -> ../ (case 3) - -- relPartSeg a/ c -> ../c (case 3) - -- relPartSeg a/ "" -> ../ (case 3) - -- NOTE the last element of the path segment lists are always the "name" component, - -- and is present as an empty string if the path ends with a '/' character - relPartSeg [_] [""] = ["./",""] -- Case 1a - relPartSeg [_] [st] - | looksLikeURI st = ["./",st] -- Case 2a - | otherwise = [st] -- Case 2 - relPartSeg [_] s2 = s2 -- Case 2 - relPartSeg s1 [s2t] = difPartSeg s1 [s2t] -- Case 3 (this test should be redundant) - relPartSeg s1@(s1h:s1t) s2@(s2h:s2t) - | s1h == s2h = relPartSeg s1t s2t -- Case 1 - | otherwise = difPartSeg s1 s2 -- Case 2 or 3 ... - difPartSeg [_] s2 = s2 -- Case 2 (final base segment is ignored) - difPartSeg (_:s1t) s2 = "../":(difPartSeg s1t s2) -- Case 3 - --- Get absolute URI given base and relative reference --- NOTE: absoluteURI base (relativeRef base u) is always equivalent to u. --- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html -absoluteUriPart :: String -> String -> String - -- absoluteUriPart "base:" "relativeRef" = "base:relativeRef" - -- absoluteUriPart "base:" "another:URI" = "another:URI" -absoluteUriPart base rel = - uriToString ( joinRef ( getURIRef base ) ( getURIRef rel ) ) - where - joinRef u1@(URI sc1 au1 se1 _ _) u2@( URI sc2 au2 se2 qu2 fr2 ) - -- non-validating case here? (See RFC2396bis section 5.2) - | sc2 /= "" = u2 - | opaque au1 = URI sc1 au2 se2 qu2 fr2 -- Base not relative - | au2 /= "" = URI sc1 au2 se2 qu2 fr2 - | se2 == [] = if qu2 == "" then URI "" "" [] "" fr2 -- Same document - else URI sc1 au1 se1 qu2 fr2 -- Base document - | otherwise = URI sc1 au1 ( mergeSeg se1 se2 ) qu2 fr2 - --- Test authority string for opaque form (non-null and not starting with '/') -opaque :: String -> Bool -opaque "" = False -opaque ('/':_) = False -opaque _ = True - --- Merge segment se2 with base segment se1 -mergeSeg :: [String] -> [String] -> [String] -mergeSeg _ s2@("/":se2) = normSeg s2 -mergeSeg [] se2 = normSeg ("/":se2) -mergeSeg se1 se2 = normSeg ( (init se1) ++ se2 ) - --- Normalize ./ and ../ in segment list: --- Don't touch leading "/" --- Don't allow "../" to cancel another "../" --- Leave bare "./" --- Remove any trailing "./" -normSeg :: [String] -> [String] -normSeg ("/":st) = "/":(normSeg1 st) -normSeg st = normSeg1 st - -normSeg1 [] = [] -normSeg1 ["./"] = ["./"] -normSeg1 ["."] = ["./",""] -- trailing '.' is treated as './' -normSeg1 [".."] = ["../",""] -- trailing '..' is treated as '../' -normSeg1 p@["./",st] - | looksLikeURI st = p - | otherwise = [st] -normSeg1 ("./":st) = normSeg1 st -normSeg1 (s1:st) = normSeg2 (s1:(normSeg1 st)) -- TEST CASE: a/b/../../c - -normSeg2 :: [String] -> [String] -normSeg2 s@("../":"../":st) = s -normSeg2 ["./","../"] = ["./"] -normSeg2 (_:"../":st) = st -normSeg2 [sh,"./"] = [sh] -normSeg2 (sh:"./":st) = sh:st -normSeg2 ("./":st) = st -normSeg2 st = st - --- Test if string looks like a URI, by virtue of starting with a 'name:' -looksLikeURI :: String -> Bool -looksLikeURI name = not ( null ( relSegmentWithColon name ) ) - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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. --- --- Foobar 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ProcessURI.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ProcessURI.hs,v $ --- Revision 1.1 2004/01/22 19:52:27 graham --- Rename module URI to avoid awkward clash with Haskell libraries --- --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.12 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.11 2003/09/24 13:35:44 graham --- QName splitting moved from URI module to QName module --- --- Revision 1.10 2003/06/03 19:24:13 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.9 2003/05/28 19:57:50 graham --- Adjusting code to compile with GHC --- --- Revision 1.8 2003/03/05 22:16:23 graham --- URI code passes all unit tests --- --- Revision 1.7 2003/03/05 14:47:45 graham --- Relative URI code complete, not tested --- Fixed a URI parser bug --- --- Revision 1.6 2003/02/28 14:02:52 graham --- A few new test cases --- --- Revision 1.5 2003/02/27 23:33:54 graham --- QName splitting tested OK --- --- Revision 1.4 2003/02/27 18:48:05 graham --- Fix URI parser bug. --- Add more URI parser test cases. --- --- Revision 1.3 2003/02/27 08:59:53 graham --- Separate URI parser from main URI module --- --- Revision 1.2 2003/02/27 00:30:14 graham --- Syntax code nearly complete, untested --- --- Revision 1.1 2003/02/20 19:45:07 graham --- Add URI module and unit tests. --- Code incomplete. --- diff --git a/Swish/HaskellUtils/QName.hs b/Swish/HaskellUtils/QName.hs deleted file mode 100644 --- a/Swish/HaskellUtils/QName.hs +++ /dev/null @@ -1,177 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: QName.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : QName --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines an algebraic datatype for qualified names (QNames). --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.QName - ( QName(..) -- , maybeQnEq - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) -where - -import Data.Char - ( isAlpha, isAlphaNum ) - ------------------------------------------------------------- --- Qualified name ------------------------------------------------------------- --- --- cf. http://www.w3.org/TR/REC-xml-names/ - -data QName = QName { qnNsuri, qnLocal :: String } - -newQName :: String -> String -> QName -newQName ns ln = QName ns ln - -qnameFromPair :: (String,String) -> QName -qnameFromPair (ns,ln) = QName ns ln - -qnameFromURI :: String -> QName -qnameFromURI = qnameFromPair . splitURI - -getNamespace :: QName -> String -getNamespace qn = qnNsuri qn - -getLocalName :: QName -> String -getLocalName qn = qnLocal qn - -getQNameURI :: QName -> String -getQNameURI (QName ns ln) = ns++ln - -instance Eq QName where - (==) = qnEq - -instance Ord QName where - (QName u1 l1) <= (QName u2 l2) = - if ( up1 /= up2) then (up1 <= up2) else ((ur1++l1) <= (ur2++l2)) - where - n = min (length u1) (length u2) - (up1,ur1) = splitAt n u1 - (up2,ur2) = splitAt n u2 - -instance Show QName where - show (QName ns ln) = "<" ++ ns ++ ln ++ ">" - --- Original used comparison of concatenated strings, --- but that was very inefficient. This version does the --- comparison without constructing new values -qnEq :: QName -> QName -> Bool -qnEq (QName ns1 ln1) (QName ns2 ln2) = qnEq1 ns1 ns2 ln1 ln2 - -qnEq1 (c1:ns1) (c2:ns2) ln1 ln2 = (c1==c2) && (qnEq1 ns1 ns2 ln1 ln2) -qnEq1 [] ns2 ln1@(_:_) ln2 = qnEq1 ln1 ns2 [] ln2 -qnEq1 ns1 [] ln1 ln2@(_:_) = qnEq1 ns1 ln2 ln1 [] -qnEq1 [] [] [] [] = True -qnEq1 _ _ _ _ = False - -{- --- Define equality of (Maybe QName) -maybeQnEq :: (Maybe QName) -> (Maybe QName) -> Bool -maybeQnEq Nothing Nothing = True -maybeQnEq (Just q1) (Just q2) = q1 == q2 -maybeQnEq _ _ = False --} - --- Separate URI string into namespace URI and local name -splitURI :: String -> ( String, String ) - -- 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/","") -splitURI qn = splitAt (scanURI qn (-1) 0) qn - --- helper function for splitQName --- Takes 3 arguments: --- QName to scan --- index of last name-start char, or (-1) --- number of characters scanned so far --- Returns index of start of name, or length of list --- -scanURI :: String -> Int -> Int -> Int -scanURI (nextch:more) (-1) nc - | isNameStartChar nextch = scanURI more nc (nc+1) - | otherwise = scanURI more (-1) (nc+1) -scanURI (nextch:more) ns nc - | not (isNameChar nextch) = scanURI more (-1) (nc+1) - | otherwise = scanURI more ns (nc+1) -scanURI "" (-1) nc = nc -scanURI "" ns _ = ns - - - --- Definitions here per XML namespaces, NCName production, --- restricted to characters used in URIs. --- cf. http://www.w3.org/TR/REC-xml-names/ - -isNameStartChar :: Char -> Bool -isNameStartChar c = ( isAlpha c ) || ( c == '_' ) - -isNameChar :: Char -> Bool -isNameChar c = ( isAlphaNum c ) || ( any (==c) ".-_" ) - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/QName.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: QName.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.5 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.4 2003/10/24 21:05:09 graham --- Working on datatype inference. Most of the variable binding logic --- is done, but the rule structure still needs to be worked out to support --- forward and backward chaining through the same rule. --- --- Revision 1.3 2003/09/30 20:02:40 graham --- Proof mechanisms now use scoped names and rulesets. --- Move some functionality between modules so that RDFProofCheck --- contains less generic code. --- --- Revision 1.2 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.1 2003/09/24 12:51:00 graham --- Add separate QName module and test suite --- diff --git a/Swish/HaskellUtils/QNameTest.hs b/Swish/HaskellUtils/QNameTest.hs deleted file mode 100644 --- a/Swish/HaskellUtils/QNameTest.hs +++ /dev/null @@ -1,399 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: QNameTest.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : QNameTest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines test cases for QName data --- --------------------------------------------------------------------------------- - --- WNH module Swish.HaskellUtils.QNameTest where - --- module Main where - -import System.IO - ( Handle, IOMode(WriteMode) - , openFile, hClose, hPutStr, hPutStrLn - ) - -import Data.Maybe - ( fromJust ) - -import Test.HUnit - ( Test(TestCase,TestList,TestLabel) - , assertBool, assertEqual, assertString - , runTestTT, runTestText, putTextToHandle - ) - -import Swish.HaskellUtils.QName - ( QName(..) - , newQName, qnameFromPair, qnameFromURI - , getNamespace, getLocalName, getQNameURI - , splitURI - ) - - - - ------------------------------------------------------------- --- Define some common values ------------------------------------------------------------- - -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" -base5 = "http://id.ninebynine.org/wip/2003/test/graph5/" - -qb1s1 = QName base1 "s1" -qb2s2 = QName base2 "s2" -qb3s3 = QName base3 "s3" -qb3 = QName base3 "" -qb3bm = QName base3 "basemore" -qb4m = QName base4 "more" - -qb5 = QName base5 "" -qb5s5 = QName base5 "s5" - -qb1st1 = QName base1 "st1" -qb2st2 = QName base2 "st2" -qb3st3 = QName base3 "st3" - - ------------------------------------------------------------- --- QName equality tests ------------------------------------------------------------- - -testQNameEq :: String -> Bool -> QName -> QName -> Test -testQNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testQNameEq:"++lab) eq (n1==n2) ) - -qnlist = - [ ("qb1s1", qb1s1) - , ("qb2s2", qb2s2) - , ("qb3s3", qb3s3) - , ("qb3", qb3) - , ("qb3bm", qb3bm) - , ("qb4m", qb4m) - , ("qb5", qb5) - , ("qb5s5", qb5s5) - , ("qb1st1",qb1st1) - , ("qb2st2",qb2st2) - , ("qb3st3",qb3st3) - ] - -qneqlist = - [ ("qb3bm","qb4m") - ] - -testQNameEqSuite = TestList - [ testQNameEq (testLab l1 l2) (testEq l1 l2) n1 n2 - | (l1,n1) <- qnlist , (l2,n2) <- qnlist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - testEq l1 l2 = (l1 == l2) || - (l1,l2) `elem` qneqlist || - (l2,l1) `elem` qneqlist - ------------------------------------------------------------- --- Alternative constructors ------------------------------------------------------------- - -nq1 = newQName base1 "s1" -nq2 = newQName base1 "s2" - -testnq01 = testQNameEq "testnq01" True nq1 qb1s1 -testnq02 = testQNameEq "testnq02" False nq2 qb1s1 - -qp1 = qnameFromPair (base1,"s1") -qp2 = qnameFromPair (base1,"s2") - -testqp01 = testQNameEq "testqp01" True qp1 qb1s1 -testqp02 = testQNameEq "testqp02" False qp2 qb1s1 - -qu1 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" -qu2 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" -qu3 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph3/node" -qu4 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph5/" -qu5 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph5/s5" - -testqu01 = testQNameEq "testqu01" True qb1s1 qu1 -testqu02 = testQNameEq "testqu02" True qb2s2 qu2 -testqu03 = testQNameEq "testqu03" True qb3 qu3 -testqu04 = testQNameEq "testqu04" True qb5 qu4 -testqu05 = testQNameEq "testqu05" True qb5s5 qu5 - -testMakeQNameSuite = TestList - [ testnq01, testnq02 - , testqp01, testqp02 - , testqu01, testqu02, testqu03, testqu04, testqu05 - ] - - ------------------------------------------------------------- --- Extract components ------------------------------------------------------------- - -testStringEq :: String -> String -> String -> Test -testStringEq lab s1 s2 = - TestCase ( assertEqual ("testStringEq:"++lab) s1 s2 ) - -testGetNamespace01 = testStringEq "testGetNamespace01" - "http://id.ninebynine.org/wip/2003/test/graph1/node#" - (getNamespace qb1s1) - -testGetNamespace02 = testStringEq "testGetNamespace02" - "http://id.ninebynine.org/wip/2003/test/graph2/node/" - (getNamespace qb2s2) - -testGetNamespace03 = testStringEq "testGetNamespace03" - "http://id.ninebynine.org/wip/2003/test/graph3/node" - (getNamespace qb3s3) - -testGetNamespace04 = testStringEq "testGetNamespace04" - "http://id.ninebynine.org/wip/2003/test/graph3/node" - (getNamespace qb3) - -testGetLocalName01 = testStringEq "testGetLocalName01" - "s1" - (getLocalName qb1s1) - -testGetLocalName02 = testStringEq "testGetLocalName02" - "s2" - (getLocalName qb2s2) - -testGetLocalName03 = testStringEq "testGetLocalName03" - "s3" - (getLocalName qb3s3) - -testGetLocalName04 = testStringEq "testGetLocalName04" - "" - (getLocalName qb3) - -testGetQNameURI01 = testStringEq "testGetQNameURI01" - "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" - (getQNameURI qb1s1) - -testGetQNameURI02 = testStringEq "testGetQNameURI02" - "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" - (getQNameURI qb2s2) - -testGetQNameURI03 = testStringEq "testGetQNameURI03" - "http://id.ninebynine.org/wip/2003/test/graph3/nodes3" - (getQNameURI qb3s3) - -testGetQNameURI04 = testStringEq "testGetQNameURI04" - "http://id.ninebynine.org/wip/2003/test/graph3/node" - (getQNameURI qb3) - - -testPartQNameSuite = TestList - [ testGetNamespace01, testGetNamespace02, testGetNamespace03 - , testGetNamespace04 - , testGetLocalName01, testGetLocalName02, testGetLocalName03 - , testGetLocalName04 - , testGetQNameURI01, testGetQNameURI02, testGetQNameURI03 - , testGetQNameURI04 - ] - ------------------------------------------------------------- --- Maybe Qname comparison ------------------------------------------------------------- - -testMaybeQNameEq :: String -> Bool -> (Maybe QName) -> (Maybe QName) -> Test -testMaybeQNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testMaybeQNameEq:"++lab) eq (n1==n2) ) - -testMaybeQNameEq01 = testMaybeQNameEq "testMaybeQNameEq01" True - (Just qb1s1) (Just qb1s1) -testMaybeQNameEq02 = testMaybeQNameEq "testMaybeQNameEq02" False - (Just qb1s1) (Just qb2s2) -testMaybeQNameEq03 = testMaybeQNameEq "testMaybeQNameEq03" False - (Just qb1s1) Nothing -testMaybeQNameEq04 = testMaybeQNameEq "testMaybeQNameEq04" False - Nothing (Just qb1s1) -testMaybeQNameEq05 = testMaybeQNameEq "testMaybeQNameEq05" True - Nothing Nothing - -testMaybeQNameEqSuite = TestList - [ testMaybeQNameEq01 - , testMaybeQNameEq02 - , testMaybeQNameEq03 - , testMaybeQNameEq04 - , testMaybeQNameEq05 - ] - ------------------------------------------------------------- --- QName ordering ------------------------------------------------------------- - -testQNameLe :: String -> Bool -> QName -> QName -> Test -testQNameLe lab le n1 n2 = - TestCase ( assertEqual ("testQNameLe:"++lab) le (n1<=n2) ) - -testQNameLe01 = testQNameLe "testQNameLe01" True qb3bm qb4m -testQNameLe02 = testQNameLe "testQNameLe02" True qb4m qb3bm -testQNameLe03 = testQNameLe "testQNameLe03" True qb1s1 qb2s2 -testQNameLe04 = testQNameLe "testQNameLe04" False qb2s2 qb1s1 - -testQNameLeSuite = TestList - [ testQNameLe01 - , testQNameLe02 - , testQNameLe03 - , testQNameLe04 - ] - ------------------------------------------------------------- --- Show QName ------------------------------------------------------------- - -testShowQName01 = testStringEq "testShowQName01" - "" - (show qb1s1) - -testShowQName02 = testStringEq "testShowQName02" - "" - (show qb2s2) - -testShowQName03 = testStringEq "testShowQName03" - "" - (show qb3) - -testShowQName04 = testStringEq "testShowQName04" - "" - (show qb5) - -testShowQNameSuite = TestList - [ testShowQName01 - , testShowQName02 - , testShowQName03 - , testShowQName04 - ] - - ------------------------------------------------------------- --- 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 ( main, local ) = - TestCase ( assertEqual label ( main, local ) ( splitURI input ) ) - -testSplitURI01 = testSplitURI "testSplitURI01" - "http://example.org/aaa#bbb" - ( "http://example.org/aaa#", "bbb" ) -testSplitURI02 = testSplitURI "testSplitURI02" - "http://example.org/aaa/bbb" - ( "http://example.org/aaa/", "bbb" ) -testSplitURI03 = testSplitURI "testSplitURI03" - "http://example.org/aaa#" - ( "http://example.org/aaa#", "" ) -testSplitURI04 = testSplitURI "testSplitURI04" - "http://example.org/aaa/" - ( "http://example.org/aaa/", "" ) -testSplitURI05 = testSplitURI "testSplitURI05" - "//example.org/aaa#bbb" - ( "//example.org/aaa#", "bbb" ) -testSplitURI06 = testSplitURI "testSplitURI06" - "aaa/bbb" - ( "aaa/", "bbb" ) -testSplitURI07 = 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? -testSplitURI08 = testSplitURI "testSplitURI08" - "mortal" - ( "", "mortal" ) - -testSplitURISuite = TestList - [ - testSplitURI01, testSplitURI02, testSplitURI03, testSplitURI04, - testSplitURI05, testSplitURI06, testSplitURI07, testSplitURI08 - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests = TestList - [ testQNameEqSuite - , testMakeQNameSuite - , testPartQNameSuite - , testMaybeQNameEqSuite - , testQNameLeSuite - , testShowQNameSuite - , testSplitURISuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/QNameTest.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: QNameTest.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.5 2004/01/07 19:49:13 graham --- Reorganized RDFLabel details to eliminate separate language field, --- and to use ScopedName rather than QName. --- Removed some duplicated functions from module Namespace. --- --- Revision 1.4 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.3 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.2 2003/09/24 13:36:42 graham --- QName handling separated from RDFGraph module, and --- QName splitting moved from URI module to QName module. --- --- Revision 1.1 2003/09/24 12:51:00 graham --- Add separate QName module and test suite --- diff --git a/Swish/HaskellUtils/ShowM.hs b/Swish/HaskellUtils/ShowM.hs deleted file mode 100644 --- a/Swish/HaskellUtils/ShowM.hs +++ /dev/null @@ -1,95 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: ShowM.hs,v 1.1 2004/02/11 16:31:01 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : ShowM --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module defines an extension of the Show class for displaying --- multi-line values. It serves the following purposes: --- (1) provides a method with greater layout control of multiline values, --- (2) provides a possibility to override the default Show behaviour --- for programs that use the extended ShowM interface, and --- (3) uses a ShowS intermediate value to avoid unnecessary --- concatenation of long strings. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.ShowM - ( ShowM(..), showm - ) -where - ------------------------------------------------------------- --- ShowM framework ------------------------------------------------------------- - --- |ShowM is a type class for values that may be formatted in --- multi-line displays. -class (Show sh) => ShowM sh where - -- |Multi-line value display method - -- Create a multiline displayable form of a value, returned - -- as a ShowS value. The default implementation behaves just - -- like a normal instance of Show. - -- - -- This function is intended to allow the calling function some control - -- of multiline displays by providing: - -- (1) the first line of the value is not preceded by any text, so - -- it may be appended to some preceding text on the same line, - -- (2) the supplied line break string is used to separate lines of the - -- formatted text, and may include any desired indentation, and - -- (3) no newline is output following the final line of text. - showms :: String -> sh -> ShowS - showms linebreak val = shows val - --- |showm --- Return a string representation of a ShowM value. -showm :: (ShowM sh) => String -> sh -> String -showm linebreak val = showms linebreak val "" - - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/ShowM.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: ShowM.hs,v $ --- Revision 1.1 2004/02/11 16:31:01 graham --- Move ShowM to HaskellUtils directory. --- --- Revision 1.2 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.1 2003/06/25 21:20:12 graham --- Add ShowM class and RDF graph instance to CVS. --- This is part of reworking N3 formatting logic to support proof display, --- and other multiline display requirements. --- diff --git a/Swish/HaskellUtils/TestHelpers.hs b/Swish/HaskellUtils/TestHelpers.hs deleted file mode 100644 --- a/Swish/HaskellUtils/TestHelpers.hs +++ /dev/null @@ -1,223 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: TestHelpers.hs,v 1.2 2004/01/13 12:18:34 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : TestHelpers --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module contains test case helper functions, providing a range of --- commonly-used test cases. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.TestHelpers - ( test, testEq, testLe, testGe, testElem - , testJust, testNothing - , testEqv, testEqv2, testHasEqv, testMaybeEqv - ) -where - -import Swish.HaskellUtils.ListHelpers - ( equiv ) - -import Test.HUnit - ( Test(TestCase,TestList) - , Assertion - , assertBool, assertEqual, assertFailure - , runTestTT - ) - -import Control.Monad - ( unless ) - -import Data.Maybe - ( isJust ) - - ------------------------------------------------------------- --- Test case helpers ------------------------------------------------------------- - -assertMember :: (Eq a, Show a) => String -> a -> [a] -> Assertion -assertMember preface item list = - unless (item `elem` list) (assertFailure msg) - where msg = (if null preface then "" else preface ++ "\n") ++ - "expected: " ++ show item ++ "\nin list: " ++ show list - -test :: String -> Bool -> Test -test lab bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - -testLe :: (Ord a, Show a) => String -> a -> a -> Test -testLe lab a1 a2 = - TestCase ( assertBool ("testLe:"++lab++vals) (a1<=a2) ) - where - vals = ", fail: "++show a1++" <= "++show a2 - -testGe :: (Ord a, Show a) => String -> a -> a -> Test -testGe lab a1 a2 = - TestCase ( assertBool ("testGe:"++lab++vals) (a1>=a2) ) - where - vals = ", fail: "++show a1++" >= "++show a2 - --- Test for Just x or Nothing - -testJust :: String -> Maybe a -> Test -testJust lab av = - TestCase ( assertBool ("testJust:"++lab) (isJust av) ) - -testNothing :: String -> Maybe a -> Test -testNothing lab av = - TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) - --- 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: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - -testEqv2 :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqv2 lab a1 a2 = - TestCase ( assertEqual ("testEqv2:"++lab) ma1 ma2 ) - where - ma1 = ListTest $ map ListTest a1 - ma2 = ListTest $ map ListTest a2 - -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test -testHasEqv lab a1 a2 = - TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest a1 - ma2 = map ListTest a2 - -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv lab a1 a2 = - TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) - where - ma1 = (MaybeListTest a1) - ma2 = (MaybeListTest a2) - ------------------------------------------------------------- --- 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") - ] - - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allSuccessTests = TestList - [ testSuccessSuite - ] - -allFailureTests = TestList - [ testFailureSuite - ] - -mainS = runTestTT allSuccessTests -mainF = runTestTT allFailureTests - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/TestHelpers.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: TestHelpers.hs,v $ --- Revision 1.2 2004/01/13 12:18:34 graham --- Clean up test case helpers module. --- --- Revision 1.1.1.1 2004/01/13 12:15:56 graham --- Fix up name of HaskellUtils project diff --git a/Swish/HaskellUtils/TraceHelpers.hs b/Swish/HaskellUtils/TraceHelpers.hs deleted file mode 100644 --- a/Swish/HaskellUtils/TraceHelpers.hs +++ /dev/null @@ -1,71 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: TraceHelpers.hs,v 1.1 2004/01/13 12:31:24 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : TraceHelpers --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 --- --- This module provides access to tracing functions from the pre-2003 --- Hugs trace module. Over time, it may accumulate other tracing --- functions that I find useful. --- --------------------------------------------------------------------------------- - -module Swish.HaskellUtils.TraceHelpers - ( trace, traceShow - ) -where - -import Debug.Trace - ( trace ) - ------------------------------------------------------------- --- traceShow function from older Hugs trace module ------------------------------------------------------------- - -traceShow :: Show a => String -> a -> a -traceShow msg x = trace (msg ++ show x) x - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/TraceHelpers.hs,v $ --- $Author: graham $ --- $Revision: 1.1 $ --- $Log: TraceHelpers.hs,v $ --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.1 2003/12/20 12:02:08 graham --- Introduced new TraceHelpers module for Hugs-2003 compatibility. --- --- Revision 1.3 2003/12/18 18:29:03 graham --- ?????? --- diff --git a/Swish/HaskellUtils/URITest.hs b/Swish/HaskellUtils/URITest.hs deleted file mode 100644 --- a/Swish/HaskellUtils/URITest.hs +++ /dev/null @@ -1,1092 +0,0 @@ --------------------------------------------------------------------------------- --- $Id: URITest.hs,v 1.2 2004/01/22 19:52:27 graham Exp $ --- --- Copyright (c) 2003, G. KLYNE. All rights reserved. --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : URITest --- Copyright : (c) 2003, Graham Klyne --- License : GPL V2 --- --- Maintainer : Graham Klyne --- Stability : provisional --- Portability : H98 + multi-parameter classes --- --- This Module contains test cases for module URI. --- --------------------------------------------------------------------------------- - --- WNH RIP OUT module Swish.HaskellUtils.URITest where - -import Test.HUnit -import Swish.HaskellUtils.Parse -import Swish.HaskellUtils.ProcessURI -import System.IO ( Handle, openFile, IOMode(WriteMode), hClose, hPutStr, hPutStrLn ) - --- Test supplied string for valid URI reference syntax --- isValidURIRef :: String -> Bool --- Test supplied string for valid absolute URI reference syntax --- isAbsoluteURIRef :: String -> Bool --- Test supplied string for valid absolute URI syntax --- isAbsoluteURI :: String -> Bool - -data URIType = AbsId -- URI form (absolute, no fragment) - | AbsRf -- Absolute URI reference - | RelRf -- Relative URI reference - | InvRf -- Invalid URI reference -isValidT :: URIType -> Bool -isValidT InvRf = False -isValidT _ = True - -isAbsRfT :: URIType -> Bool -isAbsRfT AbsId = True -isAbsRfT AbsRf = True -isAbsRfT _ = False - -isAbsIdT :: URIType -> Bool -isAbsIdT AbsId = True -isAbsIdT _ = False - -testURIRef :: URIType -> String -> Test -testURIRef t u = TestList - [ - TestCase ( assertEqual ("testValidURIRef:"++u) (isValidT t) (isValidURIRef u) ), - TestCase ( assertEqual ("testAbsoluteURIRef:"++u) (isAbsRfT t) (isAbsoluteURIRef u) ), - TestCase ( assertEqual ("testAbsoluteURI:"++u) (isAbsIdT t) (isAbsoluteURI u) ) - ] - -testURIRef001 = testURIRef AbsRf "http://example.org/aaa/bbb#ccc" -testURIRef002 = testURIRef AbsId "mailto:local@domain.org" -testURIRef003 = testURIRef AbsRf "mailto:local@domain.org#frag" -testURIRef004 = testURIRef AbsRf "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" -testURIRef005 = testURIRef RelRf "//example.org/aaa/bbb#ccc" -testURIRef006 = testURIRef RelRf "/aaa/bbb#ccc" -testURIRef007 = testURIRef RelRf "bbb#ccc" -testURIRef008 = testURIRef RelRf "#ccc" -testURIRef009 = testURIRef RelRf "#" -testURIRef010 = testURIRef RelRf "/" --- escapes -testURIRef011 = testURIRef AbsRf "http://example.org/aaa%2fbbb#ccc" -testURIRef012 = testURIRef AbsRf "http://example.org/aaa%2Fbbb#ccc" -testURIRef013 = testURIRef RelRf "%2F" -testURIRef014 = testURIRef RelRf "aaa%2Fbbb" --- ports -testURIRef015 = testURIRef AbsRf "http://example.org:80/aaa/bbb#ccc" -testURIRef016 = testURIRef AbsRf "http://example.org:/aaa/bbb#ccc" -testURIRef017 = testURIRef AbsRf "http://example.org./aaa/bbb#ccc" -testURIRef018 = testURIRef InvRf "http://example.123./aaa/bbb#ccc" --- IPv6 literals (from RFC2732): -testURIRef021 = testURIRef AbsId "http://[FEDC:BA98:7654:3210:FEDC:BA98:7654:3210]:80/index.html" -testURIRef022 = testURIRef AbsId "http://[1080:0:0:0:8:800:200C:417A]/index.html" -testURIRef023 = testURIRef AbsId "http://[3ffe:2a00:100:7031::1]" -testURIRef024 = testURIRef AbsId "http://[1080::8:800:200C:417A]/foo" -testURIRef025 = testURIRef AbsId "http://[::192.9.5.5]/ipng" -testURIRef026 = testURIRef AbsId "http://[::FFFF:129.144.52.38]:80/index.html" -testURIRef027 = testURIRef AbsId "http://[2010:836B:4179::836B:4179]" -testURIRef028 = testURIRef RelRf "//[2010:836B:4179::836B:4179]" -testURIRef029 = testURIRef InvRf "[2010:836B:4179::836B:4179]" --- RFC2396 test cases -testURIRef031 = testURIRef RelRf "./aaa" -testURIRef032 = testURIRef RelRf "../aaa" -testURIRef033 = testURIRef AbsId "g:h" -testURIRef034 = testURIRef RelRf "g" -testURIRef035 = testURIRef RelRf "./g" -testURIRef036 = testURIRef RelRf "g/" -testURIRef037 = testURIRef RelRf "/g" -testURIRef038 = testURIRef RelRf "//g" -testURIRef039 = testURIRef RelRf "?y" -testURIRef040 = testURIRef RelRf "g?y" -testURIRef041 = testURIRef RelRf "#s" -testURIRef042 = testURIRef RelRf "g#s" -testURIRef043 = testURIRef RelRf "g?y#s" -testURIRef044 = testURIRef RelRf ";x" -testURIRef045 = testURIRef RelRf "g;x" -testURIRef046 = testURIRef RelRf "g;x?y#s" -testURIRef047 = testURIRef RelRf "." -testURIRef048 = testURIRef RelRf "./" -testURIRef049 = testURIRef RelRf ".." -testURIRef050 = testURIRef RelRf "../" -testURIRef051 = testURIRef RelRf "../g" -testURIRef052 = testURIRef RelRf "../.." -testURIRef053 = testURIRef RelRf "../../" -testURIRef054 = testURIRef RelRf "../../g" -testURIRef055 = testURIRef RelRf "../../../g" -testURIRef056 = testURIRef RelRf "../../../../g" -testURIRef057 = testURIRef RelRf "/./g" -testURIRef058 = testURIRef RelRf "/../g" -testURIRef059 = testURIRef RelRf "g." -testURIRef060 = testURIRef RelRf ".g" -testURIRef061 = testURIRef RelRf "g.." -testURIRef062 = testURIRef RelRf "..g" -testURIRef063 = testURIRef RelRf "./../g" -testURIRef064 = testURIRef RelRf "./g/." -testURIRef065 = testURIRef RelRf "g/./h" -testURIRef066 = testURIRef RelRf "g/../h" -testURIRef067 = testURIRef RelRf "g;x=1/./y" -testURIRef068 = testURIRef RelRf "g;x=1/../y" -testURIRef069 = testURIRef RelRf "g?y/./x" -testURIRef070 = testURIRef RelRf "g?y/../x" -testURIRef071 = testURIRef RelRf "g#s/./x" -testURIRef072 = testURIRef RelRf "g#s/../x" --- Invalid -testURIRef081 = testURIRef RelRf "" -testURIRef082 = testURIRef InvRf " " -testURIRef083 = testURIRef InvRf "%" -testURIRef084 = testURIRef InvRf "A%Z" -testURIRef085 = testURIRef InvRf "%ZZ" -testURIRef086 = testURIRef InvRf "%AZ" -testURIRef087 = testURIRef InvRf "A C" -testURIRef088 = testURIRef InvRf "A\"C" -testURIRef089 = testURIRef RelRf "A'C" -testURIRef090 = testURIRef InvRf "A\"C" -testURIRef091 = testURIRef InvRf "A`C" -testURIRef092 = testURIRef InvRf "AC" -testURIRef094 = testURIRef InvRf "A^C" -testURIRef095 = testURIRef InvRf "A\\C" -testURIRef096 = testURIRef InvRf "A{C" -testURIRef097 = testURIRef InvRf "A|C" -testURIRef098 = testURIRef InvRf "A}C" --- From RFC2396: --- rel_segment = 1*( unreserved | escaped | --- ";" | "@" | "&" | "=" | "+" | "$" | "," ) --- unreserved = alphanum | mark --- mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | --- "(" | ")" --- Note RFC 2732 allows '[', ']' ONLY for reserved purpose of IPv6 literals, --- or does it? -testURIRef101 = testURIRef InvRf "A[C" -testURIRef102 = testURIRef InvRf "A]C" -testURIRef103 = testURIRef InvRf "A[**]C" -testURIRef104 = testURIRef InvRf "http://[xyz]/" -testURIRef105 = testURIRef InvRf "http://]/" -testURIRef106 = testURIRef InvRf "http://example.org/[2010:836B:4179::836B:4179]" -testURIRef107 = testURIRef InvRf "http://example.org/abc#[2010:836B:4179::836B:4179]" -testURIRef108 = testURIRef InvRf "http://example.org/xxx/[qwerty]#a[b]" --- Random other things that crop up -testURIRef111 = testURIRef AbsRf "http://example/Andrȷ" - -testURIRefSuite = TestLabel "Test URIrefs" testURIRefList -testURIRefList = TestList - [ - testURIRef001, testURIRef002, testURIRef003, testURIRef004, - testURIRef005, testURIRef006, testURIRef007, testURIRef008, - testURIRef009, testURIRef010, - -- - testURIRef011, testURIRef012, testURIRef013, testURIRef014, - testURIRef015, testURIRef016, testURIRef017, testURIRef018, - -- - testURIRef021, testURIRef022, testURIRef023, testURIRef024, - testURIRef025, testURIRef026, testURIRef027, testURIRef028, - testURIRef029, - -- - testURIRef031, testURIRef032, testURIRef033, testURIRef034, - testURIRef035, testURIRef036, testURIRef037, testURIRef038, - testURIRef039, - testURIRef040, testURIRef041, testURIRef042, testURIRef043, - testURIRef044, testURIRef045, testURIRef046, testURIRef047, - testURIRef048, testURIRef049, - testURIRef050, testURIRef051, testURIRef052, testURIRef053, - testURIRef054, testURIRef055, testURIRef056, testURIRef057, - testURIRef058, testURIRef059, - testURIRef060, testURIRef061, testURIRef062, testURIRef063, - testURIRef064, testURIRef065, testURIRef066, testURIRef067, - testURIRef068, testURIRef069, - testURIRef070, testURIRef071, testURIRef072, - -- - testURIRef081, testURIRef082, testURIRef083, testURIRef084, - testURIRef085, testURIRef086, testURIRef087, testURIRef088, - testURIRef089, - testURIRef090, testURIRef091, testURIRef092, testURIRef093, - testURIRef094, testURIRef095, testURIRef096, testURIRef097, - testURIRef098, -- testURIRef099, - -- - testURIRef101, testURIRef102, testURIRef103, testURIRef104, - testURIRef105, testURIRef106, testURIRef107, testURIRef108, - -- - testURIRef111 - ] - --- Parser tests: these are fairtly cursory, as the validating tests above --- are assumed to be conducted using the parser logic. - -testParser :: ( Show a, Show b, Eq a, Eq b ) => - String -> Parser a b -> [a] -> [(b,[a])] -> Test -testParser label parser input result = - TestCase ( assertEqual label result ( parser input ) ) - -noResult :: [ ( String,[Char] ) ] -noResult = [] - --- URI parser (see Parse module) --- parseURIRef :: Parser Char String - -testParseRef01 = testParser "testParseRef01" parseURIRef "http://example.org/aaa/bbb#ccc" - [("http://example.org/aaa/bbb#ccc","")] -testParseRef02 = testParser "testParseRef02" parseURIRef "mailto:local@domain.org ****" - [("mailto:local@domain.org"," ****")] -testParseRef03 = testParser "testParseRef03" parseURIRef "mailto:local@domain.org#frag|****" - [("mailto:local@domain.org#frag","|****")] -testParseRef04 = testParser "testParseRef04" parseURIRef "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" - [("HTTP://EXAMPLE.ORG/AAA/BBB#CCC","")] -testParseRef05 = testParser "testParseRef05" parseURIRef "//example.org/aaa/bbb#ccc" - [("//example.org/aaa/bbb#ccc","")] -testParseRef06 = testParser "testParseRef06" parseURIRef "/aaa/bbb#ccc" - [("/aaa/bbb#ccc","")] -testParseRef07 = testParser "testParseRef07" parseURIRef "bbb#c%aac" [("bbb#c%aac","")] -testParseRef08 = testParser "testParseRef08" parseURIRef "#ccc" [("#ccc","")] -testParseRef09 = testParser "testParseRef09" parseURIRef "#" [("#","")] -testParseRef10 = testParser "testParseRef10" parseURIRef "/" [("/","")] -testParseRef11 = testParser "testParseRef11" parseURIRef "A^C" [("A","^C")] -testParseRef12 = testParser "testParseRef12" parseURIRef "bbb#ccc%z" [("bbb#ccc","%z")] -testParseRef13 = testParser "testParseRef13" parseURIRef "bbb?ccc" [("bbb?ccc","")] -testParseRef14 = testParser "testParseRef14" parseURIRef "?ccc" [("?ccc","")] - -testParseRefSuite = TestLabel "Test parseURIRef" testParseRefList -testParseRefList = TestList - [ - testParseRef01, testParseRef02, testParseRef03, testParseRef04, - testParseRef05, testParseRef06, testParseRef07, testParseRef08, - testParseRef09, - testParseRef10, testParseRef11, testParseRef12, testParseRef13, - testParseRef14 - ] - --- Absolute URI reference parser (see Parse module) --- parseAbsoluteURIRef :: Parser Char String - -testParseAbs01 = testParser "testParseAbs01" parseAbsoluteURIRef - "http://example.org/aaa/bbb#ccc" - [("http://example.org/aaa/bbb#ccc","")] -testParseAbs02 = testParser "testParseAbs02" parseAbsoluteURIRef - "mailto:local@domain.org ****" - [("mailto:local@domain.org"," ****")] -testParseAbs03 = testParser "testParseAbs03" parseAbsoluteURIRef - "mailto:local@domain.org#frag|****" - [("mailto:local@domain.org#frag","|****")] -testParseAbs04 = testParser "testParseAbs04" parseAbsoluteURIRef - "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" - [("HTTP://EXAMPLE.ORG/AAA/BBB#CCC","")] -testParseAbs05 = testParser "testParseAbs05" parseAbsoluteURIRef - "//example.org/aaa/bbb#ccc" - noResult -testParseAbs06 = testParser "testParseAbs06" parseAbsoluteURIRef - "/aaa/bbb#ccc" - noResult -testParseAbs07 = testParser "testParseAbs07" parseAbsoluteURIRef - "bbb#c%aac" - noResult -testParseAbs08 = testParser "testParseAbs08" parseAbsoluteURIRef - "#ccc" - noResult -testParseAbs09 = testParser "testParseAbs09" parseAbsoluteURIRef - "#" - noResult -testParseAbs10 = testParser "testParseAbs10" parseAbsoluteURIRef - "/" - noResult -testParseAbs11 = testParser "testParseAbs11" parseAbsoluteURIRef - "A'C" - noResult -testParseAbs12 = testParser "testParseAbs12" parseAbsoluteURIRef - "bbb#ccc%z" - noResult - -testParseAbsSuite = TestLabel "Test parseAbsoluteURIRef" testParseAbsList -testParseAbsList = TestList - [ - testParseAbs01, testParseAbs02, testParseAbs03, testParseAbs04, - testParseAbs05, testParseAbs06, testParseAbs07, testParseAbs08, - testParseAbs09, - testParseAbs10, testParseAbs11, testParseAbs12 - ] - --- Absolute URI parser (see Parse module) --- parseAbsoluteURI :: Parser Char String - -testParseURI01 = testParser "testParseURI01" parseAbsoluteURI - "http://example.org/aaa/bbb#ccc" - [("http://example.org/aaa/bbb","#ccc")] -testParseURI02 = testParser "testParseURI02" parseAbsoluteURI - "mailto:local@domain.org ****" - [("mailto:local@domain.org"," ****")] -testParseURI03 = testParser "testParseURI03" parseAbsoluteURI - "mailto:local@domain.org#frag|****" - [("mailto:local@domain.org","#frag|****")] -testParseURI04 = testParser "testParseURI04" parseAbsoluteURI - "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" - [("HTTP://EXAMPLE.ORG/AAA/BBB","#CCC")] -testParseURI05 = testParser "testParseURI05" parseAbsoluteURI - "//example.org/aaa/bbb#ccc" - noResult -testParseURI06 = testParser "testParseURI06" parseAbsoluteURI - "/aaa/bbb#ccc" - noResult -testParseURI07 = testParser "testParseURI07" parseAbsoluteURI - "bbb#c%aac" - noResult -testParseURI08 = testParser "testParseURI08" parseAbsoluteURI - "#ccc" - noResult -testParseURI09 = testParser "testParseURI09" parseAbsoluteURI - "#" - noResult -testParseURI10 = testParser "testParseURI10" parseAbsoluteURI - "/" - noResult -testParseURI11 = testParser "testParseURI11" parseAbsoluteURI - "A'C" - noResult -testParseURI12 = testParser "testParseURI12" parseAbsoluteURI - "bbb#ccc%z" - noResult - -testParseURISuite = TestLabel "Test parseAbsoluteURI" testParseURIList -testParseURIList = TestList - [ - testParseURI01, testParseURI02, testParseURI03, testParseURI04, - testParseURI05, testParseURI06, testParseURI07, testParseURI08, - testParseURI09, - testParseURI10, testParseURI11, testParseURI12 - ] - --- Compare two URIs --- Takes account of normalizations that can be applied to all URIs --- (2003-02-20, currently subject to W3C TAG debate) --- compareURI :: String -> String -> Bool - -testCompare :: String -> Bool -> String -> String -> Test -testCompare label eq uri1 uri2 = - TestCase ( assertEqual label eq ( compareURI uri1 uri2 ) ) - -testCompare01 = testCompare "testCompare01" True - "http://example.org/aaa/bbb#ccc" - "http://example.org/aaa/bbb#ccc" -testCompare02 = testCompare "testCompare02" False - "http://example.org/aaa/bbb#ccc" - "HTTP://example.org/aaa/bbb#ccc" -testCompare03 = testCompare "testCompare03" False - "http://example.org/aaa/bbb#ccc" - "http://EXAMPLE.ORG/aaa/bbb#ccc" -testCompare04 = testCompare "testCompare04" False - "http://example.org/aaa/bbb#ccc" - "http://example.org/AAA/bbb#ccc" -testCompare05 = testCompare "testCompare05" False - "http://example.org/aaa/bbb#ccc" - "http://example.org/a%61a/bbb#ccc" -testCompare06 = testCompare "testCompare06" False - "http://example.org/aaa/bbb#ccc" - "http://example.org/aaa/b%62b#ccc" -testCompare07 = testCompare "testCompare07" False - "http://example.org/aaa/bbb#ccc" - "http://example.org/aaa/bbb#c%63c" -testCompare08 = testCompare "testCompare08" False - "mailto:local@example.org" - "mailto:local@ex%61mple.org" -testCompare09 = testCompare "testCompare09" False - "http://example.org/aaa/bbb#ccc" - "http://example.org/aaa%2Fbbb#ccc" -testCompare10 = testCompare "testCompare10" False - "http://example.org/aaa%2fbbb#ccc" - "http://example.org/aaa%2Fbbb#ccc" - -testCompareSuite = TestLabel "Test compareURI" testCompareList -testCompareList = TestList - [ - testCompare01, testCompare02, testCompare03, testCompare04, - testCompare05, testCompare06, testCompare07, testCompare08, - testCompare09, - testCompare10 -- , testCompare11, testCompare12 - ] - --- Separate URI-with-fragment into URI and fragment ID --- splitURIFragment :: String -> ( String, Maybe String ) --- Construct URI-with-fragment using URI and supplied fragment id --- makeURIWithFragment :: String -> Maybe String -> String - -testSplitFrag :: String -> String -> ( String, Maybe String ) -> Test -testSplitFrag label input ( main, frag ) = TestList - [ - TestCase ( assertEqual (label++"(split)") ( main, frag ) ( splitURIFragment input ) ), - TestCase ( assertEqual (label++"(make)") input ( makeURIWithFragment main frag ) ) - ] - -testSplitFrag01 = testSplitFrag "testSplitFrag01" - "http://example.org/aaa/bbb#ccc" - ( "http://example.org/aaa/bbb", Just "ccc" ) -testSplitFrag02 = testSplitFrag "testSplitFrag02" - "mailto:local@domain.org" - ( "mailto:local@domain.org", Nothing ) -testSplitFrag03 = testSplitFrag "testSplitFrag03" - "mailto:local@domain.org#frag" - ( "mailto:local@domain.org", Just "frag" ) -testSplitFrag04 = testSplitFrag "testSplitFrag04" - "HTTP://EXAMPLE.ORG/AAA/BBB#CCC" - ( "HTTP://EXAMPLE.ORG/AAA/BBB", Just "CCC" ) -testSplitFrag05 = testSplitFrag "testSplitFrag05" - "//example.org/aaa/bbb#ccc" - ( "//example.org/aaa/bbb", Just "ccc" ) -testSplitFrag06 = testSplitFrag "testSplitFrag06" - "/aaa/bbb#ccc" - ( "/aaa/bbb", Just "ccc" ) -testSplitFrag07 = testSplitFrag "testSplitFrag07" - "bbb#ccc" - ( "bbb", Just "ccc" ) -testSplitFrag08 = testSplitFrag "testSplitFrag08" - "#ccc" - ( "", Just "ccc" ) -testSplitFrag09 = testSplitFrag "testSplitFrag09" - "#" - ( "", Just "" ) -testSplitFrag10 = testSplitFrag "testSplitFrag10" - "/" - ( "/", Nothing ) -testSplitFrag11 = testSplitFrag "testSplitFrag11" - "aaa%12ccc" - ( "aaa%12ccc", Nothing ) -testSplitFrag12 = testSplitFrag "testSplitFrag12" - "aaa%23ccc" -- %23 = '#' - ( "aaa%23ccc", Nothing ) -testSplitFrag13 = testSplitFrag "testSplitFrag13" - "http://example.org/aaa/bbb#" - ( "http://example.org/aaa/bbb", Just "" ) -testSplitFrag14 = testSplitFrag "testSplitFrag14" - "" - ( "", Nothing ) -testSplitFrag15 = testSplitFrag "testSplitFrag15" - "abc" - ( "abc", Nothing ) -testSplitFrag16 = testSplitFrag "testSplitFrag16" - "abc#de:f" - ( "abc", Just "de:f" ) -testSplitFrag17 = testSplitFrag "testSplitFrag17" - "abc#de?f" - ( "abc", Just "de?f" ) -testSplitFrag18 = testSplitFrag "testSplitFrag18" - "abc#de/f" - ( "abc", Just "de/f" ) - -testSplitFragSuite = TestLabel "Test splitURIFragment" testSplitFragList -testSplitFragList = TestList - [ - testSplitFrag01, testSplitFrag02, testSplitFrag03, testSplitFrag04, - testSplitFrag05, testSplitFrag06, testSplitFrag07, testSplitFrag08, - testSplitFrag09, - testSplitFrag10, testSplitFrag11, testSplitFrag12, testSplitFrag13, - testSplitFrag14, testSplitFrag15, testSplitFrag16, testSplitFrag17, - testSplitFrag18 - ] - - --- Above tests most cases of makeURIWithFragment, --- but a couple of extra tests are needed for when the main URI already --- has a fragment: -testOverrideFrag label ( main, frag ) result = - TestCase ( assertEqual label result ( makeURIWithFragment main frag ) ) - -testOverrideFrag01 = testOverrideFrag "testOverrideFrag01" - ( "http://example.org/aaa#bbb", (Just "fff") ) - "http://example.org/aaa#fff" -testOverrideFrag02 = testOverrideFrag "testOverrideFrag02" - ( "http://example.org/aaa#bbb", Nothing ) - "http://example.org/aaa" -testOverrideFrag03 = testOverrideFrag "testOverrideFrag03" - ( "http://example.org/aaa#bbb", Just "" ) - "http://example.org/aaa#" - -testOverrideFragSuite = TestLabel "Test Override Fragment" testOverrideFragList -testOverrideFragList = TestList - [ - testOverrideFrag01, testOverrideFrag02, testOverrideFrag03 - ] - --- test getURIRef function -testGetURIRef :: String -> String -> URI -> Test -testGetURIRef label strval urival = - TestCase ( assertEqual label urival ( getURIRef strval ) ) - - -testGetURIRef01 = testGetURIRef "testGetURIRef01" - "foo:xyz" - (URI "foo:" "xyz" [] "" "") -testGetURIRef02 = testGetURIRef "testGetURIRef02" - "http://example/x/y/z" - (URI "http:" "//example" ["/","x/","y/","z"] "" "") -testGetURIRef03 = testGetURIRef "testGetURIRef03" - "../abc" - (URI "" "" ["../","abc"] "" "") -testGetURIRef04 = testGetURIRef "testGetURIRef04" - "http://example/a/b/../../c" - (URI "http:" "//example" ["/","a/","b/","../","../","c"] "" "") -testGetURIRef05 = testGetURIRef "testGetURIRef04" - "http://example/a/./b/./../c/" - (URI "http:" "//example" ["/","a/","./","b/","./","../","c/",""] "" "") - - -testGetURIRefSuite = TestLabel "Test getURIReg" testGetURIRefList -testGetURIRefList = TestList - [ - testGetURIRef01, testGetURIRef02, testGetURIRef03, testGetURIRef04, testGetURIRef05 - ] - --- test normalizeURI function -testNormalizeURI :: String -> String -> String -> Test -testNormalizeURI label strval normval = - TestCase ( assertEqual (label++": "++strval) normval ( normalizeURI strval ) ) - - -testNormalizeURI01 = testNormalizeURI "testNormalizeURI01" - "../abc" - "../abc" -testNormalizeURI02 = testNormalizeURI "testNormalizeURI02" - "http://example/x/y/z" - "http://example/x/y/z" -testNormalizeURI03 = testNormalizeURI "testNormalizeURI03" - "http://example/a/b/../../c" - "http://example/c" -testNormalizeURI04 = testNormalizeURI "testNormalizeURI04" - "http://example/a/b/c/../../" - "http://example/a/" -testNormalizeURI05 = testNormalizeURI "testNormalizeURI05" - "http://example/a/b/c/./" - "http://example/a/b/c/" -testNormalizeURI06 = testNormalizeURI "testNormalizeURI06" - "http://example/a/b/c/.././" - "http://example/a/b/" -testNormalizeURI07 = testNormalizeURI "testNormalizeURI07" - "http://example/a/b/c/d/../../../../e" - "http://example/e" -testNormalizeURI08 = testNormalizeURI "testNormalizeURI08" - "http://example/a/b/c/d/../.././../../e" - "http://example/e" - -testNormalizeURISuite = TestLabel "Test normalizeURI" testNormalizeURIList -testNormalizeURIList = TestList - [ - testNormalizeURI01, testNormalizeURI02, testNormalizeURI03, testNormalizeURI04, - testNormalizeURI05, testNormalizeURI06, testNormalizeURI07, testNormalizeURI08 - ] - --- Get reference relative to given base --- relativeRef :: String -> String -> String --- Get absolute URI given base and relative reference --- absoluteURI :: String -> String -> String --- --- Test cases taken from: http://www.w3.org/2000/10/swap/uripath.py --- (Thanks, Dan Connolly) --- --- NOTE: absoluteURI base (relativeRef base u) is always equivalent to u. --- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html - -testRelSplit :: String -> String -> String -> String -> Test -testRelSplit label base uabs urel = - TestCase ( assertEqual label urel ( relativeRefPart base uabs ) ) - -testRelJoin :: String -> String -> String -> String -> Test -testRelJoin label base urel uabs = - TestCase ( assertEqual label uabs ( absoluteUriPart base urel ) ) - -testRelative :: String -> String -> String -> String -> Test -testRelative label base uabs urel = TestList - [ - (testRelSplit (label++"(rel)") base uabs urel), - (testRelJoin (label++"(abs)") base urel (normalizeURI uabs)) - ] - -testRelative01 = testRelative "testRelative01" - "foo:xyz" "bar:abc" "bar:abc" -testRelative02 = testRelative "testRelative02" - "http://example/x/y/z" "http://example/x/abc" "../abc" -testRelative03 = testRelative "testRelative03" - "http://example2/x/y/z" "http://example/x/abc" "//example/x/abc" - -- "http://example2/x/y/z" "http://example/x/abc" "http://example/x/abc" -testRelative04 = testRelative "testRelative04" - "http://ex/x/y/z" "http://ex/x/r" "../r" -testRelative05 = testRelative "testRelative05" - "http://ex/x/y/z" "http://ex/r" "/r" - -- "http://ex/x/y/z" "http://ex/r" "../../r" -testRelative06 = testRelative "testRelative06" - "http://ex/x/y" "http://ex/x/q/r" "q/r" -testRelative07 = testRelative "testRelative07" - "http://ex/x/y" "http://ex/x/q/r#s" "q/r#s" -testRelative08 = testRelative "testRelative08" - "http://ex/x/y" "http://ex/x/q/r#s/t" "q/r#s/t" -testRelative09 = testRelative "testRelative09" - "http://ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" -testRelative10 = testRelative "testRelative10" - "http://ex/x/y" "http://ex/x/y" "y" - -- "http://ex/x/y" "http://ex/x/y" "" -testRelative11 = testRelative "testRelative11" - "http://ex/x/y/" "http://ex/x/y/" "./" - -- "http://ex/x/y/" "http://ex/x/y/" "" -testRelative12 = testRelative "testRelative12" - "http://ex/x/y/pdq" "http://ex/x/y/pdq" "pdq" - -- "http://ex/x/y/pdq" "http://ex/x/y/pdq" "" -testRelative13 = testRelative "testRelative13" - "http://ex/x/y/" "http://ex/x/y/z/" "z/" -testRelative14 = testRelative "testRelative14" - "file:/swap/test/animal.rdf" "file:/swap/test/animal.rdf#Animal" "animal.rdf#Animal" -testRelative15 = testRelative "testRelative15" - "file:/e/x/y/z" "file:/e/x/abc" "../abc" -testRelative16 = testRelative "testRelative16" - "file:/example2/x/y/z" "file:/example/x/abc" "/example/x/abc" -testRelative17 = testRelative "testRelative17" - "file:/ex/x/y/z" "file:/ex/x/r" "../r" -testRelative18 = testRelative "testRelative18" - "file:/ex/x/y/z" "file:/r" "/r" -testRelative19 = testRelative "testRelative19" - "file:/ex/x/y" "file:/ex/x/q/r" "q/r" -testRelative20 = testRelative "testRelative20" - "file:/ex/x/y" "file:/ex/x/q/r#s" "q/r#s" -testRelative21 = testRelative "testRelative21" - "file:/ex/x/y" "file:/ex/x/q/r#" "q/r#" -testRelative22 = testRelative "testRelative22" - "file:/ex/x/y" "file:/ex/x/q/r#s/t" "q/r#s/t" -testRelative23 = testRelative "testRelative23" - "file:/ex/x/y" "ftp://ex/x/q/r" "ftp://ex/x/q/r" -testRelative24 = testRelative "testRelative24" - "file:/ex/x/y" "file:/ex/x/y" "y" - -- "file:/ex/x/y" "file:/ex/x/y" "" -testRelative25 = testRelative "testRelative25" - "file:/ex/x/y/" "file:/ex/x/y/" "./" - -- "file:/ex/x/y/" "file:/ex/x/y/" "" -testRelative26 = testRelative "testRelative26" - "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "pdq" - -- "file:/ex/x/y/pdq" "file:/ex/x/y/pdq" "" -testRelative27 = testRelative "testRelative27" - "file:/ex/x/y/" "file:/ex/x/y/z/" "z/" -testRelative28 = testRelative "testRelative28" - "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" - "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" - -- "file:/devel/WWW/2000/10/swap/test/reluri-1.n3" - -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" -testRelative29 = testRelative "testRelative29" - "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" - "file://meetings.example.com/cal#m1" "//meetings.example.com/cal#m1" - -- "file:/home/connolly/w3ccvs/WWW/2000/10/swap/test/reluri-1.n3" - -- "file://meetings.example.com/cal#m1" "file://meetings.example.com/cal#m1" -testRelative30 = testRelative "testRelative30" - "file:/some/dir/foo" "file:/some/dir/#blort" "./#blort" -testRelative31 = testRelative "testRelative31" - "file:/some/dir/foo" "file:/some/dir/#" "./#" -testRelative32 = testRelative "testRelative32" - "http://ex/x/y" "http://ex/x/q:r" "./q:r" - -- see RFC2396bis, section 5 ^^ -testRelative33 = testRelative "testRelative33" - "http://ex/x/y" "http://ex/x/p=q:r" "./p=q:r" - -- "http://ex/x/y" "http://ex/x/p=q:r" "p=q:r" -testRelative34 = testRelative "testRelative34" - "http://ex/x/y?pp/qq" "http://ex/x/y?pp/rr" "y?pp/rr" -testRelative35 = testRelative "testRelative35" - "http://ex/x/y?pp/qq" "http://ex/x/y/z" "y/z" -testRelative36 = testRelative "testRelative36" - "mailto:local" - "mailto:local/qual@domain.org#frag" - "local/qual@domain.org#frag" --- relativeRefPart "mailto:local/qual@domain.org" "mailto:local/qual@domain.org#frag" -testRelative37 = testRelative "testRelative37" - "mailto:local/qual@domain.org" - "mailto:local/qual@domain.org#frag" - "local/qual@domain.org#frag" -testRelative38 = testRelative "testRelative38" - "http://ex/x/y?q" "http://ex/x/y?q" "y?q" -testRelative39 = testRelative "testRelative39" - "http://ex?p" "http://ex/x/y?q" "/x/y?q" - --- add escape tests -testRelative40 = testRelative "testRelative40" - "http://example/x/y%2Fz" "http://example/x/abc" "abc" -testRelative41 = testRelative "testRelative41" - "http://example/a/x/y/z" "http://example/a/x%2Fabc" "../../x%2Fabc" -testRelative42 = testRelative "testRelative42" - "http://example/a/x/y%2Fz" "http://example/a/x%2Fabc" "../x%2Fabc" -testRelative43 = testRelative "testRelative43" - "http://example/x%2Fy/z" "http://example/x%2Fy/abc" "abc" -testRelative44 = testRelative "testRelative44" - "http://ex/x/y" "http://ex/x/q%3Ar" "q%3Ar" -testRelative45 = testRelative "testRelative45" - "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" --- Apparently, TimBL prefers the following way to 41, 42 above --- cf. http://lists.w3.org/Archives/Public/uri/2003Feb/0028.html --- He also notes that there may be different relative fuctions --- that satisfy the basic equivalence axiom: --- cf. http://lists.w3.org/Archives/Public/uri/2003Jan/0008.html -testRelative46 = testRelative "testRelative46" - "http://example/x/y/z" "http://example/x%2Fabc" "/x%2Fabc" -testRelative47 = testRelative "testRelative47" - "http://example/x/y%2Fz" "http://example/x%2Fabc" "/x%2Fabc" - --- Other oddball tests - -- Check segment normalization code: -testRelative50 = testRelative "testRelative50" - "ftp://example/x/y" "http://example/a/b/../../c" "http://example/c" -testRelative51 = testRelative "testRelative51" - "ftp://example/x/y" "http://example/a/b/c/../../" "http://example/a/" -testRelative52 = testRelative "testRelative52" - "ftp://example/x/y" "http://example/a/b/c/./" "http://example/a/b/c/" -testRelative53 = testRelative "testRelative53" - "ftp://example/x/y" "http://example/a/b/c/.././" "http://example/a/b/" -testRelative54 = testRelative "testRelative54" - "ftp://example/x/y" "http://example/a/b/c/d/../../../../e" "http://example/e" -testRelative55 = testRelative "testRelative55" - "ftp://example/x/y" "http://example/a/b/c/d/../.././../../e" "http://example/e" - -- Check handling of queries and fragments with non-relative paths -testRelative60 = testRelative "testRelative60" - "mailto:local1@domain1?query1" "mailto:local2@domain2" - "local2@domain2" -testRelative61 = testRelative "testRelative61" - "mailto:local1@domain1" "mailto:local2@domain2?query2" - "local2@domain2?query2" -testRelative62 = testRelative "testRelative62" - "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" - "local2@domain2?query2" -testRelative63 = testRelative "testRelative63" - "mailto:local@domain?query1" "mailto:local@domain?query2" - "local@domain?query2" -testRelative64 = testRelative "testRelative64" - "mailto:?query1" "mailto:local@domain?query2" - "local@domain?query2" -testRelative65 = testRelative "testRelative65" - "mailto:local@domain?query1" "mailto:?query2" - "?query2" - --- testRelative base abs rel --- testRelSplit base abs rel --- testRelJoin base rel abs -testRelative70 = testRelative "testRelative70" - "http://example.org/base/uri" "http:this" - "this" -- no round-tripping this case -testRelative71 = testRelSplit "testRelative71" - "http://example.org/base/uri" "http:this" - "this" -testRelative72 = testRelJoin "testRelative72" - "http://example.org/base/uri" "http:this" - "http:this" -testRelative73 = testRelJoin "testRelative73" - "http:base" "http:this" - "http:this" -testRelative74 = testRelJoin "testRelative74" - "f:/a" ".//g" - "f://g" -testRelative75 = testRelJoin "testRelative74" - "f://example.org/base/a" "b/c//d/e" - "f://example.org/base/b/c//d/e" -testRelative76 = testRelJoin "testRelative74" - "mid:m@example.ord/c@example.org" "m2@example.ord/c2@example.org" - "mid:m2@example.ord/c2@example.org" - - -testRelativeSuite = TestLabel "Test Relative URIs" testRelativeList -testRelativeList = TestList - [ testRelative01, testRelative02, testRelative03, testRelative04 - , testRelative05, testRelative06, testRelative07, testRelative08 - , testRelative09 - , testRelative10, testRelative11, testRelative12, testRelative13 - , testRelative14, testRelative15, testRelative16, testRelative17 - , testRelative18, testRelative19 - , testRelative21, testRelative21, testRelative22, testRelative23 - , testRelative24, testRelative25, testRelative26, testRelative27 - , testRelative28, testRelative29 - , testRelative30, testRelative31, testRelative32, testRelative33 - , testRelative34, testRelative35, testRelative36, testRelative37 - -- - , testRelative40, testRelative41, testRelative42, testRelative43 - , testRelative44, testRelative45, testRelative46, testRelative47 - -- - , testRelative50, testRelative51, testRelative52, testRelative53 - , testRelative54, testRelative55 - -- - , testRelative60, testRelative61, testRelative62, testRelative63 - , testRelative64, testRelative65 - -- - -- , testRelative70 - , testRelative71, testRelative72, testRelative73 - , testRelative74, testRelative75, testRelative76 - ] - --- RFC2396 relative-to-absolute URI tests - -rfcbase = "http://a/b/c/d;p?q" --- normal cases, RFC2396 C.1 -testRFC01 = testRelJoin "testRFC01" rfcbase "g:h" "g:h" -testRFC02 = testRelJoin "testRFC02" rfcbase "g" "http://a/b/c/g" -testRFC03 = testRelJoin "testRFC03" rfcbase "./g" "http://a/b/c/g" -testRFC04 = testRelJoin "testRFC04" rfcbase "g/" "http://a/b/c/g/" -testRFC05 = testRelJoin "testRFC05" rfcbase "/g" "http://a/g" -testRFC06 = testRelJoin "testRFC06" rfcbase "//g" "http://g" -testRFC07 = testRelJoin "testRFC07" rfcbase "?y" "http://a/b/c/d;p?y" -testRFC08 = testRelJoin "testRFC08" rfcbase "g?y" "http://a/b/c/g?y" -testRFC09 = testRelJoin "testRFC09" rfcbase "?q#s" "http://a/b/c/d;p?q#s" -testRFC10 = testRelJoin "testRFC10" rfcbase "g#s" "http://a/b/c/g#s" -testRFC11 = testRelJoin "testRFC11" rfcbase "g?y#s" "http://a/b/c/g?y#s" -testRFC12 = testRelJoin "testRFC12" rfcbase ";x" "http://a/b/c/;x" -testRFC13 = testRelJoin "testRFC13" rfcbase "g;x" "http://a/b/c/g;x" -testRFC14 = testRelJoin "testRFC14" rfcbase "g;x?y#s" "http://a/b/c/g;x?y#s" -testRFC15 = testRelJoin "testRFC15" rfcbase "." "http://a/b/c/" -testRFC16 = testRelJoin "testRFC16" rfcbase "./" "http://a/b/c/" -testRFC17 = testRelJoin "testRFC17" rfcbase ".." "http://a/b/" -testRFC18 = testRelJoin "testRFC18" rfcbase "../" "http://a/b/" -testRFC19 = testRelJoin "testRFC19" rfcbase "../g" "http://a/b/g" -testRFC20 = testRelJoin "testRFC20" rfcbase "../.." "http://a/" -testRFC21 = testRelJoin "testRFC21" rfcbase "../../" "http://a/" -testRFC22 = testRelJoin "testRFC22" rfcbase "../../g" "http://a/g" -testRFC23 = testRelJoin "testRFC23" rfcbase "#s" "#s" -- current document -testRFC24 = testRelJoin "testRFC24" rfcbase "" "" -- current document --- abnormal cases, RFC2396 C.2 -testRFC31 = testRelJoin "testRFC31" rfcbase "?q" rfcbase -testRFC32 = testRelJoin "testRFC32" rfcbase "../../../g" "http://a/../g" -testRFC33 = testRelJoin "testRFC33" rfcbase "../../../../g" "http://a/../../g" -testRFC34 = testRelJoin "testRFC34" rfcbase "/./g" "http://a/g" ---testRFC34 = testRelJoin "testRFC34" rfcbase "/./g" "http://a/./g" -- RFC2396 says don't remove '.' -testRFC35 = testRelJoin "testRFC35" rfcbase "/../g" "http://a/../g" -testRFC36 = testRelJoin "testRFC36" rfcbase "g." "http://a/b/c/g." -testRFC37 = testRelJoin "testRFC37" rfcbase ".g" "http://a/b/c/.g" -testRFC38 = testRelJoin "testRFC38" rfcbase "g.." "http://a/b/c/g.." -testRFC39 = testRelJoin "testRFC39" rfcbase "..g" "http://a/b/c/..g" -testRFC40 = testRelJoin "testRFC40" rfcbase "./../g" "http://a/b/g" -testRFC41 = testRelJoin "testRFC41" rfcbase "./g/." "http://a/b/c/g/" -testRFC42 = testRelJoin "testRFC42" rfcbase "g/./h" "http://a/b/c/g/h" -testRFC43 = testRelJoin "testRFC43" rfcbase "g/../h" "http://a/b/c/h" -testRFC44 = testRelJoin "testRFC44" rfcbase "g;x=1/./y" "http://a/b/c/g;x=1/y" -testRFC45 = testRelJoin "testRFC45" rfcbase "g;x=1/../y" "http://a/b/c/y" -testRFC46 = testRelJoin "testRFC46" rfcbase "g?y/./x" "http://a/b/c/g?y/./x" -testRFC47 = testRelJoin "testRFC47" rfcbase "g?y/../x" "http://a/b/c/g?y/../x" -testRFC48 = testRelJoin "testRFC48" rfcbase "g#s/./x" "http://a/b/c/g#s/./x" -testRFC49 = testRelJoin "testRFC49" rfcbase "g#s/../x" "http://a/b/c/g#s/../x" -testRFC50 = testRelJoin "testRFC50" rfcbase "http:x" "http:x" - --- Null path tests --- See RFC2396bis, section 5.2, --- "If the base URI's path component is the empty string, then a single --- slash character is copied to the buffer" -testRFC60 = testRelative "testRFC60" "http://ex" "http://ex/x/y?q" "/x/y?q" -testRFC61 = testRelJoin "testRFC61" "http://ex" "x/y?q" "http://ex/x/y?q" -testRFC62 = testRelative "testRFC62" "http://ex?p" "http://ex/x/y?q" "/x/y?q" -testRFC63 = testRelJoin "testRFC63" "http://ex?p" "x/y?q" "http://ex/x/y?q" -testRFC64 = testRelative "testRFC64" "http://ex#f" "http://ex/x/y?q" "/x/y?q" -testRFC65 = testRelJoin "testRFC65" "http://ex#f" "x/y?q" "http://ex/x/y?q" -testRFC66 = testRelative "testRFC66" "http://ex?p" "http://ex/x/y#g" "/x/y#g" -testRFC67 = testRelJoin "testRFC67" "http://ex?p" "x/y#g" "http://ex/x/y#g" -testRFC68 = testRelative "testRFC68" "http://ex" "http://ex/" "/" -testRFC69 = testRelJoin "testRFC69" "http://ex" "./" "http://ex/" -testRFC70 = testRelative "testRFC70" "http://ex" "http://ex/a/b" "/a/b" -testRFC71 = testRelative "testRFC71" "http://ex/a/b" "http://ex" "./" - -testRFC2396Suite = TestLabel "Test RFC2396 examples" testRFC2396List -testRFC2396List = TestList - [ - testRFC01, testRFC02, testRFC03, testRFC04, - testRFC05, testRFC06, testRFC07, testRFC08, - testRFC09, - testRFC10, testRFC11, testRFC12, testRFC13, - testRFC14, testRFC15, testRFC16, testRFC17, - testRFC18, testRFC19, - testRFC20, testRFC21, testRFC22, testRFC23, - testRFC24, - -- testRFC30, - testRFC31, testRFC32, testRFC33, - testRFC34, testRFC35, testRFC36, testRFC37, - testRFC38, testRFC39, - testRFC40, testRFC41, testRFC42, testRFC43, - testRFC44, testRFC45, testRFC46, testRFC47, - testRFC48, testRFC49, - testRFC50, - -- - testRFC60, testRFC61, testRFC62, testRFC63, - testRFC64, testRFC65, testRFC66, testRFC67, - testRFC68, testRFC69, - testRFC70 - ] - --- And some other oddballs: -mailbase = "mailto:local/option@domain.org?notaquery#frag" -testMail01 = testRelJoin "testMail01" - mailbase "local@domain" - "mailto:local@domain" -testMail02 = testRelJoin "testMail02" - mailbase "#newfrag" - "mailto:#newfrag" - -- "mailto:local/option@domain.org?notaquery#newfrag" -testMail03 = testRelJoin "testMail03" - mailbase "l1/q1@domain" - "mailto:l1/q1@domain" - -testMail11 = testRelJoin "testMail11" - "mailto:local1@domain1?query1" "mailto:local2@domain2" - "mailto:local2@domain2" -testMail12 = testRelJoin "testMail12" - "mailto:local1@domain1" "mailto:local2@domain2?query2" - "mailto:local2@domain2?query2" -testMail13 = testRelJoin "testMail13" - "mailto:local1@domain1?query1" "mailto:local2@domain2?query2" - "mailto:local2@domain2?query2" -testMail14 = testRelJoin "testMail14" - "mailto:local@domain?query1" "mailto:local@domain?query2" - "mailto:local@domain?query2" -testMail15 = testRelJoin "testMail15" - "mailto:?query1" "mailto:local@domain?query2" - "mailto:local@domain?query2" -testMail16 = testRelJoin "testMail16" - "mailto:local@domain?query1" "?query2" - "mailto:?query2" -testInfo17 = testRelJoin "testInfo17" - "info:name/1234/../567" "name/9876/../543" - "info:name/9876/../543" -testInfo18 = testRelJoin "testInfo18" - "info:/name/1234/../567" "name/9876/../543" - "info:/name/name/543" - -testOddballSuite = TestLabel "Test oddball examples" testOddballList -testOddballList = TestList - [ testMail01, testMail02, testMail03 - , testMail11, testMail12, testMail13, testMail14, testMail15, testMail16 - , testInfo17 - ] - --- Full test suite -allTests = TestList - [ testURIRefSuite, - testParseRefSuite, - testParseAbsSuite, - testParseURISuite, - testCompareSuite, - testSplitFragSuite, - testOverrideFragSuite, - testGetURIRefSuite, - testNormalizeURIList, - testRelativeSuite, - testRFC2396Suite, - testOddballSuite - ] - -main = runTestTT allTests - -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT - -uref = testURIRefSuite -pref = testParseRefSuite -pabs = testParseAbsSuite -puri = testParseURISuite -comp = testCompareSuite -frag = testSplitFragSuite -over = testOverrideFragSuite -guri = testGetURIRefSuite -nuri = testNormalizeURIList -tr01 = testRelative01 -tr02 = testRelative02 -tr03 = testRelative03 -tr04 = testRelative04 -rel = testRelativeSuite -rfc = testRFC2396Suite -oddb = testOddballSuite - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, G. KLYNE. 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 --- --------------------------------------------------------------------------------- --- $Source: /file/cvsdev/HaskellUtils/URITest.hs,v $ --- $Author: graham $ --- $Revision: 1.2 $ --- $Log: URITest.hs,v $ --- Revision 1.2 2004/01/22 19:52:27 graham --- Rename module URI to avoid awkward clash with Haskell libraries --- --- Revision 1.1 2004/01/13 12:31:24 graham --- Move modules from HaskellRDF to HaskellUtils project --- --- Revision 1.21 2004/01/06 13:53:10 graham --- Created consolidated test harness (SwishTestAll.hs) --- --- Revision 1.20 2003/11/07 21:45:47 graham --- Started rework of datatype to use new DatatypeRel structure. --- --- Revision 1.19 2003/09/24 18:50:52 graham --- Revised module format to be Haddock compatible. --- --- Revision 1.18 2003/09/24 13:35:43 graham --- QName splitting moved from URI module to QName module --- --- Revision 1.17 2003/06/24 19:55:50 graham --- Another test case added --- --- Revision 1.16 2003/06/18 23:37:09 graham --- Another test case. --- --- Revision 1.15 2003/06/17 15:42:36 graham --- Misc updates --- --- Revision 1.14 2003/06/10 01:04:46 graham --- Proof framework in progress; compiles, incomplete --- --- Revision 1.13 2003/06/03 19:24:14 graham --- Updated all source modules to cite GNU Public Licence --- --- Revision 1.12 2003/05/29 13:04:42 graham --- All tests now compile and pass as stand-alone programs compiled --- using GHC. Added batch files to compile programs and run tests. --- --- Revision 1.11 2003/04/17 00:35:39 graham --- Added module N3ParserTest --- N3parser is mostly working --- Formulae remain to test --- --- Revision 1.10 2003/03/05 22:16:24 graham --- URI code passes all unit tests --- --- Revision 1.9 2003/03/05 14:47:45 graham --- Relative URI code complete, not tested --- Fixed a URI parser bug --- --- Revision 1.8 2003/02/28 14:02:52 graham --- A few new test cases --- --- Revision 1.7 2003/02/27 23:33:54 graham --- QName splitting tested OK --- --- Revision 1.6 2003/02/27 20:29:53 graham --- Fixed some more parser bugs. --- All parser tests pass. --- QName and relative path handling to do. --- --- Revision 1.5 2003/02/27 18:48:05 graham --- Fix URI parser bug. --- Add more URI parser test cases. --- --- Revision 1.4 2003/02/27 15:28:45 graham --- Updated internal structure of parsed URI. --- Passes parser unit tests --- --- Revision 1.3 2003/02/27 09:50:25 graham --- Add URI parser test cases, some name changes --- --- Revision 1.2 2003/02/27 00:30:14 graham --- Syntax code nearly complete, untested --- --- Revision 1.1 2003/02/20 19:45:07 graham --- Add URI module and unit tests. --- Code incomplete. --- diff --git a/Swish/RDF/BuiltInDatatypes.hs b/Swish/RDF/BuiltInDatatypes.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/BuiltInDatatypes.hs @@ -0,0 +1,84 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : BuiltInDatatypes +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- datatypes built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltInDatatypes + ( allDatatypes, findRDFDatatype ) +where + +import Swish.RDF.RDFDatatype + ( RDFDatatype + ) + +import Swish.Utils.LookupMap + ( LookupMap(..), mapFindMaybe + ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +import Swish.RDF.RDFDatatypeXsdString + ( rdfDatatypeXsdString ) + +import Swish.RDF.RDFDatatypeXsdInteger + ( rdfDatatypeXsdInteger ) + +------------------------------------------------------------ +-- Declare datatype map +------------------------------------------------------------ + +allDatatypes :: [RDFDatatype] +allDatatypes = + [ rdfDatatypeXsdString + , rdfDatatypeXsdInteger + ] + +findRDFDatatype :: ScopedName -> Maybe RDFDatatype +findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes) + +------------------------------------------------------------ +-- Declare datatype subtypes map +------------------------------------------------------------ + +{- +allDatatypeSubtypes :: [xxx] +allDatatypeSubtypes = [] +-- [[[details TBD]]] +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/BuiltInMap.hs b/Swish/RDF/BuiltInMap.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/BuiltInMap.hs @@ -0,0 +1,52 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : BuiltInMap +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- datatypes, variable binding modifiers and variable binding filters +-- built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltInMap + ( findRDFOpenVarBindingModifier + , findRDFDatatype + , rdfRulesetMap + , allRulesets, allDatatypeRulesets + ) +where + +import Swish.RDF.BuiltInDatatypes +import Swish.RDF.BuiltInRules + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/BuiltInRules.hs b/Swish/RDF/BuiltInRules.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/BuiltInRules.hs @@ -0,0 +1,162 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : BuiltInRules +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module collects references and provides access to all of the +-- rulesets, variable binding modifiers and variable binding filters +-- built in to Swish. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.BuiltInRules + ( findRDFOpenVarBindingModifier + , rdfRulesetMap + , allRulesets, allDatatypeRulesets + ) +where + +import Swish.RDF.BuiltInDatatypes + ( allDatatypes ) + +import Swish.RDF.RDFVarBinding + ( RDFOpenVarBindingModify + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) + +import Swish.RDF.RDFRuleset + ( RDFRuleset, RDFRulesetMap ) + +import Swish.RDF.RDFProofContext + ( rulesetRDF + , rulesetRDFS + , rulesetRDFD ) + +import Swish.RDF.VarBinding + ( nullVarBindingModify + , makeVarFilterModify + , varFilterEQ, varFilterNE + ) + +import Swish.RDF.Datatype + ( typeRules + , typeMkModifiers + ) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , mapFindMaybe + ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +------------------------------------------------------------ +-- Declare variable binding filters list +------------------------------------------------------------ + +-- |List of rdfOpenVarBindingModify values for predefined filters +-- +rdfVarBindingFilters :: [RDFOpenVarBindingModify] +rdfVarBindingFilters = + [ filter1 rdfVarBindingUriRef + , filter1 rdfVarBindingBlank + , filter1 rdfVarBindingLiteral + , filter1 rdfVarBindingUntypedLiteral + , filter1 rdfVarBindingTypedLiteral + , filter1 rdfVarBindingXMLLiteral + , filter1 rdfVarBindingMemberProp + , filter2 rdfVarBindingDatatyped + -- , filterN nullVarBindingModify + , filter2 varFilterEQ + , filter2 varFilterNE + ] + where + filter1 f lbs = makeVarFilterModify $ f (head lbs) + filter2 f lbs = makeVarFilterModify $ f (head lbs) (lbs!!1) + -- filterN f lbs = makeVarFilterModify $ f ... + +------------------------------------------------------------ +-- Declare variable binding modifiers map +------------------------------------------------------------ + +rdfVarBindingModifiers :: [RDFOpenVarBindingModify] +rdfVarBindingModifiers = + [ nullVarBindingModify + ] + +------------------------------------------------------------ +-- Find a named built-in OpenVarBindingModifier +------------------------------------------------------------ + +allOpenVarBindingModify :: [RDFOpenVarBindingModify] +allOpenVarBindingModify = + rdfVarBindingFilters ++ + rdfVarBindingModifiers ++ + dtsVarBindingModifiers + +dtsVarBindingModifiers :: [RDFOpenVarBindingModify] +-- dtsVarBindingModifiers = concatMap dtVarBindingModifiers allDatatypes +dtsVarBindingModifiers = concatMap typeMkModifiers allDatatypes + +{- +dtVarBindingModifiers dtval = + map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval) +-} + +findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify +findRDFOpenVarBindingModifier nam = + mapFindMaybe nam (LookupMap allOpenVarBindingModify) + +------------------------------------------------------------ +-- Lookup map for built-in rulesets +------------------------------------------------------------ + +rdfRulesetMap :: RDFRulesetMap +rdfRulesetMap = LookupMap allRulesets + +allRulesets :: [RDFRuleset] +allRulesets = + [ rulesetRDF + , rulesetRDFS + , rulesetRDFD + ] + ++ allDatatypeRulesets + +allDatatypeRulesets :: [RDFRuleset] +allDatatypeRulesets = map typeRules allDatatypes + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/ClassRestrictionRule.hs b/Swish/RDF/ClassRestrictionRule.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/ClassRestrictionRule.hs @@ -0,0 +1,603 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : ClassRestrictionRule +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses +-- +-- 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.RDF.RDFGraph + ( RDFLabel(..) + , getScopedName + , RDFGraph + , getArcs + , merge + , toRDFGraph, emptyRDFGraph + , Arc(..) + , res_rdf_type + , res_rdfd_maxCardinality + ) + +import Swish.RDF.RDFRuleset + ( RDFRule + , makeRDFGraphFromN3String + ) + +import Swish.RDF.RDFDatatype + ( RDFDatatypeVal + , fromRDFLabel, toRDFLabel + ) + +import Swish.RDF.RDFQuery + ( rdfQueryFind + , rdfFindValSubj, rdfFindPredVal, rdfFindPredInt + , rdfFindList + ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding ) + +import Swish.RDF.Datatype + ( DatatypeVal(..) + , DatatypeRel(..), DatatypeRelFn + ) + +import Swish.RDF.Rule + ( Rule(..) + , bwdCheckInference + ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( namespaceRDFD + ) + +import Swish.Utils.PartOrderedCollection + ( minima, maxima + , partCompareEq, partComparePair + , partCompareListMaybe + , partCompareListSubset + ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , mapFindMaybe + ) + +import Swish.Utils.ListHelpers + ( powerSet ) + +import Data.Maybe (isJust, fromJust, fromMaybe, mapMaybe) + +import Data.List + ( delete, nub, (\\) ) + +import Control.Monad + ( liftM ) + +import Swish.Utils.TraceHelpers + ( trace ) + +------------------------------------------------------------ +-- 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 + } + +instance Eq ClassRestriction where + cr1 == cr2 = crName cr1 == crName cr2 + +instance Show ClassRestriction where + show cr = "ClassRestriction:" ++ show (crName cr) + +instance LookupEntryClass ClassRestriction ScopedName ClassRestriction + where + newEntry (_,fn) = fn + keyVal cr = (crName cr, 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 = + liftM (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 +------------------------------------------------------------ + +ruleQuery :: RDFGraph +ruleQuery = makeRDFGraphFromN3String $ + "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ + " ?c a rdfd:GeneralRestriction ; " ++ + " rdfd:onProperties ?p ; " ++ + " rdfd:constraint ?r . " + +-- Placeholder false graph for now. +falseGraph :: RDFGraph +falseGraph = makeRDFGraphFromN3String $ + "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ + falseGraphStr + +falseGraphStr :: String +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 = + {- + trace "\nmakeRestrictionRule1:" $ + -- seq (traceShow "\ngr:" gr) + seq (traceShow "\nvb:" vb) $ + seq (traceShow "\nc:" c) $ + seq (traceShow "\np:" p) $ + seq (traceShow "\nr:" r) $ + seq (traceShow "\nps:" ps) $ + -- seq (traceShow "\nrn:" rn) $ + -} + 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 res_rdfd_maxCardinality gr + ps = rdfFindList gr p + rn = mapFindMaybe (getScopedName r) (LookupMap crs) + +makeRestrictionRule2 :: + Maybe ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] + -> Maybe RDFRule +makeRestrictionRule2 (Just restriction) cls@(Res cname) props cs = + {- + trace "\nmakeRestrictionRule2:" $ + seq (traceShow "\ncls:" cls) + seq (traceShow "\nprops:" props) $ + -} + 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 _ _ _ _ = + trace "\nmakeRestrictionRule: missing class restriction" + Nothing + +-- Forward apply class restriction. +fwdApplyRestriction :: + ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> [RDFGraph] + -> [RDFGraph] +fwdApplyRestriction restriction cls props cs antgrs = + if isJust newgrs then concat $ fromJust newgrs else [falseGraph] + where + -- Instances of the named class in the graph: + ris = nub $ rdfFindValSubj res_rdf_type 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 = + {- + trace "\nfwdApplyRestriction1:" $ + seq (traceShow "\nci:" ci) + seq (traceShow "\nprops:" props) + seq (traceShow "\nantgr:" 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 = nub [Arc ci p v | vs <- nts, (p,v) <- zip props vs ] + \\ getArcs antgr + newgrs = if 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 res_rdf_type 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 = liftM (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 + {- + trace "\nfwdApplyRestriction1:" $ + seq (traceShow "\nci:" ci) + seq (traceShow "\nprops:" props) + seq (traceShow "\ncongr:" congr) $ + -} + 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 + makeGraphs = map (toRDFGraph . (:[])) . (Arc ci res_rdf_type 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 $ powerSet 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 supplied datatype and graph +------------------------------------------------------------ + +makeRDFDatatypeRestrictionRules :: RDFDatatypeVal vt -> RDFGraph -> [RDFRule] +makeRDFDatatypeRestrictionRules dtval gr = + makeRDFClassRestrictionRules dcrs gr + where + dcrs = map (makeDatatypeRestriction dtval) (tvalRel dtval) + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/Datatype.hs b/Swish/RDF/Datatype.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/Datatype.hs @@ -0,0 +1,1053 @@ +{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Datatype +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : ExistentialQuantification, MultiParamTypeClasses +-- +-- This module defines the structures used by Swish to represent and +-- manipulate datatypes. It is designed as a basis for handling datatyped +-- RDF literals, but the functions in this module are more generic. +-- +-------------------------------------------------------------------------------- + +-- Testing note: this module supports a number of specific datatypes. +-- It is intended that functionality in this module will be tested via +-- modules "Swish.RDF.RDFDatatype", +-- "Swish.RDF.ClassRestrictionRule" and +-- "Swish.RDF.RDFDatatypeXsdInteger". +-- See also module ClassRestrictionRuleTest for test cases. + +module Swish.RDF.Datatype + ( Datatype(..) + , typeName, typeRules, typeMkRules, typeMkModifiers, typeMkCanonicalForm + , getTypeAxiom, getTypeRule + , DatatypeVal(..) + , getDTMod + , getDTRel + , tvalMkCanonicalForm + , DatatypeMap(..) + , DatatypeRel(..), DatatypeRelFn, DatatypeRelPr + , altArgs + , UnaryFnDescr, UnaryFnTable, UnaryFnApply, unaryFnApp + , BinaryFnDescr, BinaryFnTable, BinaryFnApply, binaryFnApp + , BinMaybeFnDescr, BinMaybeFnTable, BinMaybeFnApply, binMaybeFnApp + , ListFnDescr, ListFnTable, ListFnApply, listFnApp + , DatatypeMod(..), ModifierFn + , ApplyModifier + , nullDatatypeMod + -- , applyDatatypeMod + , makeVmod_1_1_inv, makeVmod_1_1 + , makeVmod_2_1_inv, makeVmod_2_1 + , makeVmod_2_0 + , makeVmod_2_2 + , makeVmod_N_1 + , DatatypeSub(..) + ) +where + +import Swish.RDF.Ruleset + ( Ruleset(..) + , getRulesetAxiom, getRulesetRule + ) + +import Swish.RDF.Rule + ( Formula(..) + , Rule(..) + ) + +import Swish.Utils.Namespace + ( ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( swishName ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + , addVarBinding + , VarBindingModify(..), OpenVarBindingModify, nullVarBindingModify + ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , mapFindMaybe + ) + +import Swish.Utils.ListHelpers + ( flist + , deleteIndex + ) + +import Data.Maybe( isJust, catMaybes ) + +import Control.Monad( join, liftM ) + +------------------------------------------------------------ +-- Datatype framework +------------------------------------------------------------ + +-- |Datatype wraps a 'DatatypeVal' value, hiding the value type that +-- is used only in implementations of the datatype. +-- Users see just the datatype name and associated ruleset. +-- +data Datatype ex lb vn = forall vt . Datatype (DatatypeVal ex vt lb vn) + +instance LookupEntryClass + (Datatype ex lb vn) ScopedName (Datatype ex lb vn) + where + newEntry (_,dt) = dt + keyVal dt = (typeName dt, dt) + +-- |Get type name from Datatype value +typeName :: Datatype ex lb vn -> ScopedName +typeName (Datatype dtv) = tvalName dtv + +-- |Get static rules from Datatype value +typeRules :: Datatype ex lb vn -> Ruleset ex +typeRules (Datatype dtv) = tvalRules dtv + +-- |Make rules for Datatype value based on supplied expression +typeMkRules :: Datatype ex lb vn -> ex -> [Rule ex] +typeMkRules (Datatype dtv) = tvalMkRules dtv + +-- |Make variable binding modifiers based on values supplied +typeMkModifiers :: Datatype ex lb vn -> [OpenVarBindingModify lb vn] +typeMkModifiers (Datatype dtv) = tvalMkMods dtv + +-- |Get named axiom from Datatype value +getTypeAxiom :: ScopedName -> Datatype ex lb vn -> Maybe (Formula ex) +getTypeAxiom nam dt = getRulesetAxiom nam (typeRules dt) + +-- |Get named rule from Datatype value +getTypeRule :: ScopedName -> Datatype ex lb vn -> Maybe (Rule ex) +getTypeRule nam dt = getRulesetRule nam (typeRules dt) + +-- |Get canonical form of datatype value +typeMkCanonicalForm :: Datatype ex lb vn -> String -> Maybe String +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 (whos 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@. + } + +-- Other accessor functions + +getDTRel :: + ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt) +getDTRel nam dtv = + mapFindMaybe nam (LookupMap (tvalRel dtv)) + +getDTMod :: + ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) +getDTMod nam dtv = + mapFindMaybe nam (LookupMap (tvalMod dtv)) + +-- |Get canonical form of datatype value, or @Nothing@. +-- +tvalMkCanonicalForm :: DatatypeVal ex vt lb vn -> String -> Maybe String +tvalMkCanonicalForm dtv str = can + where + dtmap = tvalMap dtv + val = mapL2V dtmap str + can = join $ liftM (mapV2L dtmap) val + +-- |DatatypeMap consists of methods that perform lexical-to-value +-- and value-to-canonical-lexical mappings for a datatype. +-- +-- The datatype mappings apply to string lexical forms. +-- +data DatatypeMap vt = DatatypeMap + { mapL2V :: String -> Maybe vt + -- ^ Function to map lexical string to + -- 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 String + -- ^ Function to map a value to its canonical + -- lexical form, if it has such. + } + +-- |Type for a datatype relation inference function. +-- +-- A datatype relation defines tuples of values that satisfy some +-- relation. A datatype relation inference function calculates +-- values that complete a relation with values supplied. +-- +-- The function accepts a list of @Maybe vt@, where vt is the +-- datatype value type. It returns one of: +-- +-- * Just a list of lists, where each inner list returned is a +-- complete set of values, including the values supplied, that +-- are in the relation. +-- +-- * Just an empty list is returned if the supplied values are +-- insufficient to compute any complete sets of values in the +-- relation. +-- +-- * Nothing if the supplied values are not consistent with +-- the relation. +-- +type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]] + +-- |Type for datatype relation predicate: accepts a list of values +-- and determines whether or not they satisfy the relation. +-- +type DatatypeRelPr vt = [vt] -> Bool + +-- |Datatype for a named relation on values of a datatype. +-- +data DatatypeRel vt = DatatypeRel + { dtRelName :: ScopedName + , dtRelFunc :: DatatypeRelFn vt + } + +instance LookupEntryClass (DatatypeRel vt) ScopedName (DatatypeRel vt) + where + newEntry (_,relf) = relf + keyVal dtrel = (dtRelName dtrel, dtrel) + +-- |Datatype value modifier functions type +-- +-- Each function accepts a list of values and returns a list of values. +-- The exact significance of the different values supplied and returned +-- depends on the variable binding pattern used (cf. 'ApplyModifier'), +-- but in all cases an empty list returned means that the corresponding +-- inputs are not consistent with the function and cannot be used. +-- +type ModifierFn vn = [vn] -> [vn] + +-- |Type of function used to apply a data value modifier to specified +-- variables in a supplied variable binding. It also accepts the +-- name of the datatype modifier and carries it into the resulting +-- variable binding modifier. +-- +-- (Note that @vn@ is not necessarily the same as @vt@, the datatype value +-- type: the modifier functions may be lifted or otherwise adapted +-- to operate on some other type from which the raw data values are +-- extracted.) +-- +type ApplyModifier lb vn = + ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + +-- |Wrapper for data type variable binding modifier included in +-- a datatype value. +-- +data DatatypeMod vt lb vn = DatatypeMod + { dmName :: ScopedName + , dmModf :: [ModifierFn vt] + , dmAppf :: ApplyModifier lb vn + } + +instance LookupEntryClass + (DatatypeMod vt lb vn) ScopedName (DatatypeMod vt lb vn) + where + newEntry (_,dmod) = dmod + keyVal dmod = (dmName dmod, dmod) + +-- |Null datatype value modifier +nullDatatypeMod :: DatatypeMod vt lb vn +nullDatatypeMod = DatatypeMod + { dmName = swishName "nullDatatypeMod" + , dmModf = [] + , dmAppf = nullAppf + } + where + -- nullAppf :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + nullAppf nam _ lbs = (nullVarBindingModify lbs) { vbmName = nam } + +{- +-- |Apply datatype variable binding modifier value to list of labels and +-- a variable binding. +applyDatatypeMod :: (Eq lb, Show lb, Eq vn, Show vn) + => DatatypeMod vt lb vn -> OpenVarBindingModify lb vn +applyDatatypeMod dtmod = dmAppf dtmod (dmName dtmod) (dmModf dtmod) +-} + +{- +dmName dtmod :: ScopedName +dmModf dtmod :: [ModifierFn vt] + :: [[vt] -> [vt]] +dmAppf dtmod :: ApplyModifier lb vn + :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn + :: ScopedName -> [[vn] -> [vn]] -> OpenVarBindingModify lb vn +dmAppf dtmod (dmName dtmod) + :: [[vn] -> [vn]] -> OpenVarBindingModify lb vn +-} + +-------------------------------------------------------------- +-- Functions for creating datatype variable binding modifiers +-------------------------------------------------------------- + +-- |'ApplyModifier' function for use with 'DatatypeMod' in cases +-- when the value mapping is a @1->1@ function and inverse, such +-- as negate. +-- +-- [@nam@] is the name from the 'DatatypeMod' value that is carried into +-- the resulting variable binding modifier. +-- +-- [@fns@] are functions used to implement details of the variable +-- binding modifier: +-- +-- (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any +-- new variable bindings), returning a non-empty list if @x@ and @y@ +-- are in the appropriate relationship. +-- +-- (1) is @[y] -> [x]@, used to perform the calculation in a forward +-- direction. +-- +-- (2) is @[x] -> [y]@, used to perform the calculation in a backward +-- direction. This may be the same as (2) (e.g. for negation) +-- or may be different (e.g. increment). +-- +-- [@lbs@] is a list of specific label values for which a variable binding +-- modifier will be generated. (The intent is that a variable-free +-- value can be generated as a Curried function, and instantiated +-- for particular variables as required.) +-- +-- Note: an irrefutable pattern match for @lbs@ is used so that a name +-- for the 'VarBindingModify' value can be extracted using an undefined +-- label value. +-- +makeVmod_1_1_inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_1_1_inv 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 _ _ = [] +makeVmod_1_1_inv _ _ _ = + error "makeVmod_1_1_inv: 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. +-- +makeVmod_1_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_1_1 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 _ _ = [] +makeVmod_1_1 _ _ _ = + error "makeVmod_1_1: 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. +-- +makeVmod_2_1_inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_2_1_inv 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 _ _ = [] +makeVmod_2_1_inv _ _ _ = + error "makeVmod_2_1_inv: 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. +-- +makeVmod_2_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_2_1 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 _ _ = [] +makeVmod_2_1 _ _ _ = + error "makeVmod_2_1: 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. +-- +makeVmod_2_0 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_2_0 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 _ _ = [] +makeVmod_2_0 _ _ _ = + error "makeVmod_2_0: 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. +-- +makeVmod_2_2 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_2_2 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 _ _ = [] +makeVmod_2_2 _ _ _ = + error "makeVmod_2_2: 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. +-- +makeVmod_N_1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn +makeVmod_N_1 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 + +makeVmod_N_1 _ _ _ = + error "makeVmod_N_1: requires 2 functions and at 1 or more labels" + +-------------------------------------------------------- +-- Local helper functions for makeVmodXXX variants +-------------------------------------------------------- + +-- Add value to variable variable binding, if value is singleton list, +-- otherwise return empty list. +addv :: (Eq lb, Show lb, Eq vt, Show vt) + => lb -> [vt] -> VarBinding lb vt + -> [VarBinding lb vt] +addv lb [val] vbind = [addVarBinding lb val vbind] +addv _ _ _ = [] + +-- Add two entries to variable variable binding, if value supplied is +-- a doubleton list, otherwise return empty list. +addv2 :: (Eq lb, Show lb, Eq vt, Show vt) + => lb -> lb -> [vt] -> VarBinding lb vt + -> [VarBinding lb vt] +addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $ + addVarBinding lb2 val2 vbind] +addv2 _ _ _ _ = [] + +-- If supplied value is non-empty list return supplied variable binding, +-- otherwise return empty list. +selv :: [vt] -> varBinding lb vt -> [varBinding lb vt] +selv [] _ = [] +selv _ vbind = [vbind] + +-------------------------------------------------------------- +-- Functions for evaluating arguments in a datatype relation +-------------------------------------------------------------- +-- +-- altArgs is a generic function for evaluating datatype relation +-- values, based on suppied functions and argument values +-- +-- UnaryFnDescr, UnaryFnApply and unaryFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on unary functions (binary relations). +-- +-- BinaryFnDescr, BinaryFnApply and binaryFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on binary functions (3-way relations). +-- +-- ListFnDescr, ListFnApply and listFnApp: +-- are support types and function for using altArgs to +-- evaluate relations on list functions (n-way relations), +-- where the first member of the list is the value of a +-- fold of a function over the rest of the list. +-- +-- See experimental module spike-altargs.hs for test cases and +-- development steps for this function. + +-- |Given a list of argument values and a list of functions for +-- calculating new values from supplied values, return a list +-- of argument values, or @Nothing@ if the supplied values are +-- inconsistent with the calculations specified. +-- +-- Each list of values returned corresponds to a set of values that +-- satisfy the relation, consistent with the values supplied. +-- +-- Functions are described as tuple consisting of: +-- +-- (a) a predicate that the argument is required to satisfy +-- +-- (b) a function to apply, +-- +-- (c) a function to apply function (b) to a list of arguments +-- +-- (d) argument list index values to which the function is applied. +-- +-- Each supplied argument is of the form @Maybe a@, where the argument +-- has value type a. @Nothing@ indicates arguments of unknown value. +-- +-- The basic idea is that, for each argument position in the relation, +-- a function may be supplied to calculate that argument's possible values +-- from some combination of the other arguments. The results calculated +-- in this way are compared with the original arguments provided: +-- if the values conflict then the relation is presumed to be +-- unsatisfiable with the supplied values, and @Nothing@ is returned; +-- if there are any calculated values for arguments supplied without +-- any values, then tbe calculated values are used. +-- If there are any arguments for which no values are supplied or +-- calculated, then the relation is presumed to be underdetermined, +-- and @Just []@ is returned. +-- +-- [@fnss@] is 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.) +-- +-- [@apfn@] is 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. +-- The value used must match the type of @fnss@ used. +-- +-- Returns a @'DatatypeRelFn' vt@ value that can be used as the +-- 'dtRelFunc' component of a 'DatatypeRel' value. +-- +altArgs :: (Eq vt) + => DatatypeRelPr vt -> [(vt->Bool,[b])] + -> ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) + -> DatatypeRelFn vt +altArgs pr fnss apfn args = cvals4 cvals3 + where + -- Calculate new value(s) for each argument from supplied values, and + -- lift inconsistency indicator (Just/Nothing) to outermost Monad. + -- cvals1 :: [Maybe [vt]] + cvals1 = flist (map (applyFdescToTuple apfn) fnss) args + -- Merge calculated values with supplied arguments, and again + -- lift inconsistency indicator (Just/Nothing) to outermost Monad. + -- cvals2 :: Maybe [[vt]] + cvals2 = sequence $ mergeTupleVals (map fst fnss) args cvals1 + -- Map list of alternative values for each tuple member to + -- a list of alternative tuples. + cvals3 = liftM sequence cvals2 + -- Check each tuple against the supplied predicate. + -- If any of the alternative tuples does not match the predicate + -- then signal an inconsistency. + cvals4 Nothing = Nothing + cvals4 cvs@(Just ts) = if all pr ts then cvs else Nothing + +-- Perform alternative calculations for single result value +-- Each result value is a list of zero or more alternatives +-- that can be calculated from available parameters, or +-- Nothing if the available parameters are inconsistent. +-- +-- apfn is the function that actually applies an element of +-- the function descriptor to a tuple of Maybe arguments +-- (where Nothing is used to indicate an unknown value) +-- (p,fns) is a pair consisting of a value-checking predicate +-- for the corresponding tuple member, and a list of +-- function descriptors that each return one or more +-- values the tuple member, calculated from other values +-- that are present. Just [] means no values are +-- calculated for this member, and Nothing means the +-- calculation has detected tuple values supplied that +-- are inconsistent with the datatype relation concerned. +-- args is a tuple of Maybe tuple elements, (where Nothing +-- indicates an unknown value). +-- +-- Returns Maybe a list of alternative values for the member, +-- Just [] to indicate insufficient information to calculate +-- any new values, and Nothing to indicate an inconsistency. +-- +applyFdescToTuple :: + ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) -> (vt->Bool,[b]) -> [Maybe vt] + -> Maybe [vt] +applyFdescToTuple apfn (p,fns) args = + liftM concat $ sequence cvals + where + -- cvals :: [Maybe [vt]] + cvals = flist (map (apfn p) fns) args + +-- Merge calculated tuple values with supplied tuple, checking for consistency. +-- +-- ps predicates used for isolated validation of each tuple member +-- args supplied tuple values, with Nothing for unknown values +-- cvals list of alternative calculated values for each tuple member, +-- or Nothing if an inconsistency has been detected by the +-- tuple-calculation functions. Note that this list may contain +-- more entries than args; the surplus entries are ignored +-- (see list functions for how this is used). +-- +-- Returns a tuple of Maybe lists of values for each tuple member, +-- containing Nothing if an inconsistency has been detected in the +-- supplied values. +-- +mergeTupleVals :: (Eq a) => [a->Bool] -> [Maybe a] -> [Maybe [a]] -> [Maybe [a]] +mergeTupleVals _ _ (Nothing:_) = [Nothing] +mergeTupleVals (_:ps) (Nothing:a1s) (Just a2s:a2ss) + = Just a2s:mergeTupleVals ps a1s a2ss +mergeTupleVals (p:ps) (Just a1:a1s) (Just []:a2ss) + | p a1 = Just [a1]:mergeTupleVals ps a1s a2ss + | otherwise = [Nothing] +mergeTupleVals (p:ps) (Just a1:a1s) (Just a2s:a2ss) + | p a1 && elem a1 a2s = Just [a1]:mergeTupleVals ps a1s a2ss + | otherwise = [Nothing] +mergeTupleVals _ [] _ = [] +mergeTupleVals _ _ _ = [Nothing] + +-- |'altArgs' support for unary functions: function descriptor type +type UnaryFnDescr a = (a->a,Int) + +-- |'altArgs' support for unary functions: function descriptor table type +type UnaryFnTable a = [(a->Bool,[UnaryFnDescr a])] + +-- |'altArgs' support for unary functions: function applicator type +type UnaryFnApply a = (a->Bool) -> UnaryFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for unary functions: function applicator +unaryFnApp :: UnaryFnApply a +unaryFnApp p (f1,n) args = apf (args!!n) + where + apf (Just a) = if p r then Just [r] else Nothing where r = f1 a + apf Nothing = Just [] + +-- |'altArgs' support for binary functions: function descriptor type +type BinaryFnDescr a = (a->a->a,Int,Int) + +-- |'altArgs' support for binary functions: function descriptor table type +type BinaryFnTable a = [(a->Bool,[BinaryFnDescr a])] + +-- |'altArgs' support for binary functions: function applicator type +type BinaryFnApply a = + (a->Bool) -> BinaryFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for binary functions: function applicator +binaryFnApp :: BinaryFnApply a +binaryFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) + where + apf (Just a1) (Just a2) = if p r then Just [r] else Nothing + where r = f a1 a2 + apf _ _ = Just [] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function descriptor type +type BinMaybeFnDescr a = (a->a->Maybe [a],Int,Int) + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function descriptor table type +type BinMaybeFnTable a = [(a->Bool,[BinMaybeFnDescr a])] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function applicator type +type BinMaybeFnApply a = + (a->Bool) -> BinMaybeFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for binary function with provision for indicating +-- inconsistent supplied values: function applicator +binMaybeFnApp :: BinMaybeFnApply a +binMaybeFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2) + where + apf (Just a1) (Just a2) = if pm r then r else Nothing + where + r = f a1 a2 + pm Nothing = False + pm (Just x) = all p x + apf _ _ = Just [] + +-- |'altArgs' support for list functions (e.g. sum over list of args), +-- where first element of list is a fold over the rest of the list, +-- and remaining elements of list can be calculated in terms +-- of the result of the fold and the remaining elements +-- +-- List function descriptor is +-- +-- (a) list-fold function, f (e.g. (+) +-- +-- (b) list-fold identity, z (e.g. 0) +-- +-- (c) list-fold-function inverse, g (e.g. (-)) +-- +-- (d) index of element to evaluate +-- +-- such that: +-- +-- > (a `f` z) == (z `f` a) == a +-- > (a `g` c) == b <=> a == b `f` c +-- > (a `g` z) == a +-- > (a `g` a) == z +-- +-- and the result of the folded function does not depend on +-- the order that the list elements are processed. +-- +-- NOTE: the list of 'ListFnDescr' values supplied to 'altArgs' must +-- be at least as long as the argument list. In many cases, Haskell +-- lazy evaluation can be used to supply an arbitrarily long list. +-- See test cases in spike-altargs.hs for an example. +-- +-- Function descriptor type +type ListFnDescr a = (a->a->a,a,a->a->a,Int) + +-- |Function table type +type ListFnTable a = [(a->Bool,[ListFnDescr a])] + +-- |'altArgs' support for list functions: function applicator type +type ListFnApply a = (a->Bool) -> ListFnDescr a -> [Maybe a] -> Maybe [a] + +-- |'altArgs' support for list functions: function applicator +listFnApp :: ListFnApply a +listFnApp p (f,z,g,n) (a0:args) + | n == 0 = + app $ foldr (apf f) (Just [z]) args + | otherwise = + app $ apf g a0 (foldr (apf f) (Just [z]) (args `deleteIndex` (n-1))) + where + apf :: (a->a->a) -> Maybe a -> Maybe [a] -> Maybe [a] + apf fn (Just a1) (Just [a2]) = Just [fn a1 a2] + apf _ _ _ = Just [] + + -- app :: Maybe [a] -> Maybe [a] + app Nothing = Nothing + app r@(Just [a]) = if p a then r else Nothing + app _ = Just [] + +listFnApp _ _ [] = error "listFnApp called with an empty list" -- -Wall + +-------------------------------------------------------- +-- Datatype sub/supertype description +-------------------------------------------------------- + +-- |Describe a subtype/supertype relationship between a pair of datatypes. +-- +-- Originally, I had this as a supertype field of the DatatypeVal structure, +-- but that suffered from some problems: +-- +-- * supertypes may be introduced retrospectively, +-- +-- * the relationship expressed with respect to a single datatype +-- cannot indicate hiow to do injections/restrictions between the +-- underlying value types. +-- +-- [@ex@] is the type of expression with which the datatype may be used. +-- +-- [@lb@] is the type of the variable labels used. +-- +-- [@vn@] is the type of value node used to contain a datatyped value +-- +-- [@supvt@] is the internal value type of the super-datatype +-- +-- [@subvt@] is the internal value type of the sub-datatype +-- +data DatatypeSub ex lb vn supvt subvt = DatatypeSub + { trelSup :: DatatypeVal ex supvt lb vn + -- ^ Datatype that is a supertype of @trelSub@, + -- having value space @supvt@. + , trelSub :: DatatypeVal ex subvt lb vn + -- ^ Datatype that is a subtype of @trelSup@, + -- having value space @supvt@. + , trelToSup :: subvt -> supvt + -- ^ Function that maps subtype value to + -- corresponding supertype value. + , trelToSub :: supvt -> Maybe subvt + -- ^ Function that maps supertype value to + -- corresponding subtype value, if there + -- is such a value. + } + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/GraphClass.hs b/Swish/RDF/GraphClass.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/GraphClass.hs @@ -0,0 +1,180 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphClass +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : DeriveFunctor, DeriveFoldable, DeriveTraversable, MultiParamTypeClasses +-- +-- This module defines a Labelled Directed Graph and Label classes, +-- and the Arc datatype. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Define LDGraph, arc and related classes and types +------------------------------------------------------------ + +module Swish.RDF.GraphClass + ( LDGraph(..), replaceArcs + , Label(..) + , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple + , Selector + , hasLabel, arcLabels + ) +where + +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +import Data.List (union, (\\)) + +-------------------------------- +-- Labelled Directed Graph class +-------------------------------- +-- +-- Minimum required implementation: setArcs, getArcs +-- +-- 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. +class (Eq (lg lb), Eq lb ) => LDGraph lg lb + where + -- empty graph + -- emptyGr :: lg lb [[[TODO?]]] + -- component-level operations + setArcs :: [Arc lb] -> lg lb -> lg lb -- setarcs [arcs] in g2 -> g3 + getArcs :: lg lb -> [Arc lb] -- g1 -> [arcs] + -- extract arcs from a graph + extract :: Selector lb -> lg lb -> lg lb -- select f1 from g2 -> g3 + extract sel = update (filter sel) + -- graph-level operations + add :: lg lb -> lg lb -> lg lb -- g1 + g2 -> g3 + add addg = update (union (getArcs addg)) + delete :: lg lb -> lg lb -> lg lb -- g2 - g1 -> g3 + delete delg = update (\\ getArcs delg) + -- enumerate distinct labels contained in a graph + labels :: lg lb -> [lb] -- g1 -> [labels] + labels g = foldl union [] (map arcLabels (getArcs g)) + -- enumerate distinct labels contained in a graph + nodes :: lg lb -> [lb] -- g1 -> [labels] + nodes g = foldl union [] (map arcNodes (getArcs g)) + -- test for graph containment in another + containedIn :: lg lb -> lg lb -> Bool -- g1 <= g2? + -- g1 update arcs in a graph using a supplied function: + update :: ( [Arc lb] -> [Arc lb] ) -> lg lb -> lg lb + update f g = setArcs ( f (getArcs g) ) g + +-- |Function to replace arcs in a graph with a given list of arcs +replaceArcs :: (LDGraph lg lb) => lg lb -> [Arc lb] -> lg lb +replaceArcs gr as = update (const as) gr + +--------------- +-- Label class +--------------- +-- +-- A label may have a fixed binding, which means that the label identifies (is) a +-- particular graph node, and different such labels are always distinct nodes. +-- Alternatively, a label may be unbound (variable), which means that it is a +-- placeholder for an unknown node label. Unbound node labels are used as +-- graph-local identifiers for indicating when the same node appears in +-- several arcs. +-- +-- For the purposes of graph-isomorphism testing, fixed labels are matched when they +-- are the same. Variable labels may be matched with any other variable label. +-- Our definition of isomorphism (for RDF graphs) does not match variable labels +-- with fixed labels. + +class (Eq lb, Show lb, Ord lb) => Label lb where + labelIsVar :: lb -> Bool -- does this node have a variable binding? + labelHash :: Int -> lb -> Int -- calculate hash of label using supplied seed + getLocal :: lb -> String -- extract local id from variable node + makeLabel :: String -> lb -- make label value given local id + -- compare :: lb -> lb -> Ordering + -- compare l1 l2 = compare (show l1) (show l2) + +------------ +-- Arc type +------------ + +data Arc lb = Arc { asubj, apred, aobj :: lb } + deriving (Eq, Functor, F.Foldable, T.Traversable) + +arcSubj :: Arc lb -> lb +arcSubj = asubj + +arcPred :: Arc lb -> lb +arcPred = apred + +arcObj :: Arc lb -> lb +arcObj = aobj + +arc :: lb -> lb -> lb -> Arc lb +arc = Arc + +arcToTriple :: Arc lb -> (lb,lb,lb) +arcToTriple a = (asubj a,apred a,aobj a) + +arcFromTriple :: (lb,lb,lb) -> Arc lb +arcFromTriple (s,p,o) = Arc s p o + +instance Ord lb => Ord (Arc lb) where + compare (Arc s1 p1 o1) (Arc s2 p2 o2) + | cs /= EQ = cs + | cp /= EQ = cp + | otherwise = co + where + cs = compare s1 s2 + cp = compare p1 p2 + co = compare o1 o2 + + (Arc s1 p1 o1) <= (Arc s2 p2 o2) + | s1 /= s2 = s1 <= s2 + | p1 /= p2 = p1 <= p2 + | otherwise = o1 <= o2 + +instance (Show lb) => Show (Arc lb) where + show (Arc lb1 lb2 lb3) = + "("++ show lb1 ++","++ show lb2 ++","++ show lb3 ++")" + +type Selector lb = Arc lb -> Bool + +hasLabel :: (Eq lb) => lb -> Arc lb -> Bool +hasLabel lbv (Arc lb1 lb2 lb3) = lbv `elem` [lb1, lb2, lb3] + +arcLabels :: Arc lb -> [lb] +arcLabels (Arc lb1 lb2 lb3) = [lb1,lb2,lb3] + +arcNodes :: Arc lb -> [lb] +arcNodes (Arc lb1 _ lb3) = [lb1,lb3] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/GraphMatch.hs b/Swish/RDF/GraphMatch.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/GraphMatch.hs @@ -0,0 +1,612 @@ +{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphMatch +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses +-- +-- This module contains graph-matching logic. +-- +-- The algorithm used is derived from a paper on RDF graph matching +-- by Jeremy Carroll [1]. +-- +-- [1] +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.GraphMatch + ( graphMatch, + -- The rest exported for testing only + 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.Utils.LookupMap +import Swish.Utils.ListHelpers +import Swish.Utils.MiscHelpers +-- import Swish.Utils.TraceHelpers( trace, traceShow ) +import Swish.RDF.GraphClass +import Data.Ord (comparing) +import Data.List( nub, sortBy, partition ) +import qualified Data.List + +-------------------------- +-- Label index value type +-------------------------- +-- + +-- | LabelIndex is a unique value assigned to each label, such that +-- labels with different values are definitely different values +-- in the graph; e.g. do not map to each other in the graph +-- bijection. The first member is a generation counter that +-- ensures new values are distinct from earlier passes. + +type LabelIndex = (Int,Int) + +nullLabelVal :: LabelIndex +nullLabelVal = (0,0) + +----------------------- +-- Label mapping types +----------------------- + +data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv + +type LabelEntry lb = GenLabelEntry lb LabelIndex + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => LookupEntryClass (GenLabelEntry lb lv) lb lv where + keyVal (LabelEntry k v) = (k,v) + newEntry (k,v) = LabelEntry k v + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => Show (GenLabelEntry lb lv) where + show = entryShow + +instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) + => Eq (GenLabelEntry lb lv) where + (==) = entryEq + +-- | Type for label->index lookup table +data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = + LabelMap Int (LookupMap (GenLabelEntry lb lv)) + +type LabelMap lb = GenLabelMap lb LabelIndex + +instance (Label lb) => Show (LabelMap lb) where + show = showLabelMap + +instance (Label lb) => Eq (LabelMap lb) where + LabelMap gen1 lmap1 == LabelMap gen2 lmap2 = + gen1 == gen2 && es1 `equiv` es2 + where + es1 = listLookupMap lmap1 + es2 = listLookupMap lmap2 + +emptyMap :: (Label lb) => LabelMap lb +emptyMap = LabelMap 1 $ makeLookupMap [] + +-------------------------- +-- Equivalence class type +-------------------------- +-- + +-- | Type for equivalence class description +-- (An equivalence class is a collection of labels with +-- the same LabelIndex value.) + +type EquivalenceClass lb = (LabelIndex,[lb]) + +{- +ecIndex :: EquivalenceClass lb -> LabelIndex +ecIndex = fst +-} + +ecLabels :: EquivalenceClass lb -> [lb] +ecLabels = snd + +{- +ecSize :: EquivalenceClass lb -> Int +ecSize = length . ecLabels +-} + +ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb +ecRemoveLabel (lv,ls) l = (lv,Data.List.delete l ls) + +------------------------------------------------------------ +-- Augmented graph label value - for graph matching +------------------------------------------------------------ +-- +-- | This instance of class label adds a graph identifier to +-- each variable label, so that variable labels from +-- different graphs are always seen as distinct values. +-- +-- The essential logic added by this class instance is embodied +-- in the eq and hash functions. Note that variable label hashes +-- depend only on the graph in which they appear, and non-variable +-- label hashes depend only on the variable. Label hash values are +-- used when initializing a label equivalence-class map (and, for +-- non-variable labels, also for resolving hash collisions). + +data (Label lb) => ScopedLabel lb = ScopedLabel Int lb + +makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb +makeScopedLabel = ScopedLabel + +makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb) +makeScopedArc scope a1 = arc (s arcSubj a1) (s arcPred a1) (s arcObj a1) + where + s f a = ScopedLabel scope (f a) + +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 = hash seed $ show scope ++ "???" + | otherwise = labelHash seed lab + +instance (Label lb) => Eq (ScopedLabel lb) where + (ScopedLabel s1 l1) == (ScopedLabel s2 l2) + = l1 == l2 && s1 == s2 + +instance (Label lb) => Show (ScopedLabel lb) where + show (ScopedLabel s1 l1) = show s1 ++ ":" ++ show l1 + +instance (Label lb) => Ord (ScopedLabel lb) where + compare (ScopedLabel s1 l1) (ScopedLabel s2 l2) = + case compare s1 s2 of + LT -> LT + EQ -> compare l1 l2 + GT -> GT + +-- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ? + +-- | Graph matching function accepting two lists of arcs and +-- returning a node map if successful +-- +graphMatch :: (Label lb) => + (lb -> lb -> Bool) + -- ^ a function that tests for additional constraints + -- that may prevent the matching of a supplied pair + -- of nodes. Returns `True` if the supplied nodes may be + -- matched. (Used in RDF graph matching for checking + -- that formula assignments are compatible.) + -> [Arc lb] -- ^ the first graph to be compared, as a list of arcs + -> [Arc lb] -- ^ the second graph to be compared, as a list of arcs + -> (Bool,LabelMap (ScopedLabel lb)) + -- ^ If the first element is `True` then the secondelement maps each label + -- to an equivalence class identifier, otherwise it is just + -- `emptyMap`. + -- +graphMatch matchable gs1 gs2 = + let + sgs1 = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1 + sgs2 = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2 + ls1 = {- traceShow "ls1 " $ -} graphLabels sgs1 + ls2 = {- traceShow "ls2 " $ -} graphLabels sgs2 + lmap = {- traceShow "lmap " $ -} + newGenerationMap $ + assignLabelMap ls1 $ + assignLabelMap ls2 emptyMap + ec1 = {- traceShow "ec1 " $ -} equivalenceClasses lmap ls1 + ec2 = {- traceShow "ec2 " $ -} equivalenceClasses lmap ls2 + ecpairs = zip (pairSort ec1) (pairSort ec2) + matchableScoped (ScopedLabel _ l1) (ScopedLabel _ l2) = matchable l1 l2 + match = graphMatch1 False matchableScoped sgs1 sgs2 lmap ecpairs + in + if length ec1 /= length ec2 then (False,emptyMap) else match + +-- | Recursive graph matching function +-- +-- This function assumes that no variable label appears in both graphs. +-- (Function `graphMatch`, which calls this, ensures that all variable +-- labels are distinct.) +-- +-- TODO: +-- +-- * replace Equivalence class pair by @(index,[lb],[lb])@ ? +-- +-- * possible optimization: the `graphMapEq` test should be +-- needed only if `graphMatch2` has been used to guess a +-- mapping; either: +-- a) supply flag saying guess has been used, or +-- b) move test to `graphMatch2` and use different +-- test to prevent rechecking for each guess used. +-- + +graphMatch1 :: + (Label lb) + => Bool + -- ^ `True` if a guess has been used before trying this comparison, + -- `False` if nodes are being matched without any guesswork + -> (lb -> lb -> Bool) + -- ^ Test for additional constraints that may prevent the matching + -- of a supplied pair of nodes. Returns `True` if the supplied + -- nodes may be matched. + -> [Arc lb] + -- ^ (@gs1@ argument) + -- first of two lists of arcs (triples) to be compared + -> [Arc lb] + -- ^ (@gs2@ argument) + -- secind of two lists of arcs (triples) to be compared + -> LabelMap lb + -- ^ the map so far used to map label values to equivalence class + -- values + -> [(EquivalenceClass lb,EquivalenceClass lb)] + -- ^ (the @ecpairs@ argument) list of pairs of corresponding + -- equivalence classes of nodes from @gs1@ and @gs2@ that have not + -- been confirmed in 1:1 correspondence with each other. Each + -- pair of equivalence classes contains nodes that must be placed + -- in 1:1 correspondence with each other. + -- + -> (Bool,LabelMap lb) + -- ^ the pair @(match, map)@ where @match@ is @True@ if the supplied + -- sets of arcs can be matched, in which case @map@ is a + -- corresponding map from labels to equivalence class identifiers. + -- When @match@ is @False@, @map@ is the most detailed equivalence + -- class map obtained before a mismatch was detected or a guess + -- was required -- this is intended to help identify where the + -- graph mismatch may be. +graphMatch1 guessed matchable gs1 gs2 lmap ecpairs = + let + (secs,mecs) = partition uniqueEc ecpairs + uniqueEc ( (_,[_]) , (_,[_]) ) = True + uniqueEc ( _ , _ ) = False + + doMatch ( (_,[l1]) , (_,[l2]) ) = labelMatch matchable lmap l1 l2 + doMatch x = error $ "doMatch failue: " ++ show x -- keep -Wall happy + + ecEqSize ( (_,ls1) , (_,ls2) ) = length ls1 == length ls2 + eSize ( (_,ls1) , _ ) = length ls1 + ecCompareSize = comparing eSize + (lmap',mecs',newEc,matchEc) = reclassify gs1 gs2 lmap mecs + match2 = graphMatch2 matchable gs1 gs2 lmap $ sortBy ecCompareSize mecs + in + -- trace ("graphMatch1\nsingle ECs:\n"++show secs++ + -- "\nmultiple ECs:\n"++show mecs++ + -- "\n\n") $ + -- if mismatch in singleton equivalence classes, fail + if not $ all doMatch secs then (False,lmap) + else + -- if no multi-member equivalence classes, + -- check and return label map supplied + -- trace ("graphMatch1\ngraphMapEq: "++show (graphMapEq lmap gs1 gs2)) $ + if null mecs then (graphMapEq lmap gs1 gs2,lmap) + else + -- if size mismatch in equivalence classes, fail + -- trace ("graphMatch1\nall ecEqSize mecs: "++show (all ecEqSize mecs)) $ + + -- invoke reclassification, and deal with result + if not (all ecEqSize mecs) || not matchEc + then (False, lmap) + else if newEc + then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' + -- if guess does not result in a match, return supplied label map + else if fst match2 then match2 else (False, lmap) + +{- + if not $ all ecEqSize mecs then (False,lmap) + else + if not matchEc then (False,lmap) + else + if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs' + else + if fst match2 then match2 else (False,lmap) +-} + +-- | Auxiliary graph matching function +-- +-- This function is called when deterministic decomposition of node +-- mapping equivalence classes has run its course. +-- +-- It picks a pair of equivalence classes in ecpairs, and arbitrarily matches +-- pairs of nodes in those equivalence classes, recursively calling the +-- graph matching function until a suitable node mapping is discovered +-- (success), or until all such pairs have been tried (failure). +-- +-- This function represents a point to which arbitrary choices are backtracked. +-- The list comprehension 'glp' represents the alternative choices at the +-- point of backtracking +-- +-- The selected pair of nodes are placed in a new equivalence class based on their +-- original equivalence class value, but with a new NodeVal generation number. + +graphMatch2 :: (Label lb) => (lb -> lb -> Bool) + -> [Arc lb] -> [Arc lb] + -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)] + -> (Bool,LabelMap lb) +graphMatch2 _ _ _ _ [] = error "graphMatch2 sent an empty list" -- To keep -Wall happy +graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) = + let + v1 = snd ev1 + -- Return any equivalence-mapping obtained by matching a pair + -- of labels in the supplied list, or Nothing. + try [] = (False,lmap) + try ((l1,l2):lps) = if isEquiv try1 l1 l2 then try1 else try lps + where + try1 = graphMatch1 True matchable gs1 gs2 lmap' ecpairs' + lmap' = newLabelMap lmap [(l1,v1),(l2,v1)] + ecpairs' = ((ev',[l1]),(ev',[l2])):ec':ecpairs + ev' = mapLabelIndex lmap' l1 + ec' = (ecRemoveLabel ec1 l1, ecRemoveLabel ec2 l2) + -- [[[TODO: replace this: if isJust try ?]]] + isEquiv (False,_) _ _ = False + isEquiv (True,lm) x1 x2 = + mapLabelIndex m1 x1 == mapLabelIndex m2 x2 + where + m1 = remapLabels gs1 lm [x1] + m2 = remapLabels gs2 lm [x2] + -- glp is a list of label-pair candidates for matching, + -- selected from the first label-equivalence class. + -- NOTE: final test is call of external matchable function + glp = [ (l1,l2) | l1 <- ls1 , l2 <- ls2 , matchable l1 l2 ] + in + assert (ev1==ev2) "GraphMatch2: Equivalence class value mismatch" $ + try glp + +-- | Returns a string representation of a LabelMap value +-- +showLabelMap :: (Label lb) => LabelMap lb -> String +showLabelMap (LabelMap gn lmap) = + "LabelMap gen="++ Prelude.show gn ++", map="++ + foldl (++) "" (map (("\n "++) . Prelude.show) es) + where + es = listLookupMap lmap + +-- | Map a label to its corresponding label index value in the supplied LabelMap +-- +mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex +mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms + +-- | Confirm that a given pair of labels are matchable, and are +-- mapped to the same value by the supplied label map +-- +labelMatch :: (Label lb) + => (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool +labelMatch matchable lmap l1 l2 = + matchable l1 l2 && (mapLabelIndex lmap l1 == mapLabelIndex lmap l1) + +-- | Replace selected values in a label map with new values from the supplied +-- list of labels and new label index values. The generation number is +-- supplied from the current label map. The generation number in the +-- resulting label map is incremented. +-- +newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb +newLabelMap (LabelMap g f) [] = LabelMap (g+1) f -- new generation +newLabelMap lmap (lv:lvs) = setLabelHash (newLabelMap lmap lvs) lv + +-- | Replace a label and its associated value in a label map +-- with a new value using the supplied hash value and the current +-- `LabelMap` generation number. If the key is not found, then no change +-- is made to the label map. + +setLabelHash :: (Label lb) + => LabelMap lb -> (lb,Int) -> LabelMap lb +setLabelHash (LabelMap g lmap) (lb,lh) = + LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) ) + +-- | Increment the generation of the label map. +-- +-- Returns a new label map identical to the supplied value +-- but with an incremented generation number. +-- +newGenerationMap :: (Label lb) => LabelMap lb -> LabelMap lb +newGenerationMap (LabelMap g lvs) = LabelMap (g+1) lvs + +-- | Scan label list, assigning initial label map values, +-- adding new values to the label map supplied. +-- +-- Label map values are assigned on the basis of the +-- label alone, without regard for it's connectivity in +-- the graph. (cf. `reclassify`). +-- +-- All variable node labels are assigned the same initial +-- value, as they may be matched with each other. +-- +assignLabelMap :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb +assignLabelMap ns lmap = foldl (flip assignLabelMap1) lmap ns + +assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb +assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs' + where + lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab)) + +-- Calculate initial value for a node + +initVal :: (Label lb) => lb -> Int +initVal = hashVal 0 + +hashVal :: (Label lb) => Int -> lb -> Int +hashVal seed lab = + if labelIsVar lab then hash seed "???" else labelHash seed lab + +equivalenceClasses :: + (Label lb) + => LabelMap lb -- ^ label map + -> [lb] -- ^ list of nodes to be reclassified + -> [EquivalenceClass lb] + -- ^ the equivalence classes of the supplied labels under the + -- supplied label map +equivalenceClasses lmap ls = + pairGroup $ map labelPair ls + where + labelPair l = (mapLabelIndex lmap l,l) + +-- | Reclassify labels +-- +-- Examines the supplied label equivalence classes (based on the supplied +-- label map), and evaluates new equivalence subclasses based on node +-- values and adjacency (for variable nodes) and rehashing +-- (for non-variable nodes). +-- +-- Note, assumes that all all equivalence classes supplied are +-- non-singletons; i.e. contain more than one label. +-- +reclassify :: + (Label lb) + => [Arc lb] + -- ^ (the @gs1@ argument) the first of two lists of arcs (triples) to perform a + -- basis for reclassifying the labels in the first equivalence + -- class in each pair of @ecpairs@. + -> [Arc lb] + -- ^ (the @gs2@ argument) the second of two lists of arcs (triples) to perform a + -- basis for reclassifying the labels in the second equivalence + -- class in each pair of the @ecpairs@ argument + -> LabelMap lb + -- ^ the label map used for classification of the labels in + -- the supplied equivalence classes + -> [(EquivalenceClass lb,EquivalenceClass lb)] + -- ^ (the @ecpairs@ argument) a list of pairs of corresponding equivalence classes of + -- nodes from @gs1@ and @gs2@ that have not been confirmed + -- in 1:1 correspondence with each other. + -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool) + -- ^ The output tuple consists of: + -- + -- 1) a revised label map reflecting the reclassification + -- + -- 2) a new list of equivalence class pairs based on the + -- new node map + -- + -- 3) if the reclassification partitions any of the + -- supplied equivalence classes then `True`, else `False` + -- + -- 4) if reclassification results in each equivalence class + -- being split same-sized equivalence classes in the two graphs, + -- then `True`, otherwise `False`. + +reclassify gs1 gs2 lmap@(LabelMap _ lm) ecpairs = + assert (gen1==gen2) "Label map generation mismatch" + (LabelMap gen1 lm',ecpairs',newPart,matchPart) + where + LabelMap gen1 lm1 = + remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs + LabelMap gen2 lm2 = + remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs + lm' = mapReplaceMap lm $ mapMerge lm1 lm2 + -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])] + ecGroups = [ (remapEc ec1,remapEc ec2) | (ec1,ec2) <- ecpairs ] + ecpairs' = concatMap (uncurry zip) ecGroups + newPart = any pairG1 lenGroups + matchPart = all pairEq lenGroups + lenGroups = map subLength ecGroups + pairEq (p1,p2) = p1 == p2 + pairG1 (p1,p2) = p1 > 1 || p2 > 1 + subLength (ls1,ls2) = (length ls1,length ls2) + remapEc ec = pairGroup $ map (newIndex lm') $ pairUngroup ec + newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab) + +-- | Calculate a new index value for a supplied list of labels based on the +-- supplied label map and adjacency calculations in the supplied graph +-- +remapLabels :: + (Label lb) + => [Arc lb] -- ^ arcs used for adjacency calculations when remapping + -> LabelMap lb -- ^ the current label index values + -> [lb] -- ^ the graph labels for which new mappings are to be created + -> LabelMap lb + -- ^ the updated label map containing recalculated label index values + -- for the given graph labels. The label map generation number is + -- incremented by 1. +remapLabels gs lmap@(LabelMap gen _) ls = + LabelMap gen' (LookupMap newEntries) + where + gen' = gen+1 + newEntries = [ newEntry (l, (gen',newIndex l)) | l <- ls ] + newIndex l + | labelIsVar l = mapAdjacent l -- adjacency classifies variable labels + | otherwise = hashVal gen l -- otherwise rehash (to disentangle collisions) + mapAdjacent l = sum (sigsOver l) `rem` hashModulus + sigsOver l = select (hasLabel l) gs (arcSignatures lmap gs) + +-- | Return list of distinct labels used in a graph + +graphLabels :: (Label lb) => [Arc lb] -> [lb] +graphLabels gs = nub $ concatMap arcLabels gs + +{- OLD CODE: +graphLabels gs = graphLabels1 gs [] + +graphLabels1 (t:gs) ls = graphLabels1 gs $ + foldl (flip addSetElem) ls (arcLabels t) +graphLabels1 [] ls = ls +-} + +-- addSetElem :: lb -> [lb] -> [lb] + +-- | 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 gs = + map (sigCalc . arcToTriple) gs + where + sigCalc (s,p,o) = + ( labelVal2 s + + labelVal2 p * 3 + + labelVal2 o * 5 ) `rem` hashModulus + labelVal = mapLabelIndex lmap + labelVal2 = uncurry (*) . labelVal + +-- | Return a new graph that is supplied graph with every node/arc +-- mapped to a new value according to the supplied function. +-- +-- Used for testing for graph equivalence under a supplied +-- label mapping; e.g. +-- +-- > if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same) +-- +graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex] +graphMap = map . fmap . mapLabelIndex -- graphMapStmt + +-- | Compare a pair of graphs for equivalence under a given mapping +-- function. +-- +-- This is used to perform the ultimate test that two graphs are +-- indeed equivalent: guesswork in `graphMatch2` means that it is +-- occasionally possible to construct a node mapping that generates +-- the required singleton equivalence classes, but does not fully +-- reflect the topology of the graphs. + +graphMapEq :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc lb] -> Bool +graphMapEq lmap gs1 gs2 = graphMap lmap gs1 `equiv` graphMap lmap gs2 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/GraphMem.hs b/Swish/RDF/GraphMem.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/GraphMem.hs @@ -0,0 +1,159 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphMem +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses +-- +-- This module defines a simple memory-based graph instance. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Simple labelled directed graph value +------------------------------------------------------------ + +module Swish.RDF.GraphMem + ( GraphMem(..) + , setArcs, getArcs, add, delete, extract, labels + , LabelMem(..) + , labelIsVar, labelHash + -- For debug/test: + , matchGraphMem + ) where + +import Swish.RDF.GraphClass +import Swish.RDF.GraphMatch +import Swish.Utils.MiscHelpers + ( hash ) + +import Data.Ord (comparing) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +-- | Memory-based graph type + +data GraphMem lb = GraphMem { arcs :: [Arc lb] } + deriving (Functor, F.Foldable, T.Traversable) + +instance (Label lb) => LDGraph GraphMem lb where + getArcs = arcs + setArcs as g = g { arcs=as } + -- gmap f g = g { arcs = (map $ fmap f) (arcs g) } + containedIn = undefined -- TODO: what should this method do? + +instance (Label lb) => Eq (GraphMem lb) where + (==) = graphEq + +instance (Label lb) => Show (GraphMem lb) where + show = graphShow + +graphShow :: (Label lb) => GraphMem lb -> String +graphShow g = "Graph:" ++ foldr ((++) . ("\n " ++) . show) "" (arcs g) + +{- +toGraph :: (Label lb) => [Arc lb] -> GraphMem lb +toGraph as = GraphMem { arcs=nub as } +-} + +-- | Return Boolean graph equality + +graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool +graphEq g1 g2 = fst ( matchGraphMem g1 g2 ) + +-- | GraphMem matching function accepting GraphMem value and returning +-- node map if successful +-- +matchGraphMem :: + (Label lb) + => GraphMem lb + -> GraphMem lb + -> (Bool,LabelMap (ScopedLabel lb)) + -- ^ if the first element is @True@ then the second value is a label + -- map that maps each label to an equivalence-class identifier, + -- otherwise `emptyMap`. + -- +matchGraphMem g1 g2 = + let + gs1 = arcs g1 + gs2 = arcs g2 + matchable l1 l2 + | labelIsVar l1 && labelIsVar l2 = True + | labelIsVar l1 || labelIsVar l2 = False + | otherwise = l1 == l2 + in + graphMatch matchable gs1 gs2 + +{- +-- | Return bijection between two graphs, or empty list +graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)] +graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2) + where + lmap = graphMatch g1 g2 + sortedls g = map snd $ + (sortBy indexComp) $ + equivalenceClasses (graphLabels $ arcs g) lmap + classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2) + indexComp (g1,v1) (g2,v2) + | g1 == g2 = compare v1 v2 + | otherwise = compare g1 g2 +-} + +-- | Minimal graph label value - for testing + +data LabelMem + = LF String + | LV String + +instance Label LabelMem where + labelIsVar (LV _) = True + labelIsVar _ = False + getLocal (LV loc) = loc + getLocal lab = error "getLocal of non-variable label: " ++ show lab + makeLabel = LV + labelHash seed lb = hash seed (show lb) + +instance Eq LabelMem where + (LF l1) == (LF l2) = l1 == l2 + (LV l1) == (LV l2) = l1 == l2 + _ == _ = False + +instance Show LabelMem where + show (LF l1) = '!' : l1 + show (LV l2) = '?' : l2 + +instance Ord LabelMem where + compare = comparing show + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/GraphPartition.hs b/Swish/RDF/GraphPartition.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/GraphPartition.hs @@ -0,0 +1,572 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphPartition +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains functions for partitioning a graph into subgraphs +-- that rooted from different subject nodes. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.GraphPartition + ( PartitionedGraph(..), getArcs, getPartitions + , GraphPartition(..), node, toArcs + , partitionGraph, comparePartitions + , partitionShowP + ) +where + +import Swish.RDF.GraphClass + ( Label(..) + , Arc(..), arcSubj, arcObj, + -- , hasLabel, arcLabels + ) + +import Data.List + ( partition ) + +import Control.Monad.State + ( MonadState(..), State, evalState ) + +import Data.Maybe + ( isJust, fromJust, mapMaybe ) + + +------------------------------------------------------------ +-- Data type for a partitioned graph +------------------------------------------------------------ + +-- |Representation of a graph as a collection of (possibly nested) +-- partitions. Each node in the graph appears at least once as the +-- root value of a 'GraphPartition' value: +-- +-- * Nodes that are the subject of at least one statement appear as +-- the first value of exactly one 'PartSub' constructor, and may +-- also appear in any number of 'PartObj' constructors. +-- +-- * Nodes appearing only as objects of statements appear only in +-- 'PartObj' constructors. + +data PartitionedGraph lb = PartitionedGraph [GraphPartition lb] + deriving (Eq,Show) + +getArcs :: PartitionedGraph lb -> [Arc lb] +getArcs (PartitionedGraph ps) = concatMap toArcs ps + +getPartitions :: PartitionedGraph lb -> [GraphPartition lb] +getPartitions (PartitionedGraph ps) = ps + +-- QUS: is the list always guaranteed to be non-empty in PartSub? +data GraphPartition lb + = PartObj lb + | PartSub lb [(lb,GraphPartition lb)] + +node :: GraphPartition lb -> lb +node (PartObj ob) = ob +node (PartSub sb _) = sb + +toArcs :: GraphPartition lb -> [Arc lb] +toArcs (PartObj _) = [] +toArcs (PartSub sb prs) = concatMap toArcs1 prs + where + toArcs1 (pr,ob) = Arc sb pr (node ob) : toArcs ob + +instance (Label lb) => Eq (GraphPartition lb) where + (==) = partitionEq + +instance (Label lb) => Show (GraphPartition lb) where + show = partitionShow + +-- Equality is based on total structural equivalence. +-- This is not the same as graph equality. +partitionEq :: (Label lb) => GraphPartition lb -> GraphPartition lb -> Bool +partitionEq (PartObj o1) (PartObj o2) = o1 == o2 +partitionEq (PartSub s1 p1) (PartSub s2 p2) = s1 == s2 && p1 == p2 +partitionEq _ _ = False + +partitionShow :: (Label lb) => GraphPartition lb -> String +partitionShow (PartObj ob) = show ob +partitionShow (PartSub sb []) = "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible? +partitionShow (PartSub sb (pr:prs)) = + "("++ show sb ++ " " ++ showpr pr ++ concatMap ((" ; "++).showpr) prs ++ ")" + where + showpr (a,b) = show a ++ " " ++ show b + +partitionShowP :: (Label lb) => String -> GraphPartition lb -> String +partitionShowP _ (PartObj ob) = show ob +partitionShowP pref (PartSub sb []) = pref ++ "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible? +partitionShowP pref (PartSub sb (pr:prs)) = + pref++"("++ show sb ++ " " ++ showpr pr ++ concatMap (((pref++" ; ")++).showpr) prs ++ ")" + where + showpr (a,b) = show a ++ " " ++ partitionShowP (pref++" ") b + +------------------------------------------------------------ +-- Creating partitioned graphs +------------------------------------------------------------ +-- +-- |Turning a partitioned graph into a flat graph is easy. +-- The interesting challenge is to turn a flat graph into a +-- partitioned graph that is more useful for certain purposes. +-- Currently, I'm interested in: +-- +-- (1) isolating differences between graphs +-- +-- (2) pretty-printing graphs +-- +-- For (1), the goal is to separate subgraphs that are known +-- to be equivalent from subgraphs that are known to be different, +-- such that: +-- +-- * different sub-graphs are minimized, +-- +-- * different +-- sub-graphs are placed into 1:1 correspondence (possibly with null +-- subgraphs), and +-- +-- * only deterministic matching decisions are made. +-- +-- For (2), the goal is to decide when a subgraph is to be treated +-- as nested in another partition, or treated as a new top-level partition. +-- If a subgraph is referenced by exactly one graph partition, it should +-- be nested in that partition, otherwise it should be a new top-level +-- partition. +-- +-- Strategy. Examining just subject and object nodes: +-- +-- * all non-blank subject nodes are the root of a top-level partition +-- +-- * blank subject nodes that are not the object of exactly one statement +-- are the root of a top-level partition. +-- +-- * blank nodes referenced as the object of exactly 1 statement +-- of an existing partition are the root of a sub-partition of the +-- refering partition. +-- +-- * what remain are circular chains of blank nodes not referenced +-- elsewhere: for each such chain, pick a root node arbitrarily. +-- +partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb +partitionGraph arcs = + makePartitions fixs topv1 intv1 + where + (fixs,vars) = partition isNonVar $ collect arcSubj arcs + vars1 = collectMore arcObj arcs vars + (intv,topv) = partition objOnce vars1 + intv1 = map stripObj intv + topv1 = map stripObj topv + isNonVar = not . labelIsVar . fst + objOnce = isSingle . snd . snd + isSingle [_] = True + isSingle _ = False + stripObj (k,(s,_)) = (k,s) + +-- Local state type for partitioning function +type MakePartitionState lb = ([(lb,[Arc lb])],[(lb,[Arc lb])],[(lb,[Arc lb])]) + +makePartitions :: (Eq lb) => + [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> PartitionedGraph lb +makePartitions fixs topv intv = + PartitionedGraph $ evalState (makePartitions1 []) (fixs,topv,intv) + +-- Use a state monad to keep track of arcs that have been incorporated into +-- the resulting list of graph partitions. The collections of arcs used to +-- generate the list of partitions are supplied as theinitial state of the +-- monad (see call of evalState above). +-- +makePartitions1 :: (Eq lb) => + [(lb,[Arc lb])] -> State (MakePartitionState lb) [GraphPartition lb] +makePartitions1 [] = + do { s <- pickNextSubject + ; if null s then return [] else makePartitions1 s + } +makePartitions1 (sub:subs) = + do { ph <- makePartitions2 sub + ; pt <- makePartitions1 subs + ; return $ ph++pt + } + +makePartitions2 :: (Eq lb) => + (lb,[Arc lb]) -> State (MakePartitionState lb) [GraphPartition lb] +makePartitions2 subs = + do { (part,moresubs) <- makeStatements subs + ; moreparts <- if not (null moresubs) then + makePartitions1 moresubs + else + return [] + ; return $ part:moreparts + } + +makeStatements :: (Eq lb) => + (lb,[Arc lb]) + -> State (MakePartitionState lb) (GraphPartition lb,[(lb,[Arc lb])]) +makeStatements (sub,stmts) = + do { propmore <- mapM makeStatement stmts + ; let (props,moresubs) = unzip propmore + ; return (PartSub sub props,concat moresubs) + } + +makeStatement :: (Eq lb) => + Arc lb + -> State (MakePartitionState lb) ((lb,GraphPartition lb),[(lb,[Arc lb])]) +makeStatement (Arc _ prop obj) = + do { intobj <- pickIntSubject obj + ; (gpobj,moresubs) <- if null intobj + then + do { ms <- pickVarSubject obj + ; return (PartObj obj,ms) + } + else + makeStatements (head intobj) + ; return ((prop,gpobj),moresubs) + } + +pickNextSubject :: State (MakePartitionState lb) [(lb,[Arc lb])] +pickNextSubject = + do { (a1,a2,a3) <- get + ; let (s,st) = case (a1,a2,a3) of + (s1h:s1t,s2,s3) -> ([s1h],(s1t,s2,s3)) + ([],s2h:s2t,s3) -> ([s2h],([],s2t,s3)) + ([],[],s3h:s3t) -> ([s3h],([],[],s3t)) + ([],[],[]) -> ([] ,([],[],[] )) + ; put st + ; return s + } + +pickIntSubject :: (Eq lb) => + lb -> State (MakePartitionState lb) [(lb,[Arc lb])] +pickIntSubject sub = + do { (s1,s2,s3) <- get + ; let varsub = removeBy (\x->(x==).fst) sub s3 + ; if isJust varsub then + do { let (vs,s3new) = fromJust varsub + ; put (s1,s2,s3new) + ; return [vs] + } + else + return [] + } + +pickVarSubject :: (Eq lb) => + lb -> State (MakePartitionState lb) [(lb,[Arc lb])] +pickVarSubject sub = + do { (s1,s2,s3) <- get + ; let varsub = removeBy (\x->(x==).fst) sub s2 + ; if isJust varsub then + do { let (vs,s2new) = fromJust varsub + ; put (s1,s2new,s3) + ; return [vs] + } + else + return [] + } + +------------------------------------------------------------ +-- Other useful functions +------------------------------------------------------------ +-- +-- Create a list of pairs of corresponding Partitions that +-- are unequal + +comparePartitions :: (Label lb) => + PartitionedGraph lb -> PartitionedGraph lb + -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions (PartitionedGraph gp1) (PartitionedGraph gp2) = + comparePartitions1 (reverse gp1) (reverse gp2) + +comparePartitions1 :: (Label lb) => + [GraphPartition lb] -> [GraphPartition lb] + -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions1 pg1 pg2 = + ds ++ [ (Just r1p,Nothing) | r1p<-r1 ] + ++ [ (Nothing,Just r2p) | r2p<-r2 ] + where + (ds,r1,r2) = listDifferences comparePartitions2 pg1 pg2 + +-- Compare two graph partitions, with three possible outcomes: +-- Nothing -> no match +-- Just [] -> total match +-- Just [...] -> partial match, with mismatched sub-partitions listed. +-- +-- A partial match occurs when the leading nodes are non-variable and +-- equal, but something else in the partition does not match. +-- +-- A complete match can be achieved with variable nodes that have +-- different labels +-- +comparePartitions2 :: (Label lb) => + GraphPartition lb -> GraphPartition lb + -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions2 (PartObj l1) (PartObj l2) = + if matchNodes l1 l2 then Just [] else Nothing +comparePartitions2 pg1@(PartSub l1 p1s) pg2@(PartSub l2 p2s) = + if match then comp1 else Nothing + where + comp1 = case comparePartitions3 l1 l2 p1s p2s of + Nothing -> if matchVar then Nothing + else Just [(Just pg1,Just pg2)] + Just [] -> Just [] + Just ps -> {- if matchVar then Nothing else -} Just ps + matchVar = labelIsVar l1 && labelIsVar l2 + match = matchVar || l1 == l2 +comparePartitions2 pg1 pg2 = + if not (labelIsVar l1) && l1 == l2 + then Just [(Just pg1,Just pg2)] + else Nothing + where + l1 = node pg1 + l2 = node pg2 + +comparePartitions3 :: (Label lb) => + lb -> lb -> [(lb,GraphPartition lb)] -> [(lb,GraphPartition lb)] + -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions3 l1 l2 s1s s2s = Just $ + ds ++ [ (Just (PartSub l1 [r1p]),Nothing) | r1p<-r1 ] + ++ [ (Nothing,Just (PartSub l2 [r2p])) | r2p<-r2 ] + where + (ds,r1,r2) = listDifferences (comparePartitions4 l1 l2) s1s s2s + +comparePartitions4 :: (Label lb) => + lb -> lb -> (lb,GraphPartition lb) -> (lb,GraphPartition lb) + -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] +comparePartitions4 _ _ (p1,o1) (p2,o2) = + if matchNodes p1 p2 then comp1 else Nothing + where + comp1 = case comparePartitions2 o1 o2 of + Nothing -> Just [(Just o1,Just o2)] + ds -> ds + +matchNodes :: (Label lb) => lb -> lb -> Bool +matchNodes l1 l2 + | labelIsVar l1 = labelIsVar l2 + | otherwise = l1 == l2 + + +------------------------------------------------------------ +-- Helpers +------------------------------------------------------------ + +-- |Collect a list of items by some comparison of a selected component +-- or other derived value. +-- +-- cmp a comparison function that determines if a pair of values +-- should be grouped together +-- sel a function that selects a value from any item +-- +-- Example: collect fst [(1,'a'),(2,'b'),(1,'c')] = +-- [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])] +-- +collect :: (Eq b) => (a->b) -> [a] -> [(b,[a])] +collect = collectBy (==) + +collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b,[a])] +collectBy cmp sel = map reverseCollection . collectBy1 cmp sel [] + +collectBy1 :: (b->b->Bool) -> (a->b) -> [(b,[a])] -> [a] -> [(b,[a])] +collectBy1 _ _ sofar [] = sofar +collectBy1 cmp sel sofar (a:as) = + collectBy1 cmp sel (collectBy2 cmp sel a sofar) as + +collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b,[a])] -> [(b,[a])] +collectBy2 _ sel a [] = [(sel a,[a])] +collectBy2 cmp sel a (col@(k,as):cols) + | cmp ka k = (k,a:as):cols + | otherwise = col:collectBy2 cmp sel a cols + where + ka = sel a + +reverseCollection :: (b,[a]) -> (b,[a]) +reverseCollection (k,as) = (k,reverse as) + +{- +-- Example/test: +testCollect1 :: [(Int, [(Int, Char)])] +testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')] + +testCollect2 :: Bool +testCollect2 = testCollect1 + == [ (1,[(1,'a'),(1,'c'),(1,'d')]) + , (2,[(2,'b'),(2,'d')]) + , (3,[(3,'d')]) + ] +-} + +-- |Add new values to an existing list of collections. +-- The list of collections is not extended, but each collection is +-- augmented with a further list of values from the supplied list, +-- each of which are related to the existing collection in some way. +-- +-- NOTE: the basic pattern of 'collect' and 'collectMore' is similar, +-- and might be generalized into a common set of core functions. +-- +collectMore :: (Eq b) => (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] +collectMore = collectMoreBy (==) + +collectMoreBy :: + (b->b->Bool) -> (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))] +collectMoreBy cmp sel as cols = + map reverseMoreCollection $ + collectMoreBy1 cmp sel as (map (\ (b,cs) -> (b,(cs,[])) ) cols) + +collectMoreBy1 :: + (b->b->Bool) -> (a->b) -> [a] -> [(b,(c,[a]))] -> [(b,(c,[a]))] +collectMoreBy1 _ _ [] cols = cols +collectMoreBy1 cmp sel (a:as) cols = + collectMoreBy1 cmp sel as (collectMoreBy2 cmp sel a cols) + +collectMoreBy2 :: + (b->b->Bool) -> (a->b) -> a -> [(b,(c,[a]))] -> [(b,(c,[a]))] +collectMoreBy2 _ _ _ [] = [] +collectMoreBy2 cmp sel a (col@(k,(b,as)):cols) + | cmp (sel a) k = (k,(b,a:as)):cols + | otherwise = col:collectMoreBy2 cmp sel a cols + +reverseMoreCollection :: (b,(c,[a])) -> (b,(c,[a])) +reverseMoreCollection (k,(c,as)) = (k,(c,reverse as)) + +{- +-- Example/test: +testCollectMore1 = + collectMore snd [(111,1),(112,1),(211,2),(311,3),(411,4)] testCollect1 + +testCollectMore2 :: Bool +testCollectMore2 = testCollectMore1 + == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)])) + , (2,([(2,'b'),(2,'d')],[(211,2)])) + , (3,([(3,'d')],[(311,3)])) + ] +-} + +-- |Remove supplied element from a list using the supplied test +-- function, and return Just the element remoived and the +-- remaining list, or Nothing if no element was matched for removal. +-- +{- +remove :: (Eq a) => a -> [a] -> Maybe (a,[a]) +remove = removeBy (==) + +testRemove1 = remove 3 [1,2,3,4,5] +testRemove2 = testRemove1 == Just (3,[1,2,4,5]) +testRemove3 = remove 3 [1,2,4,5] +testRemove4 = testRemove3 == Nothing +testRemove5 = remove 5 [1,2,4,5] +testRemove6 = testRemove5 == Just (5,[1,2,4]) +testRemove7 = remove 1 [1,2,4] +testRemove8 = testRemove7 == Just (1,[2,4]) +testRemove9 = remove 2 [2] +testRemove10 = testRemove9 == Just (2,[]) + +-} + +removeBy :: (b->a->Bool) -> b -> [a] -> Maybe (a,[a]) +removeBy cmp a0 as = removeBy1 cmp a0 as [] + +removeBy1 :: (b->a->Bool) -> b -> [a] -> [a] -> Maybe (a,[a]) +removeBy1 _ _ [] _ = Nothing +removeBy1 cmp a0 (a:as) sofar + | cmp a0 a = Just (a,reverseTo sofar as) + | otherwise = removeBy1 cmp a0 as (a:sofar) + +-- |Reverse first argument, prepending the result to the second argument +-- +reverseTo :: [a] -> [a] -> [a] +reverseTo front back = foldl (flip (:)) back front + +-- |Remove each element from a list, returning a list of pairs, +-- each of which is the element removed and the list remaining. +-- +removeEach :: [a] -> [(a,[a])] +removeEach [] = [] +removeEach (a:as) = (a,as):[ (a1,a:a1s) | (a1,a1s) <- removeEach as ] + +{- +testRemoveEach1 = removeEach [1,2,3,4,5] +testRemoveEach2 = testRemoveEach1 == + [ (1,[2,3,4,5]) + , (2,[1,3,4,5]) + , (3,[1,2,4,5]) + , (4,[1,2,3,5]) + , (5,[1,2,3,4]) + ] +-} + +-- |List differences between the members of two lists, where corresponding +-- elements may appear at arbitrary locations in the corresponding lists. +-- +-- Elements are compared using the function 'cmp', which returns: +-- * Nothing if the elements are completely unrelated +-- * Just [] if the elements are identical +-- * Just ds if the elements are related but not identical, in which case +-- ds is a list of values describing differences between them. +-- +-- Returns (ds,u1,u2), where: +-- ds is null if the related elements from each list are identical, +-- otherwise is a list of differences between the related elements. +-- u1 is a list of elements in a1 not related to elements in a2. +-- u2 is a list of elements in a2 not related to elements in a1. +-- +listDifferences :: (a->a->Maybe [d]) -> [a] -> [a] -> ([d],[a],[a]) +listDifferences _ [] a2s = ([],[],a2s) +listDifferences cmp (a1:a1t) a2s = + case mcomp of + Nothing -> morediffs [] [a1] a1t a2s + Just (ds,a2t) -> morediffs ds [] a1t a2t + where + -- mcomp finds identical match, if there is one, or + -- the first element in a2s related to a1, or Nothing + -- [choose was listToMaybe, + -- but that didn't handle repeated properties well] + mcomp = choose $ mapMaybe maybeResult comps + comps = [ (cmp a1 a2,a2t) | (a2,a2t) <- removeEach a2s ] + maybeResult (Nothing,_) = Nothing + maybeResult (Just ds,a2t) = Just (ds,a2t) + morediffs xds xa1h xa1t xa2t = (xds++xds1,xa1h++xa1r,xa2r) + where + (xds1,xa1r,xa2r) = listDifferences cmp xa1t xa2t + choose [] = Nothing + choose ds@(d:_) = choose1 d ds + choose1 _ (d@([],_):_) = Just d + choose1 d [] = Just d + choose1 d (_:ds) = choose1 d ds + +{- +testcmp (l1,h1) (l2,h2) + | (l1 >= h2) || (l2 >= h1) = Nothing + | (l1 == l2) && (h1 == h2) = Just [] + | otherwise = Just [((l1,h1),(l2,h2))] + +testdiff1 = listDifferences testcmp + [(12,15),(1,2),(3,4),(5,8),(10,11)] + [(10,11),(0,1),(3,4),(6,9),(13,15)] +testdiff2 = testdiff1 == ([((12,15),(13,15)),((5,8),(6,9))],[(1,2)],[(0,1)]) +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/MapXsdInteger.hs b/Swish/RDF/MapXsdInteger.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/MapXsdInteger.hs @@ -0,0 +1,87 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : MapXsdInteger +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines the datatytpe mapping and relation values +-- used for RDF dataype xsd:integer +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.MapXsdInteger + ( mapXsdInteger + ) +where + +import Swish.RDF.Datatype + ( DatatypeMap(..) + ) + +------------------------------------------------------------ +-- Implementation of DatatypeMap for xsd:integer +------------------------------------------------------------ + +-- |mapXsdInteger contains functions that perform lexical-to-value +-- and value-to-canonical-lexical mappings for xsd:integer values +-- +mapXsdInteger :: DatatypeMap Integer +mapXsdInteger = DatatypeMap + { -- mapL2V :: String -> Maybe Integer + mapL2V = fromString + + -- mapV2L :: Integer -> Maybe String + , mapV2L = Just . show + } + +-- basic little parser for integer values; +-- do we need to bother about rejecting +-- input like "-000" or "+0"? +-- +fromString :: String -> Maybe Integer +fromString ('-':xs) = fs False xs +fromString ('+':xs) = fs True xs +fromString xs = fs True xs + +fs :: Bool -> String -> Maybe Integer +fs _ [] = Nothing +fs f is = + let val = go is [] + + go [] ys = Just $ read $ reverse ys + go (x:xs) ys | x `elem` ['0'..'9'] = go xs (x:ys) + | otherwise = Nothing + + in case f of + True -> val + False -> fmap ((-1) *) val + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/N3Formatter.hs b/Swish/RDF/N3Formatter.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/N3Formatter.hs @@ -0,0 +1,998 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3Formatter +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module implements a Notation 3 formatter (see [1], [2] and [3]), +-- for an RDFGraph value. +-- +-- +-- REFERENCES: +-- +-- (1) +-- Notation3 (N3): A readable RDF syntax, +-- W3C Team Submission 14 January 2008 +-- +-- (2) +-- Tim Berners-Lee's design issues series notes and description +-- +-- (2) +-- Notation 3 Primer by Sean Palmer +-- +-- TODO: +-- +-- * Initial prefix list to include nested formulae; +-- then don't need to update prefix list for these. +-- +-- * correct output of strings containing unsupported escape +-- characters (such as @\\q@) +-- +-- * more flexible terminator generation for formatted formulae +-- (for inline blank nodes.) +-- +-------------------------------------------------------------------------------- + +{- +TODO: + +The code used to determine whether a blank node can be written +using the "[]" short form could probably take advantage of the +GraphPartition module. + +-} + +module Swish.RDF.N3Formatter + ( NodeGenLookupMap + , formatGraphAsStringNl + , formatGraphAsString + , formatGraphAsShowS + , formatGraphIndent + , formatGraphDiag + ) +where + +import Swish.RDF.RDFGraph ( + RDFGraph, RDFLabel(..), + NamespaceMap, RevNamespaceMap, + emptyNamespaceMap, + FormulaMap, emptyFormulaMap, + getArcs, labels, + setNamespaces, getNamespaces, + getFormulae, + emptyRDFGraph, + res_rdf_first, res_rdf_rest, res_rdf_nil + ) + +import Swish.RDF.Vocabulary ( + isLang, langTag, + rdf_type, + rdf_nil, + owl_sameAs, log_implies + ) + +import Swish.RDF.GraphClass + ( Arc(..) ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..) + , LookupMap, emptyLookupMap, reverseLookupMap + , listLookupMap + , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge + ) + +import Swish.Utils.Namespace + ( ScopedName(..), getScopeURI ) + +import Data.Char (ord, isDigit) + +import Data.List (foldl', delete, groupBy, intercalate, partition, sort) + +import Text.Printf (printf) + +import Control.Monad (liftM, when) +import Control.Monad.State (State, get, put, runState) + +---------------------------------------------------------------------- +-- Ouptut string concatenation +---------------------------------------------------------------------- +-- +-- Function puts uses the shows mechanism to avoid the cost of +-- quadratic string concatenation times. (Use function composition to +-- concatenate strings thus reprersented.) + +puts :: String -> ShowS +puts = showString + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- The graph to be formatted is carried as part of the formatting +-- state, so that decisions about what needs to be formatted can +-- themselves be based upon and reflected in the state (e.g. if a +-- decision is made to include a blank node inline, it can be removed +-- from the graph state that remains to be formatted). + +type SubjTree lb = [(lb,PredTree lb)] +type PredTree lb = [(lb,[lb])] + +data N3FormatterState = N3FS + { indent :: String + , lineBreak :: Bool + , graph :: RDFGraph + , subjs :: SubjTree RDFLabel + , props :: PredTree RDFLabel -- for last subject selected + , objs :: [RDFLabel] -- for last property selected + , formAvail :: FormulaMap RDFLabel + , formQueue :: [(RDFLabel,RDFGraph)] + , nodeGenSt :: NodeGenState + , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format + , traceBuf :: [String] + } + +type Formatter a = State N3FormatterState a + +emptyN3FS :: NodeGenState -> N3FormatterState +emptyN3FS ngs = N3FS + { indent = "\n" + , lineBreak = False + , graph = emptyRDFGraph + , subjs = [] + , props = [] + , objs = [] + , formAvail = emptyFormulaMap + , formQueue = [] + , nodeGenSt = ngs + , bNodesCheck = [] + , traceBuf = [] + } + +-- | Node name generation state information that carries through +-- and is updated by nested formulae +type NodeGenLookupMap = LookupMap (RDFLabel,Int) + +data NodeGenState = Ngs + { prefixes :: NamespaceMap + , nodeMap :: NodeGenLookupMap + , nodeGen :: Int + } + +emptyNgs :: NodeGenState +emptyNgs = Ngs + { prefixes = emptyLookupMap + , nodeMap = emptyLookupMap + , nodeGen = 0 + } + +-- simple context for label creation +-- (may be a temporary solution to the problem +-- of label creation) +-- +data LabelContext = SubjContext | PredContext | ObjContext + deriving (Eq, Show) + +getIndent :: Formatter String +getIndent = indent `liftM` get + +setIndent :: String -> Formatter () +setIndent ind = do + st <- get + put $ st { indent = ind } + +getLineBreak :: Formatter Bool +getLineBreak = lineBreak `liftM` get + +setLineBreak :: Bool -> Formatter () +setLineBreak brk = do + st <- get + put $ st {lineBreak = brk} + +getNgs :: Formatter NodeGenState +getNgs = nodeGenSt `liftM` get + +setNgs :: NodeGenState -> Formatter () +setNgs ngs = do + st <- get + put $ st { nodeGenSt = ngs } + +getPrefixes :: Formatter NamespaceMap +getPrefixes = prefixes `liftM` getNgs + +getSubjs :: Formatter (SubjTree RDFLabel) +getSubjs = subjs `liftM` get + +setSubjs :: SubjTree RDFLabel -> Formatter () +setSubjs sl = do + st <- get + put $ st { subjs = sl } + +getProps :: Formatter (PredTree RDFLabel) +getProps = props `liftM` get + +setProps :: PredTree RDFLabel -> Formatter () +setProps ps = do + st <- get + put $ st { props = ps } + +{- +getObjs :: Formatter ([RDFLabel]) +getObjs = objs `liftM` get + +setObjs :: [RDFLabel] -> Formatter () +setObjs os = do + st <- get + put $ st { objs = os } +-} + +getBnodesCheck :: Formatter ([RDFLabel]) +getBnodesCheck = bNodesCheck `liftM` get + +{- +addTrace :: String -> Formatter () +addTrace tr = do + st <- get + put $ st { traceBuf = tr : traceBuf st } +-} + +queueFormula :: RDFLabel -> Formatter () +queueFormula fn = do + st <- get + let fa = formAvail st + newState fv = st { + formAvail = mapDelete fa fn, + formQueue = (fn,fv) : formQueue st + } + case mapFindMaybe fn fa of + Nothing -> return () + Just v -> put (newState v) >> return () + +{- +Return the graph associated with the label and delete it +from the store, if there is an association, otherwise +return Nothing. +-} +extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) +extractFormula fn = do + st <- get + let fa = formAvail st + newState = st { formAvail=mapDelete fa fn } + case mapFindMaybe fn fa of + Nothing -> return Nothing + Just fv -> put newState >> return (Just fv) + +{- +moreFormulae :: Formatter Bool +moreFormulae = do + st <- get + return $ not $ null (formQueue st) + +nextFormula :: Formatter (RDFLabel,RDFGraph) +nextFormula = do + st <- get + let (nf : fq) = formQueue st + put $ st { formQueue = fq } + return nf + +-} + +-- list has a length of 1 +len1 :: [a] -> Bool +len1 (_:[]) = True +len1 _ = False + +{-| +Given a set of statements and a label, return the details of the +RDF collection referred to by label, or Nothing. + +For label to be considered as representing a collection we require the +following conditions to hold (this is only to support the +serialisation using the '(..)' syntax and does not make any statement +about semantics of the statements with regard to RDF Collections): + + - there must be one rdf_first and one rdf_rest 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 == res_rdf_nil = Just (sl, reverse cs, ss) + | otherwise = do + (pList1, sl') <- removeItem sl l + (pFirst, pList2) <- removeItem pList1 res_rdf_first + (pNext, pList3) <- removeItem pList2 res_rdf_rest + + -- QUS: could I include these checks implicitly in the pattern matches above? + -- ie instrad of (pFirst, pos1) <- .. + -- have ([content], pos1) <- ... + -- ? + if and [len1 pFirst, len1 pNext, null pList3] + then go sl' (head pNext) (head pFirst : cs, l : ss) + else Nothing + +{- +TODO: + +Should we change the preds/objs entries as well? + +-} +extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) +extractList lctxt ln = do + osubjs <- getSubjs + oprops <- getProps + let mlst = getCollection osubjs' ln + + -- we only want to send in rdf:first/rdf:rest here + fprops = filter ((`elem` [res_rdf_first, res_rdf_rest]) . fst) oprops + + osubjs' = + case lctxt of + SubjContext -> (ln, fprops) : osubjs + _ -> osubjs + + -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" + -- addTrace tr + case mlst of + -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext + Just (sl,ls,_) -> do + setSubjs sl + when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [res_rdf_first, res_rdf_rest]) . fst) oprops + return (Just ls) + + Nothing -> return Nothing + +{- +-- for safety I am assuming no ordering of the subject tree +-- but really should be using one of the container types +-- +deleteItems :: (Eq a) => [(a,b)] -> [a] -> [(a,b)] +deleteItems [] _ = [] +deleteItems os [] = os +deleteItems os (x:xs) = + deleteItems (deleteItem os x) xs + +deleteItem :: (Eq a) => [(a,b)] -> a -> [(a,b)] +deleteItem os x = + case removeItem os x of + Just (_, rest) -> rest + Nothing -> os +-} + +{-| +Removes the first occurrence of the item from the +association list, returning it's contents and the rest +of the list, if it exists. +-} +removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) +removeItem os x = + let (as, bs) = break (\a -> fst a == x) os + in case bs of + ((_,b):bbs) -> Just (b, as ++ bbs) + [] -> Nothing + +---------------------------------------------------------------------- +-- Define a top-level formatter function: +-- accepts a graph and returns a string +---------------------------------------------------------------------- + +formatGraphAsStringNl :: RDFGraph -> String +formatGraphAsStringNl gr = formatGraphAsShowS gr "\n" + +formatGraphAsString :: RDFGraph -> String +formatGraphAsString gr = formatGraphAsShowS gr "" + +formatGraphAsShowS :: RDFGraph -> ShowS +formatGraphAsShowS = formatGraphIndent "\n" True +{- old code: + where + (out,_,_,_) = formatGraphDiag gr +-} + +formatGraphIndent :: String -> Bool -> RDFGraph -> ShowS +{- working version +formatGraphIndent ind dopref gr = out + where + (_,out) = formatGraphDiag1 ind dopref emptyLookupMap gr +-} +formatGraphIndent ind dopref = fst . formatGraphDiag1 ind dopref emptyLookupMap +{- +formatGraphIndent ind dopref gr = out + where + (out',fgs) = formatGraphDiag1 ind dopref emptyLookupMap gr + tbuff = traceBuf fgs + -- tr = if null tbuff then "" else "\nDEBUG:\n" ++ concat (reverse tbuff) + tr = "" + out = out' . (++ tr) +-} + +-- | Format graph and return additional information +formatGraphDiag :: + RDFGraph -> (ShowS,NodeGenLookupMap,Int,[String]) +formatGraphDiag gr = (out,nodeMap ngs,nodeGen ngs,traceBuf fgs) + where + (out,fgs) = formatGraphDiag1 "\n" True emptyLookupMap gr + ngs = nodeGenSt fgs + +-- Internal function starts with supplied prefix table and indent string, +-- and returns final state and formatted string. +-- This is provided for diagnostic access to the final state +formatGraphDiag1 :: String -> Bool -> NamespaceMap -> RDFGraph -> (ShowS,N3FormatterState) +formatGraphDiag1 ind dopref pref gr = + let fg = formatGraph ind " ." False dopref gr + ngs = emptyNgs { + prefixes=pref, + nodeGen=findMaxBnode gr + } + + in runState fg (emptyN3FS ngs) + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +-- ind is indentation string +-- end is ending string to be placed after final statement +-- dobreak is True if a line break is to be inserted at the start +-- dopref is True if prefix strings are to be generated +-- +formatGraph :: String -> String -> Bool -> Bool -> RDFGraph -> Formatter ShowS +formatGraph ind end dobreak dopref gr = do + setIndent ind + setLineBreak dobreak + setGraph gr + fp <- if dopref + then formatPrefixes (getNamespaces gr) + else return $ puts "" + more <- moreSubjects + res <- if more + then do + fr <- formatSubjects + return $ fp . fr . puts end + else return fp + + return res + +formatPrefixes :: NamespaceMap -> Formatter ShowS +formatPrefixes pmap = do + let mls = map (pref . keyVal) (listLookupMap pmap) + ls <- sequence mls + return $ puts $ concat ls + where + pref (p,u) = nextLine $ "@prefix "++p++": <"++ quote True u ++"> ." + +formatSubjects :: Formatter ShowS +formatSubjects = do + sb <- nextSubject + sbstr <- formatLabel SubjContext sb + + flagP <- moreProperties + if flagP + then do + prstr <- formatProperties sb sbstr + -- fmstr <- formatFormulae "" + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ puts (prstr ++ " .") . fr + -- return $ puts (prstr ++ fmstr ++ " .") . fr + else return $ puts $ prstr + -- else return $ puts $ prstr ++ fmstr + + else do + txt <- nextLine sbstr + return $ puts txt + +formatProperties :: RDFLabel -> String -> Formatter String +formatProperties sb sbstr = do + pr <- nextProperty sb + prstr <- formatLabel PredContext pr + obstr <- formatObjects sb pr (sbstr++" "++prstr) + more <- moreProperties + let sbindent = replicate (length sbstr) ' ' + if more + then do + fr <- formatProperties sb sbindent + nl <- nextLine $ obstr ++ " ;" + return $ nl ++ fr + else nextLine obstr + +formatObjects :: RDFLabel -> RDFLabel -> String -> Formatter String +formatObjects sb pr prstr = do + ob <- nextObject sb pr + obstr <- formatLabel ObjContext ob + more <- moreObjects + if more + then do + let prindent = replicate (length prstr) ' ' + fr <- formatObjects sb pr prindent + nl <- nextLine $ prstr ++ " " ++ obstr ++ "," + return $ nl ++ fr + else return $ prstr ++ " " ++ obstr + +{- +formatFormulae :: String -> Formatter String +formatFormulae fp = do + more <- moreFormulae + if more + then do + fnlgr <- nextFormula + fnstr <- formatFormula fnlgr + formatFormulae $ fp ++ " ." ++ fnstr + else return fp + +TODO: need to remove the use of :-. It's not clear to me whether +we are guaranteed that fn is only used once in the graph - ie +if it is safe to inline this formula at the label location. + +formatFormula :: (RDFLabel,RDFGraph) -> Formatter String +formatFormula (fn,gr) = do + fnstr <- formatLabel SubjContext fn + f1str <- nextLine $ fnstr ++ " :-" + f2str <- nextLine " {" + ngs0 <- getNgs + ind <- getIndent + let grm = formatGraph (ind++" ") "" True False + (setNamespaces emptyNamespaceMap gr) + + (f3str, fgs') = runState grm (emptyN3FS ngs0) + + setNgs (nodeGenSt fgs') + f4str <- nextLine " }" + return $ f1str ++ f2str ++ f3str f4str + +-} + +--- DJB's version of formatFormula when it can be inserted inline +insertFormula :: RDFGraph -> Formatter String +insertFormula gr = do + ngs0 <- getNgs + ind <- getIndent + let grm = formatGraph (ind++" ") "" True False + (setNamespaces emptyNamespaceMap gr) + + (f3str, fgs') = runState grm (emptyN3FS ngs0) + + setNgs (nodeGenSt fgs') + f4str <- nextLine " } " + return $ " { " ++ f3str f4str + +{- +Add a list inline. We are given the labels that constitute +the list, in order, so just need to display them surrounded +by (). +-} +insertList :: [RDFLabel] -> Formatter String +insertList [] = return $ "()" -- not convinced this can happen +insertList xs = do + ls <- mapM (formatLabel ObjContext) xs + return $ "( " ++ intercalate " " ls ++ " )" + + +{- +Add a blank node inline. +-} + +insertBnode :: LabelContext -> RDFLabel -> Formatter String +insertBnode SubjContext lbl = do + flag <- moreProperties + txt <- if flag + then liftM (++"\n") $ formatProperties lbl "" + else return "" + + -- TODO: handle indentation? + return $ "[" ++ txt ++ "]" + +insertBnode _ lbl = do + ost <- get + let osubjs = subjs ost + oprops = props ost + oobjs = objs ost + + (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs + + rprops = case bsubj of + [(_,rs)] -> rs + _ -> [] + + -- we essentially want to create a new subgraph + -- for this node but it's not as simple as that since + -- we could have something like + -- :a :b [ :foo [ :bar "xx" ] ] + -- so we still need to carry around the whole graph + -- + nst = ost { subjs = rsubjs, + props = rprops, + objs = [] + } + + put nst + flag <- moreProperties + txt <- if flag + then liftM (++"\n") $ formatProperties lbl "" + else return "" + + -- TODO: how do we restore the original set up? + -- I can't believe the following is sufficient + -- + nst' <- get + let slist = map fst $ subjs nst' + nsubjs = filter (\(l,_) -> l `elem` slist) osubjs + + put $ nst' { subjs = nsubjs, + props = oprops, + objs = oobjs + } + + -- TODO: handle indentation? + return $ "[" ++ txt ++ "]" + +---------------------------------------------------------------------- +-- Formatting helpers +---------------------------------------------------------------------- + +setGraph :: RDFGraph -> Formatter () +setGraph gr = do + st <- get + + let ngs0 = nodeGenSt st + pre' = mapMerge (prefixes ngs0) (getNamespaces gr) + ngs' = ngs0 { prefixes = pre' } + arcs = sortArcs $ getArcs gr + nst = st { graph = gr + , subjs = arcTree arcs + , props = [] + , objs = [] + , formAvail = getFormulae gr + , nodeGenSt = ngs' + , bNodesCheck = countBnodes arcs + } + + put nst + +moreSubjects :: Formatter Bool +moreSubjects = (not . null . subjs) `liftM` get + +nextSubject :: Formatter RDFLabel +nextSubject = do + st <- get + + let sb:sbs = subjs st + nst = st { subjs = sbs + , props = snd sb + , objs = [] + } + + put nst + return $ fst sb + +moreProperties :: Formatter Bool +moreProperties = (not . null . props) `liftM` get + +nextProperty :: RDFLabel -> Formatter RDFLabel +nextProperty _ = do + st <- get + + let pr:prs = props st + nst = st { props = prs + , objs = snd pr + } + + put nst + return $ fst pr + + +moreObjects :: Formatter Bool +moreObjects = (not . null . objs) `liftM` get + +nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel +nextObject _ _ = do + st <- get + + let ob:obs = objs st + nst = st { objs = obs } + + put nst + return ob + +nextLine :: String -> Formatter String +nextLine str = do + ind <- getIndent + brk <- getLineBreak + if brk + then return $ ind++str + else do + -- After first line, always insert line break + setLineBreak True + return str + +-- Format a label +-- Most labels are simply displayed as provided, but there are a +-- number of wrinkles to take care of here: +-- (a) blank nodes automatically allocated on input, with node +-- identifiers of the form of a digit string nnn. These are +-- not syntactically valid, and are reassigned node identifiers +-- of the form _nnn, where nnn is chosen so that is does not +-- clash with any other identifier in the graph. +-- (b) URI nodes: if possible, replace URI with qname, +-- else display as +-- (c) formula nodes (containing graphs). +-- +-- [[[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 = + [ (rdf_type, "a") + , (owl_sameAs, "=") + , (log_implies, "=>") + , (rdf_nil, "()") + ] + +formatLabel :: LabelContext -> RDFLabel -> Formatter String +{- +formatLabel lab@(Blank (_:_)) = do + name <- formatNodeId lab + queueFormula lab + return name +-} + +{- +The "[..]" conversion is done last, after "()" and "{}" checks. +-} +formatLabel lctxt lab@(Blank (_:_)) = do + mlst <- extractList lctxt lab + case mlst of + Just lst -> insertList lst + Nothing -> do + mfml <- extractFormula lab + case mfml of + Just fml -> insertFormula fml + Nothing -> do + nb1 <- getBnodesCheck + if lctxt /= PredContext && lab `notElem` nb1 + then insertBnode lctxt lab + else formatNodeId lab + +formatLabel _ lab@(Res sn) = + case lookup sn specialTable of + Just txt -> return $ quote True txt -- TODO: do we need to quote? + Nothing -> do + pr <- getPrefixes + let nsuri = getScopeURI sn + local = snLocal sn + premap = reverseLookupMap pr :: RevNamespaceMap + prefix = mapFindMaybe nsuri premap + name = case prefix of + Just p -> quote True (p ++ ":" ++ local) -- TODO: what are quoting rules for QNames + _ -> "<"++ quote True (nsuri++local) ++">" + queueFormula lab + return name + +formatLabel _ (Lit lit mlit) = return $ quoteStr lit ++ formatAnnotation mlit + +formatLabel _ lab = return $ show lab + +-- the annotation for a literal (ie type or language) +formatAnnotation :: Maybe ScopedName -> String +formatAnnotation Nothing = "" +formatAnnotation (Just a) | isLang a = '@' : langTag a + | otherwise = '^':'^': showScopedName a + +{- +Swish.Utils.MiscHelpers contains a quote routine +which we expand upon here to match the N3 syntax. + +We have to decide whether to use " or """ to quote +the string. + +There is also no need to restrict the string to the +ASCII character set; this could be an option but we +can also leave Unicode as is (or at least convert to UTF-8). +-} + +quoteStr :: String -> String +quoteStr st = + let qst = quote (n==1) st + n = if '\n' `elem` st || '"' `elem` st then 3 else 1 + qch = replicate n '"' + in qch ++ qst ++ qch + +-- if the first element is True then we need to +-- quote " and new lines. +-- +quote :: Bool -> String -> String +quote _ [] = "" +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 + +formatNodeId :: RDFLabel -> Formatter String +formatNodeId lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ show lab +formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall + +mapBlankNode :: RDFLabel -> Formatter String +mapBlankNode lab = do + ngs <- getNgs + let cmap = nodeMap ngs + cval = nodeGen ngs + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + setNgs $ ngs { nodeGen = nval, nodeMap = nmap } + return nval + + n -> return n + + -- TODO: is this what we want? + return $ "_:swish" ++ show nv + +-- TODO: need to be a bit more clever with this than we did in NTriples +-- not sure the following counts as clever enough ... +-- +showScopedName :: ScopedName -> String +{- +showScopedName (ScopedName n l) = + let uri = nsURI n ++ l + in quote uri +-} +showScopedName = quote True . show + +---------------------------------------------------------------------- +-- Graph-related helper functions +---------------------------------------------------------------------- + +newtype SortedArcs lb = SA [Arc lb] + +sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb +sortArcs = SA . sort + +-- Rearrange a list of arcs into a tree of pairs which group together +-- all statements for a single subject, and similarly for multiple +-- objects of a common predicate. +-- +arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb +arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as + where + spopair (Arc s p o) = (s,(p,o)) + +{- +arcTree as = map spopair $ sort as + where + spopair (Arc s p o) = (s,[(p,[o])]) +-} + +-- Rearrange a list of pairs so that multiple occurrences of the first +-- are commoned up, and the supplied function is applied to each sublist +-- with common first elements to obtain the corresponding second value +commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] +commonFstEq f ps = + [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] + where + fstEq (f1,_) (f2,_) = f1 == f2 + +{- +-- Diagnostic code for checking arcTree logic: +testArcTree = (arcTree testArcTree1) == testArcTree2 +testArcTree1 = + [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" + ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" + ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" + ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" + ] +testArcTree2 = + [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) + ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) + ] +-} + + +findMaxBnode :: RDFGraph -> Int +findMaxBnode = maximum . map getAutoBnodeIndex . labels + +getAutoBnodeIndex :: RDFLabel -> Int +getAutoBnodeIndex (Blank ('_':lns)) = res where + -- cf. prelude definition of read s ... + res = case [x | (x,t) <- reads lns, ("","") <- lex t] of + [x] -> x + _ -> 0 +getAutoBnodeIndex _ = 0 + +{- +Find all blank nodes that occur + - any number of times as a subject + - 0 or 1 times as an object + +Such nodes can be output using the "[..]" syntax. To make it simpler +to check we actually store those nodes that can not be expanded. + +Note that we do not try and expand any bNode that is used in +a predicate position. + +Should probably be using the SubjTree RDFLabel structure but this +is easier for now. + +-} + +countBnodes :: SortedArcs RDFLabel -> [RDFLabel] +countBnodes (SA as) = snd (foldl' ctr ([],[]) as) + where + -- first element of tuple are those blank nodes only seen once, + -- second element those blank nodes seen multiple times + -- + inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (l:b1s, bms) + inc b _ = b + + -- if the bNode appears as a predicate we instantly add it to the + -- list of nodes not to expand, even if only used once + incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (b1s, l:bms) + incP b _ = b + + ctr orig (Arc _ p o) = inc (incP orig p) o + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/N3Parser.hs b/Swish/RDF/N3Parser.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/N3Parser.hs @@ -0,0 +1,1651 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3Parser +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module implements a Notation 3 parser (see [1], [2], [3]), returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied N3 input string, or an error indication. +-- +-- Uses the Parsec monadic parser library. +-- +-- REFERENCES: +-- +-- 1 +-- Notation3 (N3): A readable RDF syntax, +-- W3C Team Submission 14 January 2008 +-- +-- 2 +-- Tim Berners-Lee's design issues series notes and description +-- +-- 3 +-- Notation 3 Primer by Sean Palmer +-- +-- NOTES: +-- +-- UTF-8 handling is not really tested. +-- +-- Several items seem to be allowed (from looking at N3 test suites and files +-- 'in the wild') that are not given supported by the N3 grammar [1]. We try +-- to support these, including +-- +-- - \"@:@\" and \"@base:@\" as valid QNames (ie a blank local component) +-- +-- - @true@ and @false@ as well as @\@true@ and @\@false@ +-- +-- - use of lower-case characters for @\\u@ and @\\U@ escape codes +-- +-- No performance testing has been applied. +-- +-- Not all N3 grammar elements are supported, including: +-- +-- - @\@forSome@ (we read it in but ignore the arguments) +-- +-- - @\@forAll@ (this causes a parse error) +-- +-- - formulae are lightly tested +-- +-- - string support is incomplete (e.g. unrecognized escape characters +-- such as @\\q@ are probably handled incorrectly) +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.N3Parser + ( ParseResult + , parseN3 + , parseN3fromString + , parseAnyfromString + , parseTextFromString, parseAltFromString + , parseNameFromString, parsePrefixFromString + , parseAbsURIrefFromString, parseLexURIrefFromString, parseURIref2FromString + + -- * Exports for parsers that embed Notation3 in a bigger syntax + , N3Parser, N3State(..), SpecialMap + , whiteSpace, symbol, lexeme, eof, identStart, identLetter + -- + , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions + , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct + , quickVariable -- was varid + , lexUriRef + , document, subgraph + , newBlankNode + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , NamespaceMap + , LookupFormula(..) + , addArc + , setFormula + , setNamespaces + , emptyRDFGraph + ) + +import Swish.RDF.GraphClass + ( arc ) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , mapFind, mapFindMaybe, mapReplaceOrAdd ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + , getScopePrefix + , getScopedNameURI + , makeScopedName, makeUriScopedName + , makeQNameScopedName + , nullScopedName + ) + +import Swish.Utils.QName (QName, getQNameURI) + +import Swish.RDF.Vocabulary + ( langName + , rdf_type + , rdf_first, rdf_rest, rdf_nil + , owl_sameAs, log_implies + , xsd_boolean, xsd_integer, xsd_decimal, xsd_double + ) + +import Swish.RDF.RDFParser + ( SpecialMap + , mapPrefix + , prefixTable, specialTable + , ParseResult, RDFParser + , n3Style, n3Lexer, ignore + , annotateParsecError + , mkTypedLit + ) + +import Control.Applicative +import Control.Monad (forM_, foldM) + +import Network.URI (URI, + relativeTo, + parseURI, parseURIReference, uriToString) + +import Data.Maybe (fromMaybe, fromJust) + +import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) +import qualified Text.ParserCombinators.Parsec as PC +import qualified Text.ParserCombinators.Parsec.Token as P + +import Data.Char (isSpace, chr) + + +---------------------------------------------------------------------- +-- Set up token parsers +---------------------------------------------------------------------- + +lexer :: P.TokenParser N3State +lexer = n3Lexer + +whiteSpace :: N3Parser () +whiteSpace = P.whiteSpace lexer + +symbol :: String -> N3Parser String +symbol = P.symbol lexer + +lexeme :: N3Parser a -> N3Parser a +lexeme = P.lexeme lexer + +identStart , identLetter :: CharParser st Char +identStart = P.identStart n3Style +identLetter = P.identLetter n3Style + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | N3 parser state +data N3State = N3State + { graphState :: RDFGraph -- Graph under construction + , thisNode :: RDFLabel -- current context node (aka 'this') + , prefixUris :: NamespaceMap -- namespace prefix mapping table + , syntaxUris :: SpecialMap -- special name mapping table + , nodeGen :: Int -- blank node id generator + , keywordsList :: [String] -- 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 Parsec updateState) +setPrefix :: String -> String -> N3State -> N3State +setPrefix pre uri st = st { prefixUris=p' } + where + p' = mapReplaceOrAdd (Namespace pre uri) (prefixUris st) + +-- | Set name for special syntax element +setSName :: String -> ScopedName -> N3State -> N3State +setSName nam snam st = st { syntaxUris=s' } + where + s' = mapReplaceOrAdd (nam,snam) (syntaxUris st) +setSUri :: String -> String -> N3State -> N3State +setSUri nam suri = setSName nam (makeScopedName "" suri "") + +-- | Set the list of tokens that can be used without needing the leading +-- \@ symbol. +setKeywordsList :: [String] -> N3State -> N3State +setKeywordsList ks st = st { keywordsList = ks, allowLocalNames = True } + +-- Functions to access state: + +-- | Get name for special syntax element, default null +getSName :: N3State -> String -> ScopedName +getSName st nam = mapFind nullScopedName nam (syntaxUris st) + +getSUri :: N3State -> String -> String +getSUri st nam = getScopedNameURI $ getSName st nam + +-- Map prefix to namespace +getPrefixNs :: N3State -> String -> Namespace +getPrefixNs st pre = Namespace pre (mapPrefix (prefixUris st) pre) + +-- Map ScopedName using prefix table +-- (Ignore URI in supplied ScopedName) +getPrefixScopedName :: N3State -> ScopedName -> ScopedName +getPrefixScopedName st snam = ScopedName (getPrefixNs st pre) loc + where + pre = getScopePrefix snam + loc = snLocal snam + +getKeywordsList :: N3State -> [String] +getKeywordsList = keywordsList + +getAllowLocalNames :: N3State -> Bool +getAllowLocalNames = allowLocalNames + +-- Return function to update graph in N3 parser state, +-- using the supplied function of a graph +-- (use returned function with Parsec updateState) +updateGraph :: ( RDFGraph -> RDFGraph ) -> ( N3State -> N3State ) +updateGraph f s = s { graphState = f (graphState s) } + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +type N3Parser a = RDFParser N3State a + +-- | Parse a string as N3 (with no real base URI). +-- +-- See 'parseN3' if you need to provide a base URI. +-- +parseN3fromString :: + String -- ^ input in N3 format. + -> ParseResult +parseN3fromString = parseAnyfromString document Nothing + +-- | Parse a string with an optional base URI. +-- +-- See also 'parseN3fromString'. +-- +parseN3 :: + String -- ^ input in N3 format. + -> Maybe QName -- ^ optional base URI + -> ParseResult +parseN3 = flip (parseAnyfromString document) + +{- +-- useful for testing +test :: String -> RDFGraph +test = either error id . parseAnyfromString document Nothing +-} + +-- | Function to supply initial context and parse supplied term. +-- +-- We augment the Parsec error with the context. +-- +parseAnyfromString :: N3Parser a -- ^ parser to apply + -> Maybe QName -- ^ base URI of the input, or @Nothing@ to use default base value + -> String -- ^ input to be parsed + -> Either String a +parseAnyfromString parser mbase input = + let pmap = LookupMap prefixTable + muri = fmap makeQNameScopedName mbase + smap = LookupMap $ specialTable muri + pstate = 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 + } + + puri = case mbase of + Just base -> fmap showURI $ appendUris (getQNameURI base) "#" + _ -> Right "#" + + -- this is getting a bit ugly + + in case puri of + Left emsg -> Left $ "Invalid base: " ++ emsg + Right p -> case runParser parser (setPrefix "" p pstate) "" input of + Right res -> Right res + Left err -> Left $ annotateParsecError 1 (lines input) err + +newBlankNode :: N3Parser RDFLabel +newBlankNode = do + s <- getState + let n = succ (nodeGen s) + setState $ s { nodeGen = n } + return $ Blank (show n) + +-- Test functions for selected element parsing + +parseTextFromString :: String -> String -> Either String String +parseTextFromString s = + parseAnyfromString (string s) Nothing + +parseAltFromString :: String -> String -> String -> Either String String +parseAltFromString s1 s2 = + parseAnyfromString ( string s1 <|> string s2 ) Nothing + +parseNameFromString :: String -> Either String String +parseNameFromString = + parseAnyfromString n3Name Nothing + +parsePrefixFromString :: String -> Either String Namespace +parsePrefixFromString = + parseAnyfromString p Nothing + where + p = do + pref <- n3Name + st <- getState + return (getPrefixNs st pref) -- map prefix to namespace + +parseAbsURIrefFromString :: String -> Either String String +parseAbsURIrefFromString = + parseAnyfromString (fmap showURI explicitURI) Nothing + -- parseAnyfromString absUriRef Nothing + +parseLexURIrefFromString :: String -> Either String String +parseLexURIrefFromString = + parseAnyfromString lexUriRef Nothing + +parseURIref2FromString :: String -> Either String ScopedName +parseURIref2FromString = + parseAnyfromString n3symbol Nothing + -- parseAnyfromString uriRef2 Nothing + +---------------------------------------------------------------------- +-- Syntax productions +---------------------------------------------------------------------- + +{- + TODO: + - this parser is a *lot* slower than the original one + +-} + +-- 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 = between (symbol lsym) (symbol rsym) + +-- The @ character is optional if the keyword is in the +-- keyword list +-- +atSign :: String -> N3Parser () +atSign s = do + st <- getState + + let p = ignore $ char '@' + + if s `elem` getKeywordsList st + then PC.optional p + else p + +atWord :: String -> N3Parser String +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 $ string s *> notFollowedBy (char ':') + return s + +showURI :: URI -> String +showURI u = uriToString id u "" + +-- TODO: look at using URIs throughout +getScopedNameURI' :: URI -> String +getScopedNameURI' = showURI +-- getScopedNameURI' = getScopedNameURI . makeUriScopedName . showURI + +operatorLabel :: ScopedName -> N3Parser RDFLabel +{- +operatorLabel snam = do + s <- getState + return $ Res $ getPrefixScopedName s snam +-} +operatorLabel snam = (Res . flip getPrefixScopedName snam) <$> getState + +-- Add statement to graph in N3 parser state + +addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> N3Parser () +addStatement s p o = updateState (updateGraph (addArc (arc s p o) )) + +addStatementRev :: RDFLabel -> RDFLabel -> RDFLabel -> N3Parser () +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 +-} + +initChar , bodyChar :: String +initChar = + ['A'..'Z'] ++ "_" ++ ['a'..'z'] ++ + map chr + ([0x00c0..0x00d6] ++ [0x00d8..0x00f6] ++ [0x00f8..0x02ff] ++ [0x0370..0x037d] ++ [0x037f..0x1fff] ++ [0x200c..0x200d] ++ [0x2070..0x218f] ++ [0x2c00..0x2fef] ++ [0x3001..0xd7ff] ++ [0xf900..0xfdcf] ++ [0xfdf0..0xfffd] ++ [0x00010000..0x000effff]) +bodyChar = + '-' : ['0'..'9'] ++ ['A'..'Z'] ++ "_" ++ ['a'..'z'] ++ + map chr + (0x00b7 : [0x00c0..0x00d6] ++ [0x00d8..0x00f6] ++ [0x00f8..0x037d] ++ [0x037f..0x1fff] ++ [0x200c..0x200d] ++ [0x203f..0x2040] ++ [0x2070..0x218f] ++ [0x2c00..0x2fef] ++ [0x3001..0xd7ff] ++ [0xf900..0xfdcf] ++ [0xfdf0..0xfffd] ++ [0x00010000..0x000effff]) + +n3Name :: N3Parser String +n3Name = (:) <$> n3Init <*> n3Body + where + n3Init = oneOf initChar "Initial character of a name" + n3Body = many (oneOf bodyChar) "Body of the name" + +{- +quickvariable ::= \?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]* +-} + +-- TODO: is mapping to Var correct? +quickVariable :: N3Parser RDFLabel +quickVariable = char '?' *> (Var <$> n3Name) "quickvariable" + +{- +string ::= ("""[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""")|("[^"\\]*(?:\\.[^"\\]*)*") + +or + +string ::= tripleQuoted | singleQUoted + +-} + +n3string :: N3Parser String +n3string = tripleQuoted <|> singleQuoted "string" + +{- +singleQuoted ::= "[^"\\]*(?:\\.[^"\\]*)*" + +asciiChars :: String +asciiChars = map chr [0x20..0x7e] + +asciiCharsN3 :: String +asciiCharsN3 = filter (`notElem` "\\\"") asciiChars + +-} + +-- the grammer has only upper-case A-F but some lower case values +-- seen in the wild, so support them +-- +ntHexDigit :: N3Parser Char +ntHexDigit = oneOf $ ['0'..'9'] ++ ['A'..'F'] ++ ['a'..'f'] + +hex4 :: N3Parser Char +hex4 = do + digs <- count 4 ntHexDigit + let dstr = "0x" ++ digs + dchar = read dstr :: Int + return $ chr dchar + +hex8 :: N3Parser Char +hex8 = do + digs <- count 8 ntHexDigit + let dstr = "0x" ++ digs + dchar = read dstr :: Int + if dchar <= 0x10FFFF + then return $ chr dchar + else unexpected "\\UHHHHHHHH format is limited to a maximum of \\U0010FFFF" + +{- +This is very similar to NTriples accept that also allow the escaping of ' +even though it is not required. + +The Python rules allow \N{name}, where name is the Unicode name. It's +not clear whether we need to support this too, so for now we do not. + +-} +protectedChar :: N3Parser Char +protectedChar = + (char 't' *> return '\t') + <|> (char 'n' *> return '\n') + <|> (char 'r' *> return '\r') + <|> (char '"' *> return '"') + <|> (char '\'' *> return '\'') + <|> (char '\\' *> return '\\') + <|> (char 'u' *> hex4) + <|> (char 'U' *> hex8) + +-- Accept an escape character or any character as long as it isn't +-- a new-line or quote. Unrecognized escape sequences should therefore +-- be left alone by this. +-- +n3Character :: N3Parser Char +n3Character = + (char '\\' *> (protectedChar <|> return '\\')) + <|> noneOf "\"\n" + +{- + <|> (oneOf asciiCharsN3 "ASCII character") + -- TODO: bodyChar and asciiCharsN3 overlap + <|> (oneOf bodyChar "Unicode character") +-} + +sQuot :: N3Parser Char +sQuot = char '"' + +singleQuoted :: N3Parser String +singleQuoted = between sQuot sQuot $ many n3Character + +{- +tripleQUoted ::= """[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""" +-} +tripleQuoted :: N3Parser String +tripleQuoted = tQuot *> manyTill (n3Character <|> sQuot <|> char '\n') tQuot + where + tQuot = try (count 3 sQuot) + +getDefaultPrefix :: N3Parser Namespace +getDefaultPrefix = do + s <- getState + return (getPrefixNs s "") + +addBase :: URI -> N3Parser () +addBase = updateState . setSUri "base" . getScopedNameURI' + +addPrefix :: Maybe String -> URI -> N3Parser () +addPrefix p = updateState . setPrefix (fromMaybe "" p) . getScopedNameURI' + +{-| +Update the set of keywords that can be given without +an \@ sign. +-} +updateKeywordsList :: [String] -> N3Parser () +updateKeywordsList = updateState . setKeywordsList + +{- +document ::= | statements_optional EOF +-} + +document :: N3Parser RDFGraph +document = mkGr <$> (whiteSpace *> statementsOptional *> eof *> getState) + 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 = + (try (atWord "base") >> explicitURI >>= addBase) + <|> + (try (atWord "keywords") >> bareNameCsl >>= updateKeywordsList) + <|> + (try (atWord "prefix") *> getPrefix) + "declaration" + +getPrefix :: N3Parser () +getPrefix = do + p <- lexeme prefix + u <- explicitURI + addPrefix p u + +{- +explicituri ::= <[^>]*> + +Note: white space is to be ignored within <> +-} + +explicitURI :: N3Parser URI +explicitURI = do + let lb = char '<' + rb = char '>' + + -- TODO: do the whitespace definitions match? + ustr <- between lb (rb "end of URI '>'") $ many (satisfy (/= '>')) + let uclean = filter (not . isSpace) ustr + + s <- getState + let base = getSUri s "base" + + case appendUris base uclean of + Right uri -> return uri + Left emsg -> fail emsg + +appendUris :: String -> String -> Either String URI +appendUris base uri = + case parseURI uri of + Just absuri -> Right absuri + _ -> case parseURIReference uri of + Just reluri -> + let baseuri = fromJust $ parseURI base + in case relativeTo reluri baseuri of + Just resuri -> Right resuri + _ -> Left $ "Unable to append <" ++ uri ++ "> to base=<" ++ base ++ ">" + + _ -> Left $ "Invalid URI: <" ++ uri ++ ">" + +-- production from the old parser +lexUriRef :: N3Parser String +lexUriRef = fmap showURI $ 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 [String] +bareNameCsl = sepBy (lexeme bareName) comma + +bareName :: N3Parser String +bareName = n3Name "barename" + +{- +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 String) +prefix = optional (lexeme n3Name) <* char ':' + "prefix name" + +{- +symbol ::= | explicituri + | qname +symbol_csl ::= | symbol symbol_csl_tail + | void +symbol_csl_tail ::= | "," symbol symbol_csl_tail + | void + +-} + +n3symbol :: N3Parser ScopedName +n3symbol = + ((makeUriScopedName . showURI) <$> explicitURI) + <|> qname + "symbol" + +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]* + +Turtle appears to support ':' as a valid qname, which is not +supported by the above production. Let's support and see +what happens. This support may be removed since, if we allow +white space between : and prefix or local name then statements like + : a : b : c . +are not parseable. + +TODO: + Note that, for now, we explicitly handle blank nodes + (of the form _:name) direcly in pathItem'. + This is not a good idea since qname' is used elsewhere + and so shouldn't we do the same thing there too? +-} + +qname :: N3Parser ScopedName +qname = + (char ':' *> toSN getDefaultPrefix) + <|> (n3Name >>= fullOrLocalQName) + "QName" + where + toSN p = ScopedName <$> p <*> (n3Name <|> return "") + +fullOrLocalQName :: String -> N3Parser ScopedName +fullOrLocalQName name = + (char ':' *> fullQName name) + <|> localQName name + +fullQName :: String -> N3Parser ScopedName +fullQName name = do + pre <- findPrefix name + lname <- n3Name <|> return "" + return $ ScopedName pre lname + +findPrefix :: String -> N3Parser Namespace +findPrefix pre = do + st <- getState + case mapFindMaybe pre (prefixUris st) of + Just uri -> return $ Namespace pre uri + Nothing -> unexpected $ "Prefix '" ++ pre ++ ":' not bound." + +localQName :: String -> N3Parser ScopedName +localQName name = do + st <- getState + if getAllowLocalNames st + then do + pre <- getDefaultPrefix + return $ ScopedName pre name + + else fail "Invalid 'bare' word" -- 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 () + +{- +simpleStatement ::= | subject propertylist +-} + +simpleStatement :: N3Parser () +simpleStatement = subject >>= propertyListWith + +{- +subject ::= | expression +-} + +subject :: N3Parser RDFLabel +subject = lexeme expression + +{- +expression ::= | pathitem pathtail +pathtail ::= | "!" expression + | "^" expression + | void + +-} + +expression :: N3Parser RDFLabel +expression = do + i <- pathItem + + let backwardExpr = char '!' *> return addStatementRev + forwardExpr = char '^' *> return addStatement + + mpt <- optional + ( (,) <$> lexeme (forwardExpr <|> backwardExpr) <*> lexeme expression ) + case mpt of + Nothing -> return i + Just (addFunc, pt) -> do + bNode <- newBlankNode + addFunc bNode pt i + return bNode + +{- +pathitem ::= | "(" pathlist ")" + | "[" propertylist "]" + | "{" formulacontent "}" + | boolean + | literal + | numericliteral + | quickvariable + | symbol + +pathlist ::= | expression pathlist + | void + +Need to think about how to handle formulae, since need to know the context +of the call to know where to add them. + +TOOD: may include direct support for blank nodes here, +namely convert _:stringval -> Blank stringval since although +this should be done by symbol the types don't seem to easily match +up (at first blush anyway) +-} + +pathItem :: N3Parser RDFLabel +pathItem = + br "(" ")" pathList + <|> br "[" "]" propertyListBNode + <|> br "{" "}" formulaContent + <|> try boolean + <|> literal + <|> numericLiteral + <|> quickVariable + <|> Blank <$> (string "_:" *> n3Name) -- TODO a hack that needs fixing + <|> Res <$> n3symbol + "pathitem" + +{- +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) "pathlist" + eNode <- operatorLabel rdf_nil + case cts of + [] -> return eNode + + (c:cs) -> do + sNode <- newBlankNode + first <- operatorLabel rdf_first + addStatement sNode first c + lNode <- foldM addElem sNode cs + rest <- operatorLabel rdf_rest + addStatement lNode rest eNode + return sNode + + where + addElem prevNode curElem = do + bNode <- newBlankNode + first <- operatorLabel rdf_first + rest <- operatorLabel rdf_rest + addStatement prevNode rest bNode + addStatement bNode first curElem + return bNode + +{- +formulacontent ::= | statementlist + +statementlist ::= | statement statementtail + | void +statementtail ::= | "." statementlist + | void +-} + +{- +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 <- getState + let fstate = pstate { graphState = emptyRDFGraph, thisNode = bNode } + setState fstate + statementList + fstate' <- getState + let nstate = pstate { nodeGen = nodeGen fstate' } + setState nstate + updateState $ updateGraph $ setFormula (Formula bNode (graphState fstate')) + return bNode + +-- need to work out what is going on here +subgraph :: RDFLabel -> N3Parser RDFGraph +subgraph = undefined + +{- +subgraph :: RDFLabel -> N3Parser RDFGraph +subgraph this = do + pstate <- getState + let fstate = pstate { graphState = emptyRDFGraph, thisNode = this } + setState fstate -- switch new state into parser + statements -- parse statements of formula + fstate' <- getState + let nstate = pstate { nodeGen = nodeGen fstate' } + setState nstate -- swap back state, with updated nodeGen + return (graphState fstate') +-} + +statementList :: N3Parser () +statementList = ignore $ sepEndBy (lexeme statement) fullStop + +{- +boolean ::= | "@false" + | "@true" +-} + +boolean :: N3Parser RDFLabel +boolean = mkTypedLit xsd_boolean <$> + (try (atWord "false") <|> atWord "true") + +{- +dtlang ::= | "@" langcode + | "^^" symbol + | void +literal ::= | string dtlang + +langcode ::= [a-z]+(-[a-z0-9]+)* + +-} + +literal :: N3Parser RDFLabel +literal = Lit <$> n3string <*> optionMaybe dtlang + +dtlang :: N3Parser ScopedName +dtlang = + (char '@' *> langcode "langcode") + <|> (try (string "^^") *> n3symbol) + "dtlang" + +langcode :: N3Parser ScopedName +langcode = do + h <- many1 (oneOf ['a'..'z']) "start of langcode (a to z)" + mt <- optionMaybe ( (:) <$> char '-' <*> many1 (oneOf (['a'..'z'] ++ ['0'..'9']))) "a to z or 0 to 9 (langcode after the hyphen)" + return $ langName $ h ++ fromMaybe "" mt + +{- +decimal ::= [-+]?[0-9]+(\.[0-9]+)? +double ::= [-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+) +integer ::= [-+]?[0-9]+ +numericliteral ::= | decimal + | double + | integer +-} + +numericLiteral :: N3Parser RDFLabel +numericLiteral = + try (mkTypedLit xsd_double <$> n3double) + <|> try (mkTypedLit xsd_decimal <$> n3decimal) + <|> mkTypedLit xsd_integer <$> n3integer + "numericliteral" + +n3sign :: N3Parser Char +n3sign = char '+' <|> char '-' + +n3integer :: N3Parser String +n3integer = do + ms <- optionMaybe n3sign + ds <- many1 digit + case ms of + Just s -> return $ s : ds + _ -> return ds + +n3decimal :: N3Parser String +n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many1 digit ) + +n3double :: N3Parser String +n3double = (++) <$> n3decimal <*> ( (:) <$> oneOf "eE" <*> n3integer ) + +{- +propertylist ::= | verb object objecttail propertylisttail + | void +propertylisttail ::= | ";" propertylist + | void + +-} + +propertyListBNode :: N3Parser RDFLabel +propertyListBNode = do + plist <- sepEndBy ((,) <$> lexeme verb <*> objectList) semiColon + bNode <- newBlankNode + let addList (vrb,items) = mapM_ (addItem vrb) items + addItem (True,vrb) obj = addStatement bNode vrb obj + addItem (_,vrb) subj = addStatement subj vrb bNode + + forM_ plist addList + return bNode + +propertyListWith :: RDFLabel -> N3Parser () +propertyListWith subj = + ignore $ sepEndBy (lexeme verb >>= objectListWith subj) 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 :: RDFLabel -> (Bool, RDFLabel) -> N3Parser () +objectWith subj (flag,vrb) = object >>= addFunc subj vrb + where + addFunc = if flag then addStatement else addStatementRev + +objectListWith :: RDFLabel -> (Bool, RDFLabel) -> N3Parser () +objectListWith subj vrb = + ignore $ sepBy1 (objectWith subj vrb) comma + +{- +objectList1 :: N3Parser [RDFLabel] +objectList1 = sepBy1 object comma +-} + +{- +verb ::= | "<=" + | "=" + | "=>" + | "@a" + | "@has" expression + | "@is" expression "@of" + | expression +-} + +verb :: N3Parser (Bool, RDFLabel) +verb = + -- we check reverse first so that <= is tried before looking for a URI via expression rule + (,) False <$> verbReverse + <|> (,) True <$> verbForward + "verb" + +-- those verbs for which subject is on the right and object on the left +verbReverse :: N3Parser RDFLabel +verbReverse = + try (string "<=") *> operatorLabel log_implies + <|> 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 log_implies) + <|> (string "=" *> operatorLabel owl_sameAs) + <|> (try (atWord "a") *> operatorLabel rdf_type) + <|> (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") *> + unexpected "universal (@forAll) currently unsupported." + -- will be something like: *> symbolCsl + +{- + +-- OLD -- + +-- helper routines + +isymbol :: String -> N3Parser () +isymbol s = symbol s >> return () + +-- document = directive* statement-list + +document :: N3Parser RDFGraph +document = do + whiteSpace + _ <- many directive + statements + eof + s <- getState + return $ setNamespaces (prefixUris s) (graphState s) + +-- directive = "@prefix" prefix ":" uriRef2 "." // Namespace declaration +-- | "@prefix" ":" uriRef2 "." // Default namespace +-- | "@equivalence" uriRef2 "." // Alternative to daml:equivalent +-- | "@listfirst" uriRef2 "." // Alternative to n3:first +-- | "@listrest" uriRef2 "." // Alternative to n3:rest +-- | "@listnull" uriRef2 "." // Alternative to n3:null +-- | "@plus" uriRef2 "." // Alternative to operator:plus +-- | "@minus" uriRef2 "." // Alternative to operator:minus +-- | "@slash" uriRef2 "." // Alternative to operator:slash +-- | "@star" uriRef2 "." // Alternative to operator:star +-- | "@base" uriRef2 "." // Base URI for relative URIs. + +directive :: N3Parser () +directive = + (try (symbol "@prefix") >> (defaultPrefix <|> namedPrefix)) + <|> (string "@" >> syntaxUri) + "directive" + +defaultPrefix :: N3Parser () +defaultPrefix = do + u <- br ":" "." uriRef2 + updateState $ setPrefix "" (getScopedNameURI u) + +namedPrefix :: N3Parser () +namedPrefix = do + n <- name + u <- br ":" "." uriRef2 + updateState $ setPrefix n (getScopedNameURI u) + +syntaxUri :: N3Parser () +syntaxUri = do + s <- uriName + u <- uriRef2 + isymbol "." + updateState $ setSUri s (getScopedNameURI u) + +uriName :: N3Parser String +uriName = + try (symbol "equivalence") + <|> try (symbol "listfirst") + <|> try (symbol "listrest") + <|> try (symbol "listnull") + <|> try (symbol "plus") + <|> try (symbol "minus") + <|> try (symbol "slash") + <|> try (symbol "star") + <|> try (symbol "base") + "special URI directive" + + +-- statements = [ statement ( "." statement )* ] +-- +-- statement = subject property-list +-- +-- properties = [ property ( ";" property )* ] +-- +-- New statements are added to the user state graph + +statements :: N3Parser () +statements = sepEndBy1 statement (symbol ".") >> return () + +statement :: N3Parser () +-- statement = subject >>= optional . properties -- when using Parsec's optional +statement = subject >>= optional . properties >> return () -- not sure this is exactly the same as with Parsec + +properties :: RDFLabel -> N3Parser () +properties subj = sepBy1 (property subj) (symbol ";") >> return () + + +-- property = verb object-list +-- | ":-" anon-node // Creates anon-node aongside the current node +-- verb = ">-" prop "->" // has 'prop' of +-- | "<-" prop "<-" // is 'prop' of +-- | operator // has operator:'operator' of (???) +-- | prop // has 'prop' of -- shorthand +-- | "has" prop "of" // has 'prop' of +-- | "is" prop "of" // is 'prop' of +-- | "a" // has rdf:type of +-- | "=" // has daml:equivalent of +-- +-- subj is the subject node for these properties. +-- +-- New statements are added to the graph in the parser's user state. + +property :: RDFLabel -> N3Parser () +property subj = + (verb >>= uncurry (objects subj)) + <|> + (isymbol ":-" >> anonNode subj >> return ()) + +verb :: N3Parser (RDFLabel,Bool) +verb = + (prop >>= \p -> return (p, False)) + <|> (operator >>= \p -> return (p, False)) + <|> (br ">-" "->" prop >>= \p -> return (p, False)) + <|> (br "<-" "<-" prop >>= \p -> return (p, True)) + <|> (br "has" "of" prop >>= \p -> return (p, False)) + <|> (br "is" "of" prop >>= \p -> return (p, True)) + <|> (symbol "a" >> operatorLabel rdf_type >>= \lab -> return (lab, False)) + <|> (symbol "=" >> operatorLabel owl_sameAs >>= \lab -> return (lab, False)) + "property" + + +-- objects = object +-- | object "," object-list +-- +-- subj is the subject node for the new statements, +-- prop is the property node for the new statements. +-- swap is true if the subject/object values in the resulting statement +-- are to be swapped (for "is of", etc.) +-- +-- New statements are added to the graph in the parser's user state + +objects :: RDFLabel -> RDFLabel -> Bool -> N3Parser () +objects subj ppty swap = + sepBy1 (object subj ppty swap) (symbol ",") >> return () + +-- anonNode = "[" property-list "]" // Something with given properties +-- | "{" statement-list "}" // List of statements as resource +-- | "(" node-list ")" // Construct list with +-- // rdf:first, rdf:rest, rdf:nil +-- +-- subj is the subject node with which the new anonymous node is equated, +-- +-- The anonymous node value is returned by this parser (which is often the same +-- as the supplied subject node, but not always). +-- +-- New statements are added to the graph in the parser's user state +-- (in the case of a formula, a new graph and parser are created, and +-- the graph arcs are added to this new graph). + +anonNode :: RDFLabel -> N3Parser RDFLabel +anonNode subj = + (br "[" "]" (properties subj) >> return subj) + <|> br "{" "}" (formula subj) + <|> br "(" ")" (nodeList subj) + "anon node (\"[\", \"(\" or \"{\")" + +-- This method allows a statement list to be parsed as a subgraph +-- whose value is associated with the supplied node of the current +-- graph. + +formula :: RDFLabel -> N3Parser RDFLabel +formula subj = do + subgr <- subgraph subj + updateState + $ updateGraph + $ setFormula (Formula subj subgr) + return subj + +subgraph :: RDFLabel -> N3Parser RDFGraph +subgraph this = do + pstate <- getState + let fstate = pstate { graphState = emptyRDFGraph, thisNode = this } + setState fstate -- switch new state into parser + statements -- parse statements of formula + fstate' <- getState + let nstate = pstate { nodeGen = nodeGen fstate' } + setState nstate -- swap back state, with updated nodeGen + return (graphState fstate') + +-- prop = uri-ref2 +-- | varid +-- +-- Returns URI value as a Node + +prop :: N3Parser RDFLabel +prop = nodeid <|> varid <|> uriNode + + +-- operator = "+" // >- operator:plus -> +-- | "-" // >- operator:minus -> +-- | "/" // >- operator:slash -> +-- | "*" // >- operator:star-> +-- +-- If matched, the operator is returned as a node value. + +operator :: N3Parser RDFLabel +operator = + (symbol "+" >> operatorLabel operator_plus) + <|> (symbol "-" >> operatorLabel operator_minus) + <|> (symbol "*" >> operatorLabel operator_star) + <|> (symbol "/" >> operatorLabel operator_slash) + "" + +-- subject = node + +subject :: N3Parser RDFLabel +subject = node + + +-- object = litNode +-- +-- This production adds a new triple to the graph state, +-- using the supplied subject and property values. +-- If swap is True, the subject and object positions are +-- swapped. + +object :: RDFLabel -> RDFLabel -> Bool -> N3Parser () +object subj ppty True = do + o <- litNode + addStatement o ppty subj + +object subj ppty _ = do + o <- litNode + addStatement subj ppty o + +-- nodeList = litNode* +-- +-- subj is the node from which the list is linked. +-- +-- Returns the supplied head of list or Nil node allocated. +-- +-- Link first element of link to list head, scan rest of list, +-- and return the list head; otherwise return a node rdf_null. +-- +-- This slightly convoluted pattern is to deal with two different +-- occurrences of a list node: +-- :- ( l1, l2, ... ) +-- Here, (the supplied subj) is the listhead. +-- prop ( l1, l2, ... ) +-- Here, the a new blank is supplied as subj to be the listhead. +-- In either case, if the list is non-empty, the supplied subj +-- is returned. But if the list is empty, a rdf_null node is returned. +-- In the second case, the invoking production must use the returned +-- value. + +nodeList :: RDFLabel -> N3Parser RDFLabel +nodeList subj = + (do + val <- litNode + first <- operatorLabel rdf_first + addStatement subj first val + nodeList1 subj + return subj) + <|> operatorLabel rdf_nil + "Node or ')'" + +nodeList1 :: RDFLabel -> N3Parser () +nodeList1 prev = + (do + val <- litNode + lnk <- newBlankNode + first <- operatorLabel rdf_first + rest <- operatorLabel rdf_rest + addStatement lnk first val + addStatement prev rest lnk + nodeList1 lnk) + <|> (do + nil <- operatorLabel rdf_nil + rest <- operatorLabel rdf_rest + addStatement prev rest nil) + "Node or ')'" + + +-- lit-node = node +-- | str-node [ "@" lang ] [ "^^" uriRef2 ] +-- str-node = '"' constant-value '"' +-- | '"""' constant value '"""' // Including single or double occurences of +-- // quotes and/or newlines +-- +-- Returns a new node value. + +litNode :: N3Parser RDFLabel +litNode = + node + <|> liftM2 Lit strNode litTypeOrLang + "URI, blank node or literal" + +strNode :: N3Parser String +strNode = + tripleQuoteString + <|> singleQuoteString + + +litTypeOrLang :: N3Parser (Maybe ScopedName) +litTypeOrLang = + langTag + <|> typeUri + <|> return Nothing + "'@tag' (language tag) or '^^name' (datatype URI)" + +langTag :: N3Parser (Maybe ScopedName) +langTag = + fmap (Just . langName) (string "@" >> name) + "'@tag' (language tag)" + +typeUri :: N3Parser (Maybe ScopedName) +typeUri = + fmap Just (string "^^" >> uriRef2) + "'^^name' (datatype URI)" + +-- node = nodeid +-- | varid +-- | uri-ref2 +-- | anon-node +-- +-- nodeid = "_:" name +-- +-- varid = "?" name +-- +-- Returns a new node value. + +node :: N3Parser RDFLabel +node = nodeid + <|> varid + <|> uriNode + <|> (newBlankNode >>= anonNode) + "URI or blank node" + +-- Identified blank node in input +-- +-- Note that automatically generated blank node identifiers start with +-- a digit, where input node identifiers start with a letter, so there +-- can be no clash. Care is needed when serializing a graph to ensure +-- that future clashes are avoided. + +nodeid :: N3Parser RDFLabel +-- nodeid = lexeme nodeid1 +nodeid = fmap Blank (string "_:" >> name) + +-- variable identifier + +varid :: N3Parser RDFLabel +varid = fmap Var (string "?" >> name) + +-- uriNode = qname +-- | "<" URI-reference ">" +-- | "this" + +uriNode :: N3Parser RDFLabel +uriNode = + fmap Res uriRef2 + <|> fmap thisNode (string "this" >> getState) + "URI node" + + +-- uriRef2 = qname +-- | ":" local-name +-- | "<" URI-reference ">" +-- qname = prefix ":" local-name +-- +-- prefix = name // Namespace prefix +-- +-- local-name = name // Local name (namespace qualified) +-- +-- name = alpha alphanumeric* +-- +-- alpha = "a"-"z" +-- | "A"-"Z" +-- | "_" +-- +-- alphanumeric = alpha +-- | "0"-"9" +-- +-- URI-reference = (conforming to syntax in RFC2396) +-- +-- uriRef2 returns a ScopedName. + +uriRef2 :: N3Parser ScopedName +uriRef2 = lexeme (try uriRef2a) + "URI or QName" + +uriRef2a :: N3Parser ScopedName +uriRef2a = + liftM2 ScopedName prefix (colon >> localname) + <|> (colon >> liftM2 ScopedName defaultprefix localname) + <|> fmap makeUriScopedName absUriRef + "URI or QName" + +prefix :: N3Parser Namespace +prefix = do + pref <- prefixname + st <- getState + return (getPrefixNs st pref) -- map prefix to namespace + +defaultprefix :: N3Parser Namespace +defaultprefix = do + st <- getState + return (getPrefixNs st "") + +name :: N3Parser String +name = lexeme $ name1 identStart + +prefixname :: N3Parser String +prefixname = name1 identStart + +localname :: N3Parser String +localname = lexeme $ name1 identLetter + +-- 'name1' is a name without following whitespace +-- initChar is a parser for the first character +name1 :: N3Parser Char -> N3Parser String +name1 initChar = + liftM2 (:) initChar (many identLetter) + "identifier" + + +---------------------------------------------------------------------- +-- Lexical support +---------------------------------------------------------------------- +-- +-- The following code adapted from ParsecToken, +-- modified to handle different escape conventions and triple-quoted strings +-- \c +-- \uhhhh +-- \Uhhhhhhhh +-- +-- Regular single-quoted string -- cannot be split over line breaks + +singleQuoteString :: N3Parser String +singleQuoteString = + lexeme + ( between (char '"') (char '"' "end of string (\")") anyStringChars + "literal string" ) + +anyStringChars :: CharParser st String +anyStringChars = + fmap (foldr (maybe id (:)) "") (many stringChar) + +-- Triple-quoted string -- may include line breaks, '"' or '""'. +tripleQuoteString :: N3Parser String +tripleQuoteString = + lexeme + (fmap (foldr (++) "") $ between (try $ string "\"\"\"") + (string "\"\"\"" "end of string (\"\"\")") + (many tripleQuoteSubstring)) + "triple-quoted literal string" + +-- Match non-quote substring or one or two quote characters +tripleQuoteSubstring :: N3Parser String +tripleQuoteSubstring = + tripleQuoteSubstring1 + <|> try sqTripleQuoteSubstring1 + <|> try dqTripleQuoteSubstring1 + +dqTripleQuoteSubstring1 :: N3Parser String +dqTripleQuoteSubstring1 = + fmap ("\"\""++) $ string "\"\"" >> tripleQuoteSubstring1 + +sqTripleQuoteSubstring1 :: N3Parser String +sqTripleQuoteSubstring1 = + fmap ('"':) $ char '"' >> tripleQuoteSubstring1 + +-- match at least one non-quote character in a triple-quoted string +tripleQuoteSubstring1 :: N3Parser String +tripleQuoteSubstring1 = + fmap (foldr (maybe id (:)) "") $ many1 tripleQuoteStringChar + +tripleQuoteStringChar :: CharParser st (Maybe Char) +tripleQuoteStringChar = + stringChar <|> (string "\n" >> return (Just '\n')) + +stringChar :: CharParser st (Maybe Char) +stringChar = + fmap Just stringLetter + <|> stringEscape + "string character" + +stringLetter :: CharParser st Char +stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c >= '\032')) + +stringEscape :: CharParser st (Maybe Char) +stringEscape = + fmap Just $ char '\\' >> escapeCode + +-- escape codes +escapeCode :: CharParser st Char +escapeCode = charEsc <|> charUCS2 <|> charUCS4 "escape code" + +-- \c +charEsc :: CharParser st Char +charEsc = choice (map parseEsc escMap) + where + parseEsc (c,code) = fmap (const code) (char c) + escMap = zip "nrt\\\"\'" "\n\r\t\\\"\'" + +-- \uhhhh +charUCS2 :: CharParser st Char +charUCS2 = + fmap chr $ char 'u' >> numberFW 16 hexDigit 4 0 + +-- \Uhhhhhhhh +charUCS4 :: CharParser st Char +charUCS4 = + fmap chr $ char 'U' >> numberFW 16 hexDigit 8 0 + +-- parse fixed-width number: +numberFW :: Int -> CharParser st Char -> Int -> Int -> CharParser st Int +numberFW _ _ 0 val = return val +numberFW base baseDigit width val = do + d <- baseDigit + numberFW base baseDigit (width-1) (val*base + digitToInt d) + + +---------------------------------------------------------------------- +-- Parse a URI reference from the input +-- The result returned has absolute form; relative URIs are resolved +-- relative to the current base prefix (set using "@base"). +-- + +-- lexeme version +lexUriRef :: N3Parser String +lexUriRef = lexeme absUriRef + +-- from Swish.Utils.ProcessURI +absoluteUriPart :: String -- ^ URI base + -> String -- ^ URI reference + -> String +absoluteUriPart base rel = showURI $ fromJust $ relativeTo (fromJust (parseURIReference rel)) (fromJust (parseURI base)) + +absUriRef :: N3Parser String +absUriRef = do + u <- between (char '<') (char '>' "end of URI '>'") anyUriChars + if isURI u + then return u + else if isURIReference u + then do + s <- getState + return $ absoluteUriPart (getSUri s "base") u + else fail ("Invalid URI: <"++u++">") + +anyUriChars :: N3Parser String +anyUriChars = many uriChar + +uriChar :: N3Parser Char +uriChar = + alphaNum + <|> oneOf "[];?:@&=+$,-_.!~*'()%//#" + "URI character" + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/NTFormatter.hs b/Swish/RDF/NTFormatter.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/NTFormatter.hs @@ -0,0 +1,217 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3Formatter +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module implements a NTriples formatter (see [1]) +-- for an RDFGraph value. +-- +-- +-- REFERENCES: +-- +-- 1 +-- RDF Test Cases +-- W3C Recommendation 10 February 2004 +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.NTFormatter + ( NodeGenLookupMap + , formatGraphAsString + , formatGraphAsShowS + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , getArcs + ) + +import Swish.RDF.GraphClass + ( Arc(..) ) + +import Swish.Utils.Namespace (ScopedName(..), nsURI) +import Swish.RDF.Vocabulary (isLang, langTag) + +import Swish.Utils.LookupMap + ( LookupMap, emptyLookupMap + , mapFind, mapAdd + ) + +import Text.Printf (printf) +import Data.Char (ord) + +-- import "mtl" Control.Monad.State +import Control.Monad.State + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- This is a lot simpler than other formatters. + +-- | Node name generation state information that carries through +-- and is updated by nested formulae +type NodeGenLookupMap = LookupMap (RDFLabel,Int) + +data NTFormatterState = NTFS { + ntfsNodeMap :: NodeGenLookupMap, + ntfsNodeGen :: Int + } deriving Show + +emptyNTFS :: NTFormatterState +emptyNTFS = NTFS { + ntfsNodeMap = emptyLookupMap, + ntfsNodeGen = 0 + } + +type Formatter a = State NTFormatterState a + +---------------------------------------------------------------------- +-- Define a top-level formatter function: +-- accepts a graph and returns a string +---------------------------------------------------------------------- + +formatGraphAsString :: RDFGraph -> String +formatGraphAsString gr = formatGraphAsShowS gr "\n" + +formatGraphAsShowS :: RDFGraph -> ShowS +formatGraphAsShowS gr = + let (out, _, _) = formatGraphInternal gr + in out + +formatGraphInternal :: RDFGraph -> (ShowS, NodeGenLookupMap, Int) +formatGraphInternal gr = + let (out, st) = runState (formatGraph gr) emptyNTFS + in (out, ntfsNodeMap st, ntfsNodeGen st) + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +-- Are there better ways to do this (could look at moving to a Builder +-- style system)? +-- +applyShowS :: [ShowS] -> ShowS +applyShowS = foldr (.) id + +formatGraph :: RDFGraph -> Formatter ShowS +formatGraph gr = do + ls <- mapM formatArc (getArcs gr) + return $ applyShowS ls + +formatArc :: Arc RDFLabel -> Formatter ShowS +formatArc (Arc s p o) = do + sl <- formatLabel s + pl <- formatLabel p + ol <- formatLabel o + return $ applyShowS $ map showString [sl, " ", pl, " ", ol, " .\n"] + +{- +If we have a blank node then can + + - use the label it contains + - generate a new one on output + +For now we create new labels whatever the input was since this +simplifies things, but it may be changed. + +formatLabel :: RDFLabel -> Formatter String +formatLabel lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ show lab +formatLabel lab = return $ show lab +-} + +formatLabel :: RDFLabel -> Formatter String +formatLabel lab@(Blank _) = mapBlankNode lab +formatLabel (Res sn) = return $ showScopedName sn +formatLabel (Lit lit Nothing) = return $ quoteStr lit +formatLabel (Lit lit (Just nam)) | isLang nam = return $ quoteStr lit ++ "@" ++ langTag nam + | otherwise = return $ quoteStr lit ++ "^^" ++ showScopedName nam + +-- do not expect to get the following, but include +-- just in case rather than failing +formatLabel lab = return $ show lab + +mapBlankNode :: RDFLabel -> Formatter String +mapBlankNode lab = do + st <- get + let cmap = ntfsNodeMap st + cval = ntfsNodeGen st + + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + + put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval } + return nval + + n -> return n + + return $ "_:swish" ++ show nv + +showScopedName :: ScopedName -> String +showScopedName (ScopedName n l) = + let uri = nsURI n ++ l + in "<" ++ quote uri ++ ">" + +{- +Swish.Utils.MiscHelpers contains a quote routine +which we expand upon here to match the NT syntax. +-} + +quoteStr :: String -> String +quoteStr st = ['"'] ++ quote st ++ ['"'] + +quote :: String -> String +quote [] = "" +quote ('\\':st) = '\\':'\\': quote st +quote ('"': st) = '\\':'"': quote st +quote ('\n':st) = '\\':'n': quote st +quote ('\r':st) = '\\':'r': quote st +quote ('\t':st) = '\\':'t': quote st +quote (c:st) = + let nc = ord c + rst = quote 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 + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/NTParser.hs b/Swish/RDF/NTParser.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/NTParser.hs @@ -0,0 +1,401 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : NTParser +-- Copyright : (c) 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module implements a NTriples parser (see [1]), returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied NTriples input string, or an error indication. +-- +-- Uses the Parsec monadic parser library. +-- +-- REFERENCES: +-- +-- 1 +-- RDF Test Cases +-- W3C Recommendation 10 February 2004 +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.NTParser + ( ParseResult + , parseNT + , parsefromString + + -- * Exports for parsers that embed NTriples in a bigger syntax + , NTParser, NTState(..) + , ntripleDoc + , line, ws, comment, eoln + , character, name, triple + , subject, predicate, object + , uriref, urirefLbl + , nodeID, literal, language + + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , addArc + , emptyRDFGraph + ) + +import Swish.RDF.GraphClass + ( arc ) + +import Swish.Utils.Namespace + ( ScopedName(..) + , makeUriScopedName + ) + +import Swish.RDF.Vocabulary (langName) + +import Swish.RDF.RDFParser + ( ParseResult, RDFParser + , ignore + , annotateParsecError + ) + +import Control.Applicative +import Control.Monad (when) + +import Network.URI (parseURI) + +import Data.Char (chr) +import Data.Maybe (fromMaybe, isNothing) + +import Text.ParserCombinators.Parsec hiding (many, optional, (<|>)) + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | NT parser state +data NTState = NTState + { graphState :: RDFGraph -- Graph under construction + } + +-- Return function to update graph in NT parser state, +-- using the supplied function of a graph +-- (use returned function with Parsec updateState) +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 +---------------------------------------------------------------------- + +type NTParser a = RDFParser NTState a + +-- | Parse a string. +-- +parseNT :: + String -- ^ input in NTriples format. + -> ParseResult +parseNT = parsefromString ntripleDoc +-- parseNT = either Error Result . parsefromString ntripleDoc + +{- +-- useful for testing +test :: String -> RDFGraph +test = either error id . parsefromString ntripleDoc +-} + +-- | Function to supply initial context and parse supplied term. +-- +-- We augment the Parsec error with the context. +-- +parsefromString :: + NTParser a -- ^ parser to apply + -> String -- ^ input to be parsed + -> Either String a +parsefromString parser input = + let + pstate = NTState + { graphState = emptyRDFGraph + } + result = runParser parser pstate "" input + in + case result of + Right res -> Right res + Left err -> Left $ annotateParsecError 1 (lines input) err + +-- helper routines + +fullStop :: NTParser () +fullStop = ignore (char '.') + +{- +lineFeed :: NTParser () +lineFeed = ignore (char '\r') +-} + +-- Add statement to graph in NT parser state + +addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> NTParser () +addStatement s p o = updateState (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 *> skipMany ws *> eof *> getState) + +line :: NTParser () +line = skipMany ws *> 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. +-} +ws :: NTParser () +ws = ignore (char ' ' <|> tab) "white space (' ' or tab)" + +{- +comment ::= '#' ( character - ( cr | lf ) )* +-} + +comment :: NTParser () +comment = char '#' *> skipMany (noneOf "\r\n") "comment line" + +{- +eoln ::= cr | lf | cr lf +-} + +eoln :: NTParser () +-- eoln = ignore (newline <|> (lineFeed *> optional newline)) +eoln = ignore (try (string "\r\n") <|> string "\r" <|> string "\n") + "new line" + +{- +name ::= [A-Za-z][A-Za-z0-9]* +-} + +hChars, bChars :: String +hChars = ['a'..'z'] ++ ['A'..'Z'] +bChars = hChars ++ ['0'..'9'] + +name :: NTParser String +name = (:) <$> oneOf hChars <*> many (oneOf bChars) + +{- +triple ::= subject ws+ predicate ws+ object ws* '.' ws* + +-} + +triple :: NTParser () +triple = do + s <- subject + skipMany1 ws + p <- predicate + skipMany1 ws + o <- object + skipMany ws + fullStop + skipMany ws + addStatement s p o + +{- +subject ::= uriref | nodeID +predicate ::= uriref +object ::= uriref | nodeID | literal +-} + +subject :: NTParser RDFLabel +subject = urirefLbl <|> nodeID + +predicate :: NTParser RDFLabel +predicate = urirefLbl + +object :: NTParser RDFLabel +object = urirefLbl <|> nodeID <|> literal + +{- +uriref ::= '<' absoluteURI '>' +absoluteURI ::= character+ with escapes as defined in section URI References + +-} + +uriref :: NTParser ScopedName +uriref = do + ustr <- char '<' *> manyTill character (char '>') + when (isNothing (parseURI ustr)) $ + fail ("Invalid URI: <" ++ ustr ++ ">") + return $ makeUriScopedName ustr + +urirefLbl :: NTParser RDFLabel +urirefLbl = Res <$> uriref + +{- +nodeID ::= '_:' name +-} + +nodeID :: NTParser RDFLabel +nodeID = Blank <$> (string "_:" *> name) "blank node (_:label)" + +{- +literal ::= langString | datatypeString +langString ::= '"' string '"' ( '@' language )? +datatypeString ::= '"' string '"' '^^' uriref +language ::= [a-z]+ ('-' [a-z0-9]+ )* +encoding a language tag. +string ::= character* with escapes as defined in section Strings + +-} + +literal :: NTParser RDFLabel +literal = Lit <$> between (char '"') (char '"') (many character) <*> optionMaybe dtlang + +dtlang :: NTParser ScopedName +dtlang = + (char '@' *> language) + <|> (string "^^" *> uriref) + +language :: NTParser ScopedName +language = do + h <- many1 (oneOf ['a'..'z']) + mt <- optionMaybe ( (:) <$> char '-' <*> many1 (oneOf (['a'..'z'] ++ ['0'..'9'])) ) + return $ langName $ h ++ fromMaybe "" mt + +{- +String handling: + +EBNF has: + +character ::= [#x20-#x7E] /* US-ASCII space to decimal 126 */ + +Additional information from: + + http://www.w3.org/TR/rdf-testcases/#ntrip_strings + +N-Triples strings are sequences of US-ASCII character productions encoding [UNICODE] character strings. The characters outside the US-ASCII range and some other specific characters are made available by \-escape sequences as follows: + + Unicode character + (with code point u) N-Triples encoding + [#x0-#x8] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + #x9 \t + #xA \n + [#xB-#xC] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + #xD \r + [#xE-#x1F] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + [#x20-#x21] the character u + #x22 \" + [#x23-#x5B] the character u + #x5C \\ + [#x5D-#x7E] the character u + [#x7F-#xFFFF] \uHHHH + 4 required hexadecimal digits HHHH encoding Unicode character u + [#10000-#x10FFFF] \UHHHHHHHH + 8 required hexadecimal digits HHHHHHHH encoding Unicode character u + where H is a hexadecimal digit: [#x30-#x39],[#x41-#x46] (0-9, uppercase A-F). + +This escaping satisfies the [CHARMOD] section Reference Processing Model on making the full Unicode character range U+0 to U+10FFFF available to applications and providing only one way to escape any character. + +-} + +asciiChars :: String +asciiChars = map chr [0x20..0x7e] + +asciiCharsNT :: String +asciiCharsNT = filter (`notElem` "\\\"") asciiChars + +ntHexDigit :: NTParser Char +ntHexDigit = oneOf $ ['0'..'9'] ++ ['A'..'F'] + +hex4 :: NTParser Char +hex4 = do + digs <- count 4 ntHexDigit + let dstr = "0x" ++ digs + dchar = read dstr :: Int + return $ chr dchar + +hex8 :: NTParser Char +hex8 = do + digs <- count 8 ntHexDigit + let dstr = "0x" ++ digs + dchar = read dstr :: Int + if dchar <= 0x10FFFF + then return $ chr dchar + else unexpected "\\UHHHHHHHH format is limited to a maximum of \\U0010FFFF" + +protectedChar :: NTParser Char +protectedChar = + (char 't' *> return '\t') + <|> (char 'n' *> return '\n') + <|> (char 'r' *> return '\r') + <|> (char '"' *> return '"') + <|> (char '\\' *> return '\\') + <|> (char 'u' *> hex4) + <|> (char 'U' *> hex8) + +character :: NTParser Char +character = (char '\\' *> protectedChar) + <|> (oneOf asciiCharsNT "ASCII character") + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/Proof.hs b/Swish/RDF/Proof.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/Proof.hs @@ -0,0 +1,278 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Proof +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines a framework for constructing proofs +-- over some expression form. It is intended to be used +-- with RDF graphs, but the structures aim to be quite +-- generic with respect to the expression forms allowed. +-- +-- It does not define any proof-finding strategy. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Proof + ( Proof(..), Step(..) + , checkProof, explainProof, checkStep, showProof, showsProof, showsFormula ) +where + +import Swish.RDF.Ruleset + ( Ruleset(..) ) + +import Swish.RDF.Rule + ( Expression(..), Formula(..), Rule(..) + , showsFormula, showsFormulae ) + +import Swish.Utils.ShowM + ( ShowM(..) ) + +import Swish.Utils.ListHelpers + ( subset ) + +import Data.List + ( union, intersect, intercalate ) + +import Data.Maybe + ( catMaybes ) + + +------------------------------------------------------------ +-- Proof framework +------------------------------------------------------------ + +-- |Step in proof chain +-- +-- The display name for a proof step comes from the display name of its +-- consequence formula. +data Step ex = Step + { stepRule :: Rule ex -- ^ Inference rule used + , stepAnt :: [Formula ex] -- ^ Antecedents of inference rule + , stepCon :: Formula ex -- ^ Named consequence of inference rule + } deriving Show + +-- |Proof is a structure that presents a chain of rule applications +-- that yield a result expression from a given expression +data Proof ex = Proof + { proofContext :: [Ruleset ex] -- ^ Proof context: list of rulesets, + -- each of which provides a number of + -- axioms and rules. + , proofInput :: Formula ex -- ^ Given expression + , proofResult :: Formula ex -- ^ Result expression + , proofChain :: [Step ex] -- ^ Chain of inference rule applications + -- progressing from input to result + } + +-- |Return a list of axioms from all the rulesets in a proof +proofAxioms :: Proof a -> [Formula a] +proofAxioms = concatMap rsAxioms . proofContext + +-- |Return a list of rules from all the rulesets in a proof +proofRules :: Proof a -> [Rule a] +proofRules = concatMap rsRules . proofContext + +-- |Return list of axioms actually referenced by a proof +proofAxiomsUsed :: Proof ex -> [Formula ex] +proofAxiomsUsed proof = foldl union [] $ map stepAxioms (proofChain proof) + where + stepAxioms st = stepAnt st `intersect` proofAxioms proof + +-- |Check consistency of given proof. +-- The supplied rules and axioms are assumed to be correct. +checkProof :: (Expression ex) => Proof ex -> Bool +checkProof pr = + checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr + where + initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) + goalExpr = formExpr $ proofResult pr + +checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool +checkProof1 _ prev [] res = res `elem` prev +checkProof1 rules prev (st:steps) res = + checkStep rules prev st && + checkProof1 rules (formExpr (stepCon st):prev) steps res + +-- A proof step is valid if rule is in list of rules +-- and the antecedents are sufficient to obtain the conclusion +-- and the antecedents are in the list of formulae already proven. +-- +-- Note: this function depends on the ruleName of any rule being +-- unique among all rules. In particular the name of the step rule +-- being in correspondence with the name of one of the indicated +-- valid rules of inference. +checkStep :: (Expression ex) => [Rule ex] -> [ex] -> Step ex -> Bool +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, and return identification of failing step. +explainProof :: + (Expression ex) => Proof ex -> Maybe String +explainProof pr = + explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr + where + initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) + goalExpr = formExpr $ proofResult pr + +explainProof1 :: + (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String +explainProof1 _ prev [] res = + if res `elem` prev then Nothing else Just "Result not demonstrated" +explainProof1 rules prev (st:steps) res = + case explainStep rules prev st of + Nothing -> explainProof1 rules (formExpr (stepCon st):prev) steps res + Just ex -> Just ("Invalid step: "++show (formName $ stepCon st)++": "++ex) + +-- A proof step is valid if rule is in list of rules +-- and the antecedents are sufficient to obtain the conclusion +-- and the antecedents are in the list of formulae already proven. +-- +-- Note: this function depends on the ruleName of any rule being +-- unique among all rules. In particular the name of the step rule +-- being in correspondence with the name of one of the indicated +-- valid rules of inference. +-- +-- Return Nothing if step is OK, or Just string describing failure +-- +explainStep :: (Expression ex) => [Rule ex] -> [ex] -> Step ex -> Maybe String +explainStep rules prev step = + if null errors then Nothing else Just $ intercalate ", " errors + where + -- Rule from proof step: + srul = stepRule step + -- Antecedent expressions from proof step: + sant = map formExpr $ stepAnt step + -- Consequentent expression from proof step: + scon = formExpr $ stepCon step + -- Tests for step to be valid + errors = catMaybes + -- Rule name is one of supplied rules, and + [ require (ruleName srul `elem` map ruleName rules) + ("rule "++show (ruleName srul)++" not present") + -- Antecedent expressions are all previously accepted expressions + , require (sant `subset` prev) + "antecedent not axiom or previous result" + -- Inference rule yields consequence from antecedents + , require (checkInference srul sant scon) + "rule does not deduce consequence from antecedents" + ] + require b s = if b then Nothing else Just s + +-- |Create a displayable form of a proof, returned as a `ShowS` value. +-- +-- This function is intended to allow the calling function some control +-- of multiline displays by providing: +-- +-- (1) the first line of the proof is not preceded by any text, so +-- it may be appended to some preceding text on the same line, +-- +-- (2) the supplied newline string is used to separate lines of the +-- formatted text, and may include any desired indentation, and +-- +-- (3) no newline is output following the final line of text. +showsProof :: (ShowM ex) => 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 :: (ShowM ex) => String -> Proof ex -> String +showProof newline proof = showsProof newline proof "" + +-- |Create a displayable form of a list of labelled proof steps +showsSteps :: (ShowM ex) => String -> [Step ex] -> ShowS +showsSteps _ [] = id +showsSteps newline [s] = showsStep newline s +showsSteps newline (s:ss) = showsStep newline s . + showString newline . + showsSteps newline ss + +-- |Create a displayable form of a labelled proof step. +showsStep :: (ShowM ex) => String -> Step ex -> ShowS +showsStep newline s = showsFormula newline (stepCon s) . + showString newline . + showString (" (by ["++rulename++"] from "++antnames++")") + where + rulename = show . ruleName $ stepRule s + antnames = showNames $ map (show . formName) (stepAnt s) + +-- |Return a string containing a list of names. +showNames :: [String] -> String +showNames [] = "" +showNames [n] = showName n +showNames [n1,n2] = showName n1 ++ " and " ++ showName n2 +showNames (n1:ns) = showName n1 ++ ", " ++ showNames ns + +-- |Return a string representing a single name. +showName :: String -> String +showName n = "["++n++"]" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFDatatype.hs b/Swish/RDF/RDFDatatype.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFDatatype.hs @@ -0,0 +1,221 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFDatatype +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines the structures used by Swish to represent and +-- manipulate RDF datatypes. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFDatatype + ( RDFDatatype + , RDFDatatypeVal + , RDFDatatypeMod + , RDFModifierFn, RDFApplyModifier + , makeRdfDtOpenVarBindingModify, makeRdfDtOpenVarBindingModifiers + , applyRDFDatatypeMod + , RDFDatatypeSub + , fromRDFLabel, toRDFLabel, makeDatatypedLiteral + ) +where + +import Swish.RDF.RDFGraph + ( RDFLabel(..) + , isDatatyped + , getLiteralText + , RDFGraph + ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding, RDFOpenVarBindingModify ) + +import Swish.RDF.Datatype + ( Datatype -- , typeName, typeRules + , DatatypeVal(..) + , DatatypeMap(..) + , DatatypeMod(..), ModifierFn + , ApplyModifier + , DatatypeSub(..) + ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +import Swish.RDF.VarBinding + ( VarBindingModify(..) ) + +import Data.Maybe + ( fromMaybe, isJust, fromJust ) + +import Control.Monad + ( liftM ) + +------------------------------------------------------------ +-- 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 (rdfNodeExtract dtval) ivs + ovals | isJust ivals = fn (fromJust ivals) + | otherwise = [] + in + fromMaybe [] $ mapM (rdfNodeInject dtval) ovals + +-- |Extract datatyped value from 'RDFLabel' value, or return @Nothing@. +-- +rdfNodeExtract :: RDFDatatypeVal vt -> RDFLabel -> Maybe vt +rdfNodeExtract dtval node + | isDatatyped dtname node = mapL2V dtmap $ getLiteralText node + | otherwise = Nothing + where + dtname = tvalName dtval + dtmap = tvalMap dtval + +-- |Return new RDF literal node with a representation of the supplied +-- value, or @Nothing@. +-- +rdfNodeInject :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel +rdfNodeInject dtval val = maybeNode valstr + where + valstr = mapV2L (tvalMap dtval) val + maybeNode Nothing = Nothing + maybeNode (Just str) = Just $ Lit str (Just (tvalName dtval)) + +------------------------------------------------------------ +-- Helpers to map between datatype values and RDFLabels +------------------------------------------------------------ + +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 + +toRDFLabel :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel +toRDFLabel dtv = + liftM (makeDatatypedLiteral dtnam) . mapV2L dtmap + where + dtnam = tvalName dtv + dtmap = tvalMap dtv + +makeDatatypedLiteral :: ScopedName -> String -> RDFLabel +makeDatatypedLiteral dtnam strval = + Lit strval (Just dtnam) + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFDatatypeXsdInteger.hs b/Swish/RDF/RDFDatatypeXsdInteger.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFDatatypeXsdInteger.hs @@ -0,0 +1,544 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFDatatypeXsdInteger +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines the structures used by swish to represent and +-- manipulate RDF datatypes. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFDatatypeXsdInteger + ( rdfDatatypeXsdInteger + , rdfDatatypeValXsdInteger + , typeNameXsdInteger, namespaceXsdInteger + , axiomsXsdInteger, rulesXsdInteger + , prefixXsdInteger + ) +where + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleset + , makeRDFGraphFromN3String + , makeRDFFormula + ) + +import Swish.RDF.RDFDatatype + ( RDFDatatype + , RDFDatatypeVal + , RDFDatatypeMod + , makeRdfDtOpenVarBindingModifiers + ) + +import Swish.RDF.ClassRestrictionRule + ( makeRDFDatatypeRestrictionRules + ) + +import Swish.RDF.MapXsdInteger + ( mapXsdInteger + ) + +import Swish.RDF.Datatype + ( Datatype(..) + , DatatypeVal(..) + , DatatypeRel(..), DatatypeRelPr + , altArgs + , UnaryFnTable, unaryFnApp + , BinaryFnTable, binaryFnApp + , BinMaybeFnTable, binMaybeFnApp + , DatatypeMod(..) + , makeVmod_1_1_inv, makeVmod_1_1 + , makeVmod_2_1_inv, makeVmod_2_1 + , makeVmod_2_0 + , makeVmod_2_2 + ) + +import Swish.RDF.Ruleset (makeRuleset) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + ) + +import Data.Maybe (maybeToList) + +import Control.Monad (liftM) + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +-- Local name for Integer datatype +nameXsdInteger :: String +nameXsdInteger = "integer" + +-- |Type name for xsd:integer datatype +typeNameXsdInteger :: ScopedName +typeNameXsdInteger = ScopedName namespaceXSD nameXsdInteger + +-- |Namespace for xsd:integer datatype functions +namespaceXsdInteger :: Namespace +namespaceXsdInteger = namespaceXsdType nameXsdInteger + +-- Helper to catenate strings with newline separator, +-- used for making textual representations of graphs. +-- (the newline makes N3 parser diagnostics easier to interpret) +-- +infixr 5 +++ +(+++) :: String -> ShowS +(+++) str = ((str++"\n")++) + +-- Compose with function of two arguments +c2 :: (b -> c) -> (a -> d -> b) -> a -> d -> c +c2 = (.) . (.) + +-- Integer power (exponentiation) function +-- returns Nothing if exponent is negative. +-- +intPower :: Integer -> Integer -> Maybe Integer +intPower a b = if b < 0 then Nothing else Just (intPower1 a b) + where + intPower1 x y + | q == 1 = atopsq*x + | p == 0 = 1 + | otherwise = atopsq + where + (p,q) = y `divMod` 2 + atop = intPower1 x p + atopsq = atop*atop + +------------------------------------------------------------ +-- Declare exported RDFDatatype value for xsd:integer +------------------------------------------------------------ + +rdfDatatypeXsdInteger :: RDFDatatype +rdfDatatypeXsdInteger = Datatype rdfDatatypeValXsdInteger + +------------------------------------------------------------ +-- Implmentation of RDFDatatypeVal for xsd:integer +------------------------------------------------------------ + +-- |Define Datatype value for xsd:integer +-- Members of this datatype are positive or negative integer values. +-- +-- The lexical form consists of an option @+@ 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. +-- (cf. http://www.w3.org/2000/10/swap/doc/CwmBuiltins.html) +-- + +relXsdInteger :: [DatatypeRel Integer] +relXsdInteger = + [ relXsdIntegerAbs + , relXsdIntegerNeg + , relXsdIntegerSum + , relXsdIntegerDiff + , relXsdIntegerProd + , relXsdIntegerDivMod + , relXsdIntegerPower + , relXsdIntegerEq + , relXsdIntegerNe + , relXsdIntegerLt + , relXsdIntegerLe + , relXsdIntegerGt + , relXsdIntegerGe + ] + +mkIntRel2 :: + String -> DatatypeRelPr Integer -> UnaryFnTable Integer + -> DatatypeRel Integer +mkIntRel2 nam pr fns = DatatypeRel + { dtRelName = ScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns unaryFnApp + } + +mkIntRel3 :: + String -> DatatypeRelPr Integer -> BinaryFnTable Integer + -> DatatypeRel Integer +mkIntRel3 nam pr fns = DatatypeRel + { dtRelName = ScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns binaryFnApp + } + +mkIntRel3maybe :: + String -> DatatypeRelPr Integer -> BinMaybeFnTable Integer + -> DatatypeRel Integer +mkIntRel3maybe nam pr fns = DatatypeRel + { dtRelName = ScopedName namespaceXsdInteger nam + , dtRelFunc = altArgs pr fns binMaybeFnApp + } + +relXsdIntegerAbs :: DatatypeRel Integer +relXsdIntegerAbs = mkIntRel2 "abs" (const True) + [ ( (>=0), [ (abs,1) ] ) + , ( const True, [ (id,0), (negate,0) ] ) + ] + +relXsdIntegerNeg :: DatatypeRel Integer +relXsdIntegerNeg = mkIntRel2 "neg" (const True) + [ ( const True, [ (negate,1) ] ) + , ( const True, [ (negate,0) ] ) + ] + +relXsdIntegerSum :: DatatypeRel Integer +relXsdIntegerSum = mkIntRel3 "sum" (const True) + [ ( const True, [ ((+),1,2) ] ) + , ( const True, [ ((-),0,2) ] ) + , ( const True, [ ((-),0,1) ] ) + ] + +relXsdIntegerDiff :: DatatypeRel Integer +relXsdIntegerDiff = mkIntRel3 "diff" (const True) + [ ( const True, [ ((-),1,2) ] ) + , ( const True, [ ((+),0,2) ] ) + , ( const True, [ ((-),1,0) ] ) + ] + +relXsdIntegerProd :: DatatypeRel Integer +relXsdIntegerProd = mkIntRel3 "prod" (const True) + [ ( const True, [ ((*),1,2) ] ) + , ( const True, [ (div,0,2) ] ) + , ( const True, [ (div,0,1) ] ) + ] + +relXsdIntegerDivMod :: DatatypeRel Integer +relXsdIntegerDivMod = mkIntRel3 "divmod" (const True) + [ ( const True, [ (div,2,3) ] ) + , ( const True, [ (mod,2,3) ] ) + , ( const True, [ ] ) + , ( const True, [ ] ) + ] + +relXsdIntegerPower :: DatatypeRel Integer +relXsdIntegerPower = mkIntRel3maybe "power" (const True) + [ ( const True, [ (liftM (:[]) `c2` intPower,1,2) ] ) + , ( const True, [ ] ) + , ( (>=0), [ ] ) + ] + +liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool +liftL2 p i1 i2 as = p (i1 as) (i2 as) + +lcomp :: (a->a->Bool) -> [a] -> Bool +lcomp p = liftL2 p head (head . tail) + +-- eq + +relXsdIntegerEq :: DatatypeRel Integer +relXsdIntegerEq = mkIntRel2 "eq" (lcomp (==)) + ( repeat (const True, []) ) + +-- ne + +relXsdIntegerNe :: DatatypeRel Integer +relXsdIntegerNe = mkIntRel2 "ne" (lcomp (/=)) + ( repeat (const True, []) ) + +-- lt + +relXsdIntegerLt :: DatatypeRel Integer +relXsdIntegerLt = mkIntRel2 "lt" (lcomp (<)) + ( repeat (const True, []) ) + +-- le + +relXsdIntegerLe :: DatatypeRel Integer +relXsdIntegerLe = mkIntRel2 "le" (lcomp (<=)) + ( repeat (const True, []) ) + +-- gt + +relXsdIntegerGt :: DatatypeRel Integer +relXsdIntegerGt = mkIntRel2 "gt" (lcomp (>)) + ( repeat (const True, []) ) + +-- ge + +relXsdIntegerGe :: DatatypeRel Integer +relXsdIntegerGe = mkIntRel2 "ge" (lcomp (>=)) + ( repeat (const True, []) ) + +-- |modXsdInteger contains variable binding modifiers for xsd:Integer values. +-- +-- The functions are selected from those defined by CWM as math: +-- properties. +-- (cf. http://www.w3.org/2000/10/swap/doc/CwmBuiltins.html) +-- +modXsdInteger :: [RDFDatatypeMod Integer] +modXsdInteger = + [ modXsdIntegerAbs + , modXsdIntegerNeg + , modXsdIntegerSum + , modXsdIntegerDiff + , modXsdIntegerProd + , modXsdIntegerDivMod + , modXsdIntegerPower + , modXsdIntegerEq + , modXsdIntegerNe + , modXsdIntegerLt + , modXsdIntegerLe + , modXsdIntegerGt + , modXsdIntegerGe + ] + +modXsdIntegerAbs :: RDFDatatypeMod Integer +modXsdIntegerAbs = DatatypeMod + { dmName = ScopedName namespaceXsdInteger "abs" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod_1_1 + } + where + f0 vs@[v1,v2] = if v1 == abs v2 then vs else [] + f0 _ = [] + f1 [v2] = [abs v2] + f1 _ = [] + +modXsdIntegerNeg :: RDFDatatypeMod Integer +modXsdIntegerNeg = DatatypeMod + { dmName = ScopedName namespaceXsdInteger "neg" + , dmModf = [ f0, f1, f1 ] + , dmAppf = makeVmod_1_1_inv + } + where + f0 vs@[v1,v2] = if v1 == negate v2 then vs else [] + f0 _ = [] + f1 [vi] = [-vi] + f1 _ = [] + +modXsdIntegerSum :: RDFDatatypeMod Integer +modXsdIntegerSum = DatatypeMod + { dmName = ScopedName namespaceXsdInteger "sum" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod_2_1_inv + } + 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 = ScopedName namespaceXsdInteger "diff" + , dmModf = [ f0, f1, f2, f3 ] + , dmAppf = makeVmod_2_1_inv + } + 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 = ScopedName namespaceXsdInteger "prod" + , dmModf = [ f0, f1, f2, f2 ] + , dmAppf = makeVmod_2_1_inv + } + where + f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else [] + f0 _ = [] + f1 [v2,v3] = [v2*v3] + f1 _ = [] + f2 [v1,vi] = if r == 0 then [q] else [] + where (q,r) = quotRem v1 vi + f2 _ = [] + +modXsdIntegerDivMod :: RDFDatatypeMod Integer +modXsdIntegerDivMod = DatatypeMod + { dmName = ScopedName namespaceXsdInteger "divmod" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod_2_2 + } + 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 = ScopedName namespaceXsdInteger "power" + , dmModf = [ f0, f1 ] + , dmAppf = makeVmod_2_1 + } + 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 :: + String -> (Integer->Integer->Bool) -> RDFDatatypeMod Integer +modXsdIntegerCompare nam rel = DatatypeMod + { dmName = ScopedName namespaceXsdInteger nam + , dmModf = [ f0 ] + , dmAppf = makeVmod_2_0 + } + where + f0 vs@[v1,v2] = if rel v1 v2 then vs else [] + f0 _ = [] + +-- |rulesetXsdInteger contains rules and axioms that allow additional +-- deductions when xsd:integer values appear in a graph. +-- +-- The rules defined here are concerned with basic integer arithmetic +-- operations: +, -, *, div, rem +-- +-- makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +-- +rdfRulesetXsdInteger :: RDFRuleset +rdfRulesetXsdInteger = + makeRuleset namespaceXsdInteger axiomsXsdInteger rulesXsdInteger + +mkPrefix :: Namespace -> String +mkPrefix ns = + "@prefix " ++ nsPrefix ns ++ ": <" ++ nsURI ns ++ "> . \n" + +prefixXsdInteger :: String +prefixXsdInteger = + mkPrefix namespaceRDF ++ + mkPrefix namespaceRDFS ++ + mkPrefix namespaceRDFD ++ + mkPrefix namespaceXSD ++ + mkPrefix namespaceXsdInteger ++ + " \n" + +mkAxiom :: String -> String -> RDFFormula +mkAxiom local gr = + makeRDFFormula namespaceXsdInteger local (prefixXsdInteger++gr) + +axiomsXsdInteger :: [RDFFormula] +axiomsXsdInteger = + [ mkAxiom "dt" "xsd:integer rdf:type rdfs:Datatype ." + ] + +rulesXsdInteger :: [RDFRule] +rulesXsdInteger = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr + where + gr = makeRDFGraphFromN3String rulesXsdIntegerStr + +rulesXsdIntegerStr :: String +rulesXsdIntegerStr = prefixXsdInteger + +++ "xsd_integer:Abs a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:abs ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Neg a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:neg ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Sum a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + +++ " rdfd:constraint xsd_integer:sum ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Diff a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + +++ " rdfd:constraint xsd_integer:diff ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Prod a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + +++ " rdfd:constraint xsd_integer:prod ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:DivMod a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; " + +++ " rdfd:constraint xsd_integer:divmod ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Power a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; " + +++ " rdfd:constraint xsd_integer:power ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Eq a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:eq ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Ne a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:ne ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Lt a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:lt ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Le a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:le ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Gt a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:gt ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +++ "xsd_integer:Ge a rdfd:GeneralRestriction ; " + +++ " rdfd:onProperties (rdf:_1 rdf:_2) ; " + +++ " rdfd:constraint xsd_integer:ge ; " + +++ " rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . " + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFDatatypeXsdString.hs b/Swish/RDF/RDFDatatypeXsdString.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFDatatypeXsdString.hs @@ -0,0 +1,347 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFDatatypeXsdString +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines the structures used by swish to represent and +-- manipulate RDF xsd:string datatyped literals. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFDatatypeXsdString + ( rdfDatatypeXsdString + , rdfDatatypeValXsdString + , typeNameXsdString, namespaceXsdString + , axiomsXsdString, rulesXsdString + , prefixXsdString + ) +where + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleset + , makeRDFGraphFromN3String + , makeRDFFormula + , makeN3ClosureRule + ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBindingModify + ) + +import Swish.RDF.RDFDatatype + ( RDFDatatype + , RDFDatatypeVal + , RDFDatatypeMod + , makeRdfDtOpenVarBindingModifiers + ) + +import Swish.RDF.RDFGraph + ( RDFLabel(..) ) + +import Swish.RDF.ClassRestrictionRule + ( makeRDFDatatypeRestrictionRules + ) + +import Swish.RDF.Datatype + ( Datatype(..) + , DatatypeVal(..) + , DatatypeMap(..) + , DatatypeRel(..), DatatypeRelPr + , altArgs + , UnaryFnTable, unaryFnApp + , DatatypeMod(..) + , makeVmod_2_0 + ) + +import Swish.RDF.Ruleset + ( makeRuleset + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + , addVarBinding + , VarBindingModify(..) + ) + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +-- Local name for Integer datatype +nameXsdString :: String +nameXsdString = "string" + +-- |Type name for @xsd:string@ datatype +typeNameXsdString :: ScopedName +typeNameXsdString = ScopedName namespaceXSD nameXsdString + +-- |Namespace for @xsd:string@ datatype functions +namespaceXsdString :: Namespace +namespaceXsdString = namespaceXsdType nameXsdString + +-- Helper to catenate strings with newline separator, +-- used for making textual representations of graphs. +-- (the newline makes N3 parser diagnostics easier to interpret) +-- +infixr 5 +++ +(+++) :: String -> ShowS +(+++) str = ((str++"\n")++) + +------------------------------------------------------------ +-- Declare exported RDFDatatype value for xsd:integer +------------------------------------------------------------ + +rdfDatatypeXsdString :: RDFDatatype +rdfDatatypeXsdString = Datatype rdfDatatypeValXsdString + +------------------------------------------------------------ +-- Implmentation of RDFDatatypeVal for xsd:integer +------------------------------------------------------------ + +-- |Define Datatype value for @xsd:string@. +-- +rdfDatatypeValXsdString :: RDFDatatypeVal String +rdfDatatypeValXsdString = DatatypeVal + { tvalName = typeNameXsdString + , tvalRules = rdfRulesetXsdString -- Ruleset RDFGraph + , tvalMkRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString + -- RDFGraph -> [RDFRules] + , tvalMkMods = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdString + , tvalMap = mapXsdString -- DatatypeMap Integer + , tvalRel = relXsdString -- [DatatypeRel Integer] + , tvalMod = modXsdString -- [DatatypeMod Integer] + } + +-- |mapXsdString contains functions that perform lexical-to-value +-- and value-to-canonical-lexical mappings for @xsd:string@ values +-- +-- These are identity mappings. +-- +mapXsdString :: DatatypeMap String +mapXsdString = DatatypeMap + { -- mapL2V :: String -> Maybe String + mapL2V = Just + -- mapV2L :: String -> Maybe String + , mapV2L = Just + } + +-- |relXsdString contains useful relations for @xsd:string@ values. +-- +relXsdString :: [DatatypeRel String] +relXsdString = + [ relXsdStringEq + , relXsdStringNe + ] + +mkStrRel2 :: + String -> DatatypeRelPr String -> UnaryFnTable String + -> DatatypeRel String +mkStrRel2 nam pr fns = DatatypeRel + { dtRelName = ScopedName 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 String +relXsdStringEq = mkStrRel2 "eq" (lcomp (==)) + ( repeat (const True, []) ) + +-- ne + +relXsdStringNe :: DatatypeRel String +relXsdStringNe = mkStrRel2 "ne" (lcomp (/=)) + ( repeat (const True, []) ) + +-- |modXsdString contains variable binding modifiers for @xsd:string@ values. +-- +modXsdString :: [RDFDatatypeMod String] +modXsdString = + [ modXsdStringEq + , modXsdStringNe + ] + +modXsdStringEq, modXsdStringNe :: RDFDatatypeMod String +modXsdStringEq = modXsdStringCompare "eq" (==) +modXsdStringNe = modXsdStringCompare "ne" (/=) + +modXsdStringCompare :: + String -> (String->String->Bool) -> RDFDatatypeMod String +modXsdStringCompare nam rel = DatatypeMod + { dmName = ScopedName namespaceXsdString nam + , dmModf = [ f0 ] + , dmAppf = makeVmod_2_0 + } + 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 -> String +mkPrefix ns = + "@prefix " ++ nsPrefix ns ++ ": <" ++ nsURI ns ++ "> . \n" + +prefixXsdString :: String +prefixXsdString = + mkPrefix namespaceRDF ++ + mkPrefix namespaceRDFS ++ + mkPrefix namespaceRDFD ++ + mkPrefix namespaceXSD ++ + mkPrefix namespaceXsdString ++ + " \n" + +mkAxiom :: String -> String -> RDFFormula +mkAxiom local gr = + makeRDFFormula namespaceXsdString local (prefixXsdString++gr) + +axiomsXsdString :: [RDFFormula] +axiomsXsdString = + [ mkAxiom "dt" "xsd:string rdf:type rdfs:Datatype ." + ] + +rulesXsdString :: [RDFRule] +rulesXsdString = rulesXsdStringClosure ++ rulesXsdStringRestriction + +rulesXsdStringRestriction :: [RDFRule] +rulesXsdStringRestriction = + makeRDFDatatypeRestrictionRules rdfDatatypeValXsdString gr + where + gr = makeRDFGraphFromN3String rulesXsdStringStr + +rulesXsdStringStr :: String +rulesXsdStringStr = 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 = ScopedName namespaceRDFD "stringPlain" + , vbmApply = concatMap app1 + , vbmVocab = [svar,lvar] + , vbmUsage = [[svar],[lvar],[]] + } + where + app1 vbind = app2 (vbMap vbind svar) (vbMap vbind lvar) vbind + app2 (Just (Lit s (Just _))) + (Just (Lit l Nothing)) + vbind + | s == l + = [vbind] + app2 (Just (Lit s (Just _))) + Nothing + vbind + = [addVarBinding lvar (Lit s Nothing) vbind] + app2 Nothing + (Just (Lit l Nothing)) + vbind + = [addVarBinding svar (Lit l (Just typeNameXsdString)) vbind] + app2 _ _ _ = [] + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFGraph.hs b/Swish/RDF/RDFGraph.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFGraph.hs @@ -0,0 +1,649 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFGraph +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances +-- +-- This module defines a memory-based RDF graph instance. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Simple labelled directed graph value +------------------------------------------------------------ + +module Swish.RDF.RDFGraph + ( RDFLabel(..) + , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral + , isDatatyped, isMemberProp, isUri, isBlank, isQueryVar + , getLiteralText, getScopedName, makeBlank + , RDFTriple + , NSGraph(..), RDFGraph + , NamespaceMap, RevNamespaceMap, RevNamespace + , emptyNamespaceMap + , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap + , addArc, merge + , allLabels, allNodes, remapLabels, remapLabelList + , newNode, newNodes + , setNamespaces, getNamespaces + , setFormulae, getFormulae, setFormula, getFormula + , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} + -- Re-export from GraphClass + , LDGraph(..), Label (..), Arc(..) + , arc, arcSubj, arcPred, arcObj, Selector + -- Export selected RDFLabel values + , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil + , res_rdfs_member + , res_rdfd_GeneralRestriction + , res_rdfd_onProperties, res_rdfd_constraint, res_rdfd_maxCardinality + , res_owl_sameAs, res_log_implies + -- Exported for testing: + , grMatchMap, grEq + , mapnode, maplist + ) +where + +import Swish.Utils.Namespace + ( Namespace(..) + , getScopedNameURI + , ScopedName(..) + , nullScopedName + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , langTag, isLang + , rdf_type + , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral + , rdfs_member + , rdfd_GeneralRestriction + , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality + , owl_sameAs, log_implies + ) + +import Swish.RDF.GraphClass + ( LDGraph(..), Label (..) + , Arc(..), arc, arcSubj, arcPred, arcObj + , Selector ) + +import Swish.RDF.GraphMatch + ( graphMatch, LabelMap, ScopedLabel(..) ) + +import Swish.Utils.MiscHelpers + ( hash, quote ) + +import Swish.Utils.ListHelpers + ( addSetElem ) + +import Swish.Utils.LookupMap + ( LookupMap(..), LookupEntryClass(..) + , listLookupMap + , mapFind, mapFindMaybe, mapReplaceOrAdd, mapVals, mapKeys ) + +import qualified Data.Foldable as F +import qualified Data.Traversable as T + +import Control.Applicative (Applicative, liftA, (<$>), (<*>)) +-- import Control.Monad (liftM, ap) + +import Data.Char + ( isDigit ) + +import Data.List + ( intersect, union, findIndices ) + +import Data.Ord (comparing) + +----------------------------------------------------------- +-- | RDF graph node values +-- +-- cf. +-- +-- This is extended from the RDF abstract graph syntax in the +-- following ways: +-- +-- (a) a graph can be part of a resource node or blank node +-- (cf. Notation3 formulae) +-- +-- (b) a \"variable\" node option is distinguished from a +-- blank node. +-- I have found this useful for encoding and handling +-- queries, even though query variables can be expressed +-- as blank nodes. +-- +-- (c) a \"NoNode\" option is defined. +-- This might otherwise be handled by @Maybe (RDFLabel g)@. +-- + +-- TODO: should Lit be split up so that can easily differentiate between +-- a type and a language tag + +data RDFLabel = + Res ScopedName -- ^ resource + | Lit String (Maybe ScopedName) -- ^ literal [type/language] + | Blank String -- ^ blank node + | Var String -- ^ variable (not used in ordinary graphs) + | NoNode -- ^ no node (not used in ordinary graphs) + +instance Eq RDFLabel where + (==) = labelEq + +instance Show RDFLabel where + show (Res sn) = show sn + show (Lit st Nothing) = quote st + show (Lit st (Just nam)) + | isLang nam = quote st ++ "@" ++ langTag nam + | otherwise = quote st ++ "^^" ++ show nam + show (Blank ln) = "_:"++ln + show (Var ln) = '?' : ln + show NoNode = "" + +instance Ord RDFLabel where + -- Optimize some common cases.. + compare (Res sn1) (Res sn2) = compare sn1 sn2 + compare (Blank ln1) (Blank ln2) = compare ln1 ln2 + compare (Res _) (Blank _) = LT + compare (Blank _) (Res _) = GT + -- .. else use show string comparison + compare l1 l2 = comparing show l1 l2 + -- Similarly for <= + (Res qn1) <= (Res qn2) = qn1 <= qn2 + (Blank ln1) <= (Blank ln2) = ln1 <= ln2 + (Res _) <= (Blank _) = True + (Blank _) <= (Res _) = False + l1 <= l2 = show l1 <= show l2 + +instance Label RDFLabel where + labelIsVar (Blank _) = True + labelIsVar (Var _) = True + labelIsVar _ = False + getLocal (Blank loc) = loc + getLocal (Var loc) = '?':loc + getLocal (Res sn) = "Res_"++snLocal sn + getLocal (NoNode) = "None" + getLocal _ = "Lit_" + makeLabel ('?':loc) = Var loc + makeLabel loc = Blank loc + labelHash seed lb = hash seed (showCanon lb) + +-- | Get the canonical string for RDF label. +-- +-- Used for hashing, so that equivalent labels always return +-- the same hash value. + +showCanon :: RDFLabel -> String +showCanon (Res sn) = "<"++getScopedNameURI sn++">" +showCanon (Lit st (Just nam)) + | isLang nam = quote st ++ "@" ++ langTag nam + | otherwise = quote st ++ "^^" ++ getScopedNameURI nam +showCanon s = show s + + +-- | Define equality of nodes possibly based on different graph types. +-- +-- The version of equality defined here is not strictly RDF abstract syntax +-- equality, but my interpretation of equivalence for the purposes of +-- entailment, in the absence of any specific datatype knowledge other +-- than XML literals. +-- +labelEq :: RDFLabel -> RDFLabel -> Bool +labelEq (Res q1) (Res q2) = q1 == q2 +labelEq (Blank s1) (Blank s2) = s1 == s2 +labelEq (Var v1) (Var v2) = v1 == v2 +labelEq (Lit s1 t1) (Lit s2 t2) = s1 == s2 && t1 == t2 +labelEq _ _ = False + +--------------------------------------------------------- +-- Selected RDFLabel values +--------------------------------------------------------- + +res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil, + res_rdfs_member, res_rdfd_GeneralRestriction, + res_rdfd_onProperties, res_rdfd_constraint, + res_rdfd_maxCardinality, res_owl_sameAs, res_log_implies + :: RDFLabel + +res_rdf_type = Res rdf_type +res_rdf_first = Res rdf_first +res_rdf_rest = Res rdf_rest +res_rdf_nil = Res rdf_nil +res_rdfs_member = Res rdfs_member +res_rdfd_GeneralRestriction = Res rdfd_GeneralRestriction +res_rdfd_onProperties = Res rdfd_onProperties +res_rdfd_constraint = Res rdfd_constraint +res_rdfd_maxCardinality = Res rdfd_maxCardinality +res_owl_sameAs = Res owl_sameAs +res_log_implies = Res log_implies + +--------------------------------------------------------- +-- Additional functions on RDFLabel values +--------------------------------------------------------- + +-- |Test if supplied labal is a URI resource node +isUri :: RDFLabel -> Bool +isUri (Res _) = True +isUri _ = False + +-- |Test if supplied labal is a literal node +isLiteral :: RDFLabel -> Bool +isLiteral (Lit _ _) = True +isLiteral _ = False + +-- |Test if supplied labal is an untyped literal node +isUntypedLiteral :: RDFLabel -> Bool +isUntypedLiteral (Lit _ Nothing ) = True +isUntypedLiteral (Lit _ (Just tn)) = isLang tn +isUntypedLiteral _ = False + +-- |Test if supplied labal is an untyped literal node +isTypedLiteral :: RDFLabel -> Bool +isTypedLiteral (Lit _ (Just tn)) = not (isLang tn) +isTypedLiteral _ = False + +-- |Test if supplied labal is an XML literal node +isXMLLiteral :: RDFLabel -> Bool +isXMLLiteral = isDatatyped rdf_XMLLiteral + +-- |Test if supplied label is an typed literal node of a given datatype +isDatatyped :: ScopedName -> RDFLabel -> Bool +isDatatyped d (Lit _ (Just n)) = n == d +isDatatyped _ _ = False + +-- |Test if supplied label is a container membership property +-- +-- Check for namespace is RDF namespace and +-- first character of local name is '_' and +-- remaining characters of local name are all digits +isMemberProp :: RDFLabel -> Bool +isMemberProp (Res sn) = snScope sn == namespaceRDF && + head loc == '_' && + all isDigit (tail loc) + where + loc = snLocal sn +isMemberProp _ = False + +-- |Test if supplied labal is a blank node +isBlank :: RDFLabel -> Bool +isBlank (Blank _) = True +isBlank _ = False + +-- |Test if supplied labal is a query variable +isQueryVar :: RDFLabel -> Bool +isQueryVar (Var _) = True +isQueryVar _ = False + +-- |Extract text value from a literal node +getLiteralText :: RDFLabel -> String +getLiteralText (Lit s _) = s +getLiteralText _ = "" + +-- |Extract ScopedName value from a resource node +getScopedName :: RDFLabel -> ScopedName +getScopedName (Res sn) = sn +getScopedName _ = nullScopedName + +-- |Make a blank node from a supplied query variable, +-- or return the supplied label unchanged. +-- (Use this in when substituting an existential for an +-- unsubstituted query variable.) +makeBlank :: RDFLabel -> RDFLabel +makeBlank (Var loc) = Blank loc +makeBlank lb = lb + +-- | RDF Triple (statement) + +type RDFTriple = Arc RDFLabel + +-- | Namespace prefix list entry + +type NamespaceMap = LookupMap Namespace + +data RevNamespace = RevNamespace Namespace + +instance LookupEntryClass RevNamespace String String where + keyVal (RevNamespace (Namespace pre uri)) = (uri,pre) + newEntry (uri,pre) = RevNamespace (Namespace pre uri) + +type RevNamespaceMap = LookupMap RevNamespace + +emptyNamespaceMap :: NamespaceMap +emptyNamespaceMap = LookupMap [] + +-- | Graph formula entry + +data LookupFormula lb gr = Formula + { formLabel :: lb + , formGraph :: gr + } + +instance ( Eq lb, Eq gr ) => Eq (LookupFormula lb gr) where + f1 == f2 = formLabel f1 == formLabel f2 && + formGraph f1 == formGraph f2 + +instance (Label lb) + => LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb) + where + keyVal fe = (formLabel fe, formGraph fe) + newEntry (k,v) = Formula { formLabel=k, formGraph=v } + +instance (Label lb) => Show (LookupFormula lb (NSGraph lb)) + where + show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" + +type Formula lb = LookupFormula lb (NSGraph lb) + +type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb)) + +emptyFormulaMap :: FormulaMap RDFLabel +emptyFormulaMap = LookupMap [] + +{- given up on trying to do Functor for formulae... +instance Functor (LookupFormula (NSGraph lb)) where + fmap f fm = mapTranslateEntries (mapFormulaEntry f) fm +-} + +formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2 +formulaeMap f = fmap (formulaEntryMap f) + +formulaEntryMap :: + (lb -> l2) + -> Formula lb + -> Formula l2 +formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr) + +formulaeMapA :: Applicative f => (lb -> f l2) -> + FormulaMap lb -> f (FormulaMap l2) +formulaeMapA f = T.traverse (formulaEntryMapA f) + +formulaEntryMapA :: + (Applicative f) => + (lb -> f l2) + -> Formula lb + -> f (Formula l2) +formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> T.traverse f gr + +{- +formulaeMapM :: + (Monad m) => (lb -> m l2) -> FormulaMap lb -> m (FormulaMap l2) +formulaeMapM f = T.mapM (formulaEntryMapM f) + +formulaEntryMapM :: + (Monad m) + => (lb -> m l2) + -> Formula lb + -> m (Formula l2) +formulaEntryMapM f (Formula k gr) = + Formula `liftM` f k `ap` T.mapM f gr + +-} + +-- | Memory-based graph with namespaces and subgraphs + +data NSGraph lb = NSGraph + { namespaces :: NamespaceMap + , formulae :: FormulaMap lb + , statements :: [Arc lb] + } + +getNamespaces :: NSGraph lb -> NamespaceMap +getNamespaces = namespaces + +setNamespaces :: NamespaceMap -> NSGraph lb -> NSGraph lb +setNamespaces ns g = g { namespaces=ns } + +getFormulae :: NSGraph lb -> FormulaMap lb +getFormulae = formulae + +setFormulae :: FormulaMap lb -> NSGraph lb -> NSGraph lb +setFormulae fs g = g { formulae=fs } + +getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb) +getFormula g l = mapFindMaybe l (formulae g) + +setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb +setFormula f g = g { formulae=mapReplaceOrAdd f (formulae g) } + +instance (Label lb) => LDGraph NSGraph lb where + getArcs = statements + setArcs as g = g { statements=as } + containedIn = undefined -- TODO: should there be one defined? + +-- Optimized method to add arc .. don't check for duplicates. +addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb +addArc ar gr = gr { statements=addSetElem ar (statements gr) } + +instance Functor NSGraph where + fmap f (NSGraph ns fml stmts) = + NSGraph ns (formulaeMap f fml) ((map $ fmap f) stmts) + +instance F.Foldable NSGraph where + foldMap = T.foldMapDefault + +instance T.Traversable NSGraph where + traverse f (NSGraph ns fml stmts) = + (NSGraph ns) <$> formulaeMapA f fml <*> (T.traverse $ T.traverse f) stmts + +instance (Label lb) => Eq (NSGraph lb) where + (==) = grEq + +instance (Label lb) => Show (NSGraph lb) where + show = grShow "" + showList = grShowList "" + +grShowList :: (Label lb) => String -> [NSGraph lb] -> String -> String +grShowList _ [] = showString "[no graphs]" +grShowList p (g:gs) = showChar '[' . showString (grShow pp g) . showl gs + where + showl [] = showChar ']' -- showString $ "\n" ++ p ++ "]" + showl (h:hs) = showString (",\n "++p++grShow pp h) . showl hs + pp = ' ':p + +grShow :: (Label lb) => String -> NSGraph lb -> String +grShow p g = + "Graph, formulae: " ++ showForm ++ "\n" ++ + p ++ "arcs: " ++ showArcs p g + where + showForm = foldr ((++) . (pp ++) . show) "" fml + fml = listLookupMap (getFormulae g) + pp = "\n " ++ p + +showArcs :: (Label lb) => String -> NSGraph lb -> String +showArcs p g = foldr ((++) . (pp ++) . show) "" (getArcs g) + where + pp = "\n " ++ p + +grEq :: (Label lb) => NSGraph lb -> NSGraph lb -> Bool +grEq g1 g2 = fst ( grMatchMap g1 g2 ) + +grMatchMap :: (Label lb) => + NSGraph lb -> NSGraph lb -> (Bool, LabelMap (ScopedLabel lb)) +grMatchMap g1 g2 = + graphMatch matchable (getArcs g1) (getArcs g2) + where + matchable l1 l2 = mapFormula g1 l1 == mapFormula g2 l2 + mapFormula g l = mapFindMaybe l (getFormulae g) + +toNSGraph :: (Eq lb, Show lb) => [Arc lb] -> NSGraph lb +toNSGraph arcs = + NSGraph + { statements = arcs + , namespaces = emptyNamespaceMap + , formulae = LookupMap [] + } + +-- |Merge RDF graphs, renaming blank and query variable nodes as +-- needed to neep variable nodes from the two graphs distinct in +-- the resulting graph. +merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb +merge gr1 gr2 = + let + bn1 = allLabels labelIsVar gr1 + bn2 = allLabels labelIsVar gr2 + dupbn = intersect bn1 bn2 + allbn = union bn1 bn2 + in + add gr1 (remapLabels dupbn allbn id gr2) + +-- |Return list of all labels (including properties) in the graph +-- satisfying a supplied filter predicate. +allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) ) + +-- |Return list of all subjects and objects in the graph +-- satisfying a supplied filter predicate. +allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +allNodes p = unionNodes p [] . nodes + +-- | List all nodes in graph formulae satisfying a supplied predicate +formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +formulaNodes p gr = foldl (unionNodes p) fkeys (map (allLabels p) fvals) + where + -- fm :: (Label lb) => FormulaMap lb + -- LookupMap LookupFormula (NSGraph lb) lb + fm = formulae gr + -- fvals :: (Label lb) => [NSGraph lb] + fvals = mapVals fm + -- fkeys :: (Label lb) => [lb] + fkeys = filter p $ mapKeys fm + +-- | Helper to filter variable nodes and merge with those found so far +unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb] +unionNodes p ls1 ls2 = ls1 `union` filter p ls2 + +-- |Remap selected nodes in graph: +-- +-- This is the node renaming operation that prevents graph-scoped +-- variable nodes from being merged when two graphs are merged. +remapLabels :: + (Label lb) + => [lb] -- ^ variable nodes to be renamed (@dupbn@) + -> [lb] -- ^ variable nodes used that must be avoided (@allbn@) + -> (lb -> lb) -- ^ node conversion function that is applied to nodes + -- from @dupbn@ in the graph that are to be replaced by + -- new blank nodes. If no such conversion is required, + -- supply @id@. The function 'makeBlank' can be used to convert + -- RDF query nodes into RDF blank nodes. + -> NSGraph lb -- ^ graph in which nodes are to be renamed + -> NSGraph lb +remapLabels dupbn allbn cnvbn = fmap (mapnode dupbn allbn cnvbn) + +-- |Externally callable function to construct a list of (old,new) +-- values to be used for graph label remapping. +-- +remapLabelList :: + (Label lb) + => [lb] -- ^ labels to be remaped + -> [lb] -- ^ labels to be avoided by the remapping + -> [(lb,lb)] +remapLabelList remap avoid = maplist remap avoid id [] + +-- | Remap a single graph node. +-- +-- If the node is not one of those to be remapped, +-- the supplied value is returned unchanged. +mapnode :: + (Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb +mapnode dupbn allbn cnvbn nv = + mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn [])) + +-- | Construct a list of (oldnode,newnode) values to be used for +-- graph label remapping. The function operates recursiovely, adding +-- new nodes generated to the mapping list (mapbn') and also to the +-- list of nodes to be avoided (allbn'). +maplist :: + (Label lb) => [lb] -> [lb] -> (lb -> lb) -> [(lb,lb)] -> [(lb,lb)] +maplist [] _ _ mapbn = mapbn +maplist (dn:dupbn) allbn cnvbn mapbn = maplist dupbn allbn' cnvbn mapbn' + where + dnmap = newNode (cnvbn dn) allbn + mapbn' = (dn,dnmap):mapbn + allbn' = dnmap:allbn + +-- |Given a node and a list of existing nodes, find a new node for +-- the supplied node that does not clash with any existing node. +-- (Generates an non-terminating list of possible replacements, and +-- picks the first one that isn't already in use.) +-- +-- TODO: optimize this for common case @nnn@ and @_nnn@: +-- always generate @_nnn@ and keep track of last allocated +-- +newNode :: (Label lb) => lb -> [lb] -> lb +newNode dn existnodes = + head $ newNodes dn existnodes + +-- |Given a node and a list of existing nodes, generate a list of new +-- nodes for the supplied node that do not clash with any existing node. +newNodes :: (Label lb) => lb -> [lb] -> [lb] +newNodes dn existnodes = + filter (not . (`elem` existnodes)) $ trynodes (noderootindex dn) + +noderootindex :: (Label lb) => lb -> (String,Int) +noderootindex dn = (nh,nx) where + (nh,nt) = splitnodeid $ getLocal dn + nx = if null nt then 0 else read nt + +splitnodeid :: String -> (String,String) +splitnodeid dn = splitAt (tx+1) dn where + tx = last $ (-1):findIndices (not . isDigit) dn + +trynodes :: (Label lb) => (String,Int) -> [lb] +trynodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] + +{- +trybnodes :: (Label lb) => (String,Int) -> [lb] +trybnodes (nr,nx) = [ makeLabel (nr++show n) | n <- iterate (+1) nx ] +-} + +-- | Memory-based RDF graph type + +type RDFGraph = NSGraph RDFLabel + +-- |Create a new RDF graph from a supplied list of arcs +toRDFGraph :: [Arc RDFLabel] -> RDFGraph +toRDFGraph = toNSGraph + +-- |Create a new, empty RDF graph. +emptyRDFGraph :: RDFGraph +emptyRDFGraph = toRDFGraph [] + +{- +-- |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 -> [Arc RDFLabel] -> RDFGraph +updateRDFGraph gr as = gr { statements=as } +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFGraphShowM.hs b/Swish/RDF/RDFGraphShowM.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFGraphShowM.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE TypeSynonymInstances #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFGraphShowM +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : TypeSynonymInstances +-- +-- This module defines a `ShowM` class instance for `RDFGraph`, to be +-- used when displaying RDF Graph values as part of a proof sequence, +-- etc. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFGraphShowM() +where + +import Swish.RDF.RDFGraph + ( RDFGraph ) + +import Swish.RDF.N3Formatter + ( formatGraphIndent ) + +import Swish.Utils.ShowM + ( ShowM(..) ) + + +------------------------------------------------------------ +-- ShowM instance for RDFGraph +------------------------------------------------------------ + +instance ShowM RDFGraph where + showms linebreak = formatGraphIndent linebreak False + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFParser.hs b/Swish/RDF/RDFParser.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFParser.hs @@ -0,0 +1,214 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFParser +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- Support for the RDF Parsing modules. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFParser + ( SpecialMap + , mapPrefix + + -- tables + , prefixTable, specialTable + + -- parser + , ParseResult, RDFParser + , n3Style, n3Lexer + , ignore + , annotateParsecError + , mkTypedLit + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , NamespaceMap + ) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , mapFind + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceOWL + , namespaceLOG + , rdf_type + , rdf_first, rdf_rest, rdf_nil + , owl_sameAs, log_implies + , default_base + ) + +import Control.Applicative +import Control.Monad (MonadPlus(..), ap) + +import Text.ParserCombinators.Parsec (GenParser, ParseError, char, letter, alphaNum, errorPos, sourceLine, sourceColumn) +import Text.ParserCombinators.Parsec.Error (errorMessages, showErrorMessages) +import Text.ParserCombinators.Parsec.Language (emptyDef) +import qualified Text.ParserCombinators.Parsec.Token as P + +import Data.Maybe (fromMaybe) + +-- Code + +{-| +The language definition for N3-style formats. +-} + +n3Style :: P.LanguageDef st +n3Style = + emptyDef + { P.commentStart = "" + , P.commentEnd = "" + , P.commentLine = "#" + , P.nestedComments = True + , P.identStart = letter <|> char '_' -- oneOf "_" + , P.identLetter = alphaNum <|> char '_' + , P.reservedNames = [] + , P.reservedOpNames= [] + , P.caseSensitive = True + } + +{-| +The lexer for N3 style languages. +-} +n3Lexer :: P.TokenParser st +n3Lexer = P.makeTokenParser n3Style + +-- | Type for special name lookup table +type SpecialMap = LookupMap (String,ScopedName) + +-- | Lookup prefix in table and return URI or 'prefix:' +mapPrefix :: NamespaceMap -> String -> String +mapPrefix ps pre = mapFind (pre++":") pre ps + +-- | Define default table of namespaces +prefixTable :: [Namespace] +prefixTable = [ namespaceRDF + , namespaceRDFS + , namespaceRDFD -- datatypes + , namespaceOWL + , namespaceLOG + , Namespace "" "#" -- is this correct? + ] + +{-| +Define default special-URI table. +The optional argument defines the initial base URI. +-} +specialTable :: Maybe ScopedName -> [(String,ScopedName)] +specialTable mbase = + [ ("a", rdf_type ), + ("equals", owl_sameAs ), + ("implies", log_implies ), + ("listfirst", rdf_first ), + ("listrest", rdf_rest ), + ("listnull", rdf_nil ), + ("base", fromMaybe default_base mbase ) + ] + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +type RDFParser a b = GenParser Char a b + +-- Applicative/Alternative are defined for us in Parsec 3 +instance Applicative (GenParser a b) where + pure = return + (<*>) = ap + +instance Alternative (GenParser a b) where + empty = mzero + (<|>) = mplus + +type ParseResult = Either String RDFGraph + +ignore :: (Monad m) => m a -> m () +ignore p = p >> return () + +-- | Annotate a Parsec error with the local context - i.e. the actual text +-- that caused the error and preceeding/succeeding lines (if available) +-- +annotateParsecError :: + Int -- ^ the number of extra lines to include in the context (<=0 is ignored) + -> [String] -- ^ text being parsed + -> ParseError -- ^ the parse error + -> String -- ^ Parsec error with additional context +annotateParsecError extraLines ls err = + -- the following is based on the show instance of ParseError + let ePos = errorPos err + lNum = sourceLine ePos + cNum = sourceColumn ePos + -- it is possible to be at the end of the input so need + -- to check; should produce better output than this in this + -- case + nLines = length ls + ln1 = lNum - 1 + eln = max 0 extraLines + lNums = [max 0 (ln1 - eln) .. min (nLines-1) (ln1 + eln)] + + beforeLines = map (ls !!) $ filter (< ln1) lNums + afterLines = map (ls !!) $ filter (> ln1) lNums + + -- in testing was able to get a line number after the text so catch this + -- case; is it still necessary? + errorLine = if ln1 >= nLines then "" else ls !! ln1 + arrowLine = replicate (cNum-1) ' ' ++ "^" + finalLine = "(line " ++ show lNum ++ ", column " ++ show cNum ++ " indicated by the '^' sign above):" + + eHdr = "" : beforeLines ++ errorLine : arrowLine : afterLines ++ [finalLine] + eMsg = showErrorMessages "or" "unknown parse error" "expecting" "unexpected" "end of input" + (errorMessages err) + + in unlines eHdr ++ eMsg + +-- | Create a typed literal. +mkTypedLit :: + ScopedName -- ^ the type + -> String -- ^ the value + -> RDFLabel +mkTypedLit u v = Lit v (Just u) + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFProof.hs b/Swish/RDF/RDFProof.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFProof.hs @@ -0,0 +1,381 @@ +{-# LANGUAGE FlexibleInstances, UndecidableInstances #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFProof +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, UndecidableInstances +-- +-- This module instantiates the 'Proof' framework for +-- constructing proofs over RDFGraph expressions. +-- The intent is that this can be used to test some +-- correspondences between the RDF Model theory and +-- corresponding proof theory based on closure rules +-- applied to the graph, per . +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFProof + ( RDFProof, RDFProofStep + , makeRDFProof, makeRDFProofStep + , makeRdfInstanceEntailmentRule + , makeRdfSubgraphEntailmentRule + , makeRdfSimpleEntailmentRule ) +where + +import Swish.RDF.RDFQuery + ( rdfQueryInstance + , rdfQuerySubs + ) + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleset ) + +import Swish.RDF.RDFGraph + ( RDFLabel(..), RDFGraph + --, makeBlank + , merge , allLabels , remapLabelList + {-, newNode, newNodes + , toRDFGraph -}, emptyRDFGraph + ) + +import Swish.RDF.VarBinding + ( makeVarBinding + ) + +import Swish.RDF.Proof + ( Proof(..), Step(..) ) + +import Swish.RDF.Rule + ( Expression(..), Rule(..) ) + +import Swish.Utils.Namespace + ( ScopedName(..) + ) + +import Swish.RDF.GraphClass + ( Label(..), LDGraph(..), replaceArcs ) + +import Swish.Utils.LookupMap + ( makeLookupMap, mapFind ) + +import Swish.Utils.ListHelpers + ( subset + , powerSet + , powerSequences_len + , flist + ) + +------------------------------------------------------------ +-- Type instantiation of Proof framework for RDFGraph data +------------------------------------------------------------ +-- +-- This is a partial instantiation of the proof framework. +-- Details for applying inference rules are specific to the +-- graph instance type. + +------------------------------------------------------------ +-- Proof datatypes for graph values +------------------------------------------------------------ + +-- The following is an orphan instance + +-- |Instances of 'LDGraph' are also instance of the +-- @Expression@ class, for which proofs can be constructed. +-- The empty RDF graph is always @True@ (other enduring +-- truths are asserted as axioms). +instance (Label lb, LDGraph lg lb) => Expression (lg lb) where + isValid gr = null $ getArcs gr + +------------------------------------------------------------ +-- Define RDF-specific types for proof framework +------------------------------------------------------------ + +type RDFProof = Proof RDFGraph + +type RDFProofStep = Step RDFGraph + +------------------------------------------------------------ +-- Helper functions for constructing proofs on RDF graphs +------------------------------------------------------------ + +-- |Make an RDF graph proof step +-- +makeRDFProofStep :: + RDFRule -- ^ rule to use for this step + -> [RDFFormula] -- ^ antecedent RDF formulae for this step + -> RDFFormula -- ^ RDF formula that is the consequent for this step + -> RDFProofStep +makeRDFProofStep rul ants con = Step + { stepRule = rul + , stepAnt = ants + , stepCon = con + } + +-- |Make an RDF proof +-- +makeRDFProof :: + [RDFRuleset] -- ^ RDF rulesets that constitute a proof context for this proof + -> RDFFormula -- ^ initial statement from which the goal is claimed to be proven + -> RDFFormula -- ^ statement that is claimed to be proven + -> [RDFProofStep] + -> RDFProof +makeRDFProof rsets base goal steps = Proof + { proofContext = rsets + , proofInput = base + , proofResult = goal + , proofChain = steps + } + +------------------------------------------------------------ +-- RDF instance entailment inference rule +------------------------------------------------------------ + +-- |Make an inference rule dealing with RDF instance entailment; +-- i.e. entailments that are due to replacement of a URI or literal +-- node with a blank node. +-- +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' and 'bwdApply' functions defined here may return +-- rather large results if applied to graphs with many variables or +-- a large vocabulary, and are defined for experimentation. +-- +-- Forward and backward chaining is performed with respect to a +-- specified vocabulary. In the case of backward chaining, it would +-- otherwise be impossible to bound the options thus generated. +-- In the case of forward chaining, it is often not desirable to +-- have the properties generalized. If forward or backward backward +-- chaining will not be used, supply an empty vocabulary. +-- Note: graph method 'allNodes' can be used to obtain a list of all +-- the subjects and objuects used ina graph, not counting nested +-- formulae; use a call of the form: +-- +-- > allNodes (not . labelIsVar) graph +-- +makeRdfInstanceEntailmentRule :: ScopedName -> [RDFLabel] -> RDFRule +makeRdfInstanceEntailmentRule name vocab = newrule + where + newrule = Rule + { ruleName = name + , fwdApply = rdfInstanceEntailFwdApply vocab + , bwdApply = rdfInstanceEntailBwdApply vocab + , checkInference = rdfInstanceEntailCheckInference + } + +-- Instance entailment forward chaining +-- +-- Note: unless the initial graph is small, the total result +-- here could be very large. The existential generalizations are +-- sequenced in increasing number of substitutions applied. +-- This sequencing is determined by the powerset function used, +-- which generates subsets in increasing order of size +-- (see module 'ListHelpers'). +-- +-- The instances generated are all copies of the merge of the +-- supplied graphs, with some or all of the non-variable nodes +-- replaced by blank nodes. +rdfInstanceEntailFwdApply :: [RDFLabel] -> [RDFGraph] -> [RDFGraph] +rdfInstanceEntailFwdApply vocab ante = + let + -- Merge antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + mergeGraph = if null ante then emptyRDFGraph + else foldl1 merge ante + -- Obtain lists of variable and non-variable nodes + -- (was: nonvarNodes = allLabels (not . labelIsVar) mergeGraph) + nonvarNodes = vocab + varNodes = allLabels labelIsVar mergeGraph + -- Obtain list of possible remappings for non-variable nodes + mapList = remapLabelList nonvarNodes varNodes + mapSubLists = powerSet mapList + mapGr ls = fmap (\l -> mapFind l l (makeLookupMap ls)) + in + -- Return all remappings of the original merged graph + flist (map mapGr mapSubLists) mergeGraph + +-- Instance entailment backward chaining (for specified vocabulary) +-- +-- [[[TODO: this is an incomplete implementation, there being no +-- provision for instantiating some variables and leaving others +-- alone. This can be overcome in many cases by combining instance +-- and subgraph chaining. +-- Also, there is no provision for instantiating some variables in +-- a triple and leaving others alone. This may be fixed later if +-- this function is really needed to be completely faithful to the +-- precise notion of instance entailment.]]] +rdfInstanceEntailBwdApply :: [RDFLabel] -> RDFGraph -> [[RDFGraph]] +rdfInstanceEntailBwdApply vocab cons = + let + -- Obtain list of variable nodes + varNodes = allLabels labelIsVar cons + -- Generate a substitution for each combination of variable + -- and vocabulary node. + varBindings = map (makeVarBinding . zip varNodes) vocSequences + vocSequences = powerSequences_len (length varNodes) vocab + in + -- Generate a substitution for each combination of variable + -- and vocabulary: + [ rdfQuerySubs [v] cons | v <- varBindings ] + +-- Instance entailment inference checker +rdfInstanceEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfInstanceEntailCheckInference ante cons = + let + mante = if null ante then emptyRDFGraph -- merged antecedents + else foldl1 merge ante + qvars = rdfQueryInstance cons mante -- all query matches + bsubs = rdfQuerySubs qvars cons -- all back substitutions + in + -- Return True if any back-substitution matches the original + -- merged antecendent graph. + any (mante ==) bsubs + +-- Instance entailment notes. +-- +-- Relation to simple entailment (s-entails): +-- +-- (1) back-substitution yields original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o1 by [_:o1/ex:o1] +-- +-- (2) back-substitution yields original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] +-- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/_:o1] +-- +-- (3) back-substitution does not yield original graph +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 _:o2 by [_:o2/ex:o1] +-- ex:s1 ex:p1 _:o1 ex:s1 ex:p1 _:o3 [_:o3/ex:o1] +-- +-- (4) consider +-- ex:s1 ex:p1 ex:o1 s-entails ex:s1 ex:p1 ex:o1 +-- ex:s1 ex:p1 ex:o2 ex:s1 ex:p1 ex:o2 +-- ex:s1 ex:p1 ex:o3 ex:s1 ex:p1 _:o1 +-- ex:s1 ex:p1 _:o2 +-- where [_:o1/ex:o1,_:o2/ex:o2] yields a simple entailment but not +-- an instance entailment, but [_:o1/ex:o3,_:o2/ex:o3] is also +-- (arguably) an instance entailment. Therefore, it is not sufficient +-- to look only at the "largest" substitutions to determine instance +-- entailment. +-- +-- All this means that when checking for instance entailment by +-- back substitution, all of the query results must be checked. +-- This seems clumsy. If this function is heavily used with +-- multiple query matches, a modified query that uses each +-- triple of the target graph exactly once may be required. + +------------------------------------------------------------ +-- RDF subgraph entailment inference rule +------------------------------------------------------------ + +-- |Make an inference rule dealing with RDF subgraph entailment. +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' function defined here may return rather large +-- results. But in the name of completeness and experimentation +-- with the possibilities of lazy evaluation, it has been defined. +-- +-- Backward chaining is not performed, as there is no reasonable way +-- to choose a meaningful supergraph of that supplied. +makeRdfSubgraphEntailmentRule :: ScopedName -> RDFRule +makeRdfSubgraphEntailmentRule name = newrule + where + newrule = Rule + { ruleName = name + , fwdApply = rdfSubgraphEntailFwdApply + , bwdApply = const [] + , checkInference = rdfSubgraphEntailCheckInference + } + +-- Subgraph entailment forward chaining +-- +-- Note: unless the initial graph is small, the total result +-- here could be very large. The subgraphs are sequenced in +-- increasing size of the sub graph. This sequencing is determined +-- by the 'powerSet' function used which generates subsets in +-- increasing order of size (see module 'ListHelpers'). +rdfSubgraphEntailFwdApply :: [RDFGraph] -> [RDFGraph] +rdfSubgraphEntailFwdApply ante = + let + -- Merge antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + mergeGraph = if null ante then emptyRDFGraph + else foldl1 merge ante + in + -- Return all subgraphs of the full graph constructed above + map (replaceArcs mergeGraph) (init $ powerSet $ getArcs mergeGraph) + +-- Subgraph entailment inference checker +-- +-- This is of dubious utiltiy, as it doesn't allow for node renaming. +-- The simple entailment inference rule is probably more useful here. +rdfSubgraphEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfSubgraphEntailCheckInference ante cons = + let + -- Combine antecedents to single graph, renaming bnodes if needed. + -- (Null test and using 'foldl1' to avoid merging if possible.) + fullGraph = if null ante then emptyRDFGraph + else foldl1 add ante + in + -- Check each consequent graph arc is in the antecedent graph + getArcs cons `subset` getArcs fullGraph + +------------------------------------------------------------ +-- RDF simple entailment inference rule +------------------------------------------------------------ + +-- |Make an inference rule dealing with RDF simple entailment. +-- The part of this rule expected to be useful is 'checkInference'. +-- The 'fwdApply' and 'bwdApply' functions defined return null +-- results, indicating that they are not useful for the purposes +-- of proof discovery. +makeRdfSimpleEntailmentRule :: ScopedName -> RDFRule +makeRdfSimpleEntailmentRule name = newrule + where + newrule = Rule + { ruleName = name + , fwdApply = const [] + , bwdApply = const [] + , checkInference = rdfSimpleEntailCheckInference + } + +-- Simple entailment inference checker +-- +-- Note: antecedents here are presumed to share bnodes. +-- (Use 'merge' instead of 'add' for non-shared bnodes) +-- +rdfSimpleEntailCheckInference :: [RDFGraph] -> RDFGraph -> Bool +rdfSimpleEntailCheckInference ante cons = + let agr = if null ante then emptyRDFGraph else foldl1 add ante + in + not $ null $ rdfQueryInstance cons agr + +{- original.. + not $ null $ rdfQueryInstance cons (foldl1 merge ante) +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFProofContext.hs b/Swish/RDF/RDFProofContext.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFProofContext.hs @@ -0,0 +1,859 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFProofContext +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains proof-context declarations based on +-- the RDF, RDFS and RDF datatyping semantics specifications. +-- These definitions consist of namespaces (for identification +-- in proofs), axioms and inference rules. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFProofContext + ( rulesetRDF + , rulesetRDFS + , rulesetRDFD ) +where + +import Swish.RDF.BuiltInDatatypes + ( findRDFDatatype ) + +import Swish.RDF.RDFProof + ( makeRdfSubgraphEntailmentRule + , makeRdfSimpleEntailmentRule ) + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleset + , makeRDFFormula + , makeN3ClosureRule + , makeN3ClosureSimpleRule + , makeN3ClosureModifyRule + , makeN3ClosureAllocatorRule + , makeNodeAllocTo ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding + , RDFVarBindingModify + , RDFVarBindingFilter + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) + +import Swish.RDF.RDFGraph + ( RDFLabel(..) + , isUri, isDatatyped + , getLiteralText ) + +import Swish.RDF.VarBinding + ( applyVarBinding + , addVarBinding + , VarBindingModify(..) + , makeVarFilterModify + , varFilterDisjunction + ) + +import Swish.RDF.Ruleset (makeRuleset) + +import Swish.RDF.Datatype + ( typeMkCanonicalForm ) + +import Swish.Utils.Namespace + ( Namespace(..), ScopedName(..) + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , scopeRDF + , scopeRDFS + , scopeRDFD + ) + +import Data.Maybe (isJust, fromJust) + +import Control.Monad (liftM) + +------------------------------------------------------------ +-- Define query binding filter auxiliaries +------------------------------------------------------------ + +makeFormula :: Namespace -> String -> String -> RDFFormula +makeFormula scope local gr = + makeRDFFormula scope local (prefixRDF++gr) + +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 = ScopedName 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 st = Lit st (Just dqn2) + + getRes (Res dqnam) = dqnam + getRes x = error $ "Expected a Resource, sent " ++ show x -- for -Wall + +{- -- Test data +qnamint = ScopedName namespaceXSD "integer" +xsdint = Res qnamint +lab010 = Lit "010" (Just qnamint) +can010 = getCanonical lab010 xsdint xsdint +nsex = Namespace "ex" "http://example.org/" +resexp = Res (ScopedName nsex "p") +resexs = Res (ScopedName nsex "s") + +vara = Var "a" +varb = Var "b" +varc = Var "c" +vard = Var "d" +varp = Var "p" +vars = Var "s" +vart = Var "t" + +vb1 = makeVarBinding [(vara,lab010),(varb,xsdint),(vard,xsdint)] +vb2 = sameDatatypedValueApply vara varb varc vard vb1 +vb3 = vbmApply (sameDatatypedValue vara varb varc vard) [vb1] +vb3t = vb3 == vb2 +vb4 = vbmApply (valueSame "a" "b" "c" "d") [vb1] +vb4t = vb4 == vb2 +vb5 = vbmApply (valueSame "a" "b" "c" "b") [vb1] +vb5t = vb5 == vb2 + +vb6 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint)] +vb7 = vbmApply (valueSame "s" "d" "t" "d") [vb6] +vb8 = makeVarBinding [(vars,lab010),(varp,resexp),(vara,resexs),(vard,xsdint) + ,(vart,fromJust can010)] +vb8t = vb7 == [vb8] +-- -} + +------------------------------------------------------------ +-- Common definitions +------------------------------------------------------------ + +prefixRDF :: String +prefixRDF = + "@prefix rdf: <" ++ nsURI namespaceRDF ++ "> . \n" ++ + "@prefix rdfs: <" ++ nsURI namespaceRDFS ++ "> . \n" ++ + "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ + " \n" + +------------------------------------------------------------ +-- 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 (ScopedName 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 (ScopedName 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.) +-- +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 + ] + +-- Define 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.) +-- +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 "cp1" + "?x ?c ?y . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp12 :: RDFRule +rdfscp12 = makeN3ClosureRule scopeRDFS "cp1" + "?c ?p ?y . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp13 :: RDFRule +rdfscp13 = makeN3ClosureRule scopeRDFS "cp1" + "?x ?p ?c . " + "?c rdf:type rdfs:ContainerMembershipProperty ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp21 :: RDFRule +rdfscp21 = makeN3ClosureRule scopeRDFS "cp1" + "?x ?c ?y . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp22 :: RDFRule +rdfscp22 = makeN3ClosureRule scopeRDFS "cp1" + "?c ?p ?y . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp23 :: RDFRule +rdfscp23 = makeN3ClosureRule scopeRDFS "cp1" + "?x ?p ?c . " + "?c rdfs:domain rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp31 :: RDFRule +rdfscp31 = makeN3ClosureRule scopeRDFS "cp1" + "?x ?c ?y . " + "?c rdfs:range rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp32 :: RDFRule +rdfscp32 = makeN3ClosureRule scopeRDFS "cp1" + "?c ?p ?y . " + "?c rdfs:range rdfs:Resource ." + (makeVarFilterModify $ isMemberPropV "c") + +rdfscp33 :: RDFRule +rdfscp33 = makeN3ClosureRule scopeRDFS "cp1" + "?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 + ] + +-- Define 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 . " ++ + "?a ?p ?s ." ) + "?a ?p ?t ." + (makeVarFilterModify $ isDatatypedV "s" "d") + (valueSame "s" "d" "t" "e") + +-- Collect RDFD rules +-- +rulesRDFD :: [RDFRule] +rulesRDFD = + [ rdfdr1, rdfdr2, rdfdr3 + ] + +-- Define ruleset for RDFD inference +-- +rulesetRDFD :: RDFRuleset +rulesetRDFD = makeRuleset scopeRDFD axiomsRDFD rulesRDFD + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFQuery.hs b/Swish/RDF/RDFQuery.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFQuery.hs @@ -0,0 +1,619 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFQuery +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines functions for querying an RDF graph to obtain +-- a set of variable substitutions, and to apply a set of variable +-- substitutions to a query pattern to obtain a new graph. +-- +-- It also defines a few primitive graph access functions. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFQuery + ( rdfQueryFind, rdfQueryFilter + , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify + , rdfQueryInstance + , rdfQuerySubs, rdfQueryBackSubs + , rdfQuerySubsAll + , rdfQuerySubsBlank, rdfQueryBackSubsBlank + , rdfFindArcs, rdfSubjEq, rdfPredEq, rdfObjEq + , rdfFindPredVal, rdfFindPredInt, rdfFindValSubj + , rdfFindList + -- debug + , rdfQuerySubs2 ) +where + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding, nullRDFVarBinding + , RDFVarBindingFilter + ) + +import Swish.RDF.RDFGraph + ( Arc(..), LDGraph(..) + , arcSubj, arcPred, arcObj + , RDFLabel(..) + , isDatatyped, isBlank, isQueryVar + , getLiteralText, makeBlank + , RDFTriple + , RDFGraph, emptyRDFGraph + , allLabels, remapLabels + , res_rdf_first + , res_rdf_rest + , res_rdf_nil + ) + +import Swish.RDF.MapXsdInteger + ( mapXsdInteger + ) + +import Swish.RDF.Datatype + ( DatatypeMap(..) + ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + , makeVarBinding + , applyVarBinding, joinVarBindings + , VarBindingModify(..) + , VarBindingFilter(..) + ) + +import Swish.RDF.Vocabulary + ( xsd_integer, xsd_nonneg_integer + ) + +import Swish.Utils.ListHelpers + ( listProduct, allp, anyp ) + +import qualified Data.Traversable as T + +import Control.Monad.State + ( State, runState, modify ) + +import Data.Maybe + ( mapMaybe, isJust, fromJust ) + +------------------------------------------------------------ +-- Primitive RDF graph queries +------------------------------------------------------------ + +-- |Basic graph-query function. +-- +-- A very basic form of graph query, a query graph and +-- a target graph, and returns a list of 'RDFVarBinding' +-- values, each of which corresponds to a set of variable +-- bindings that make the query graph a subgraph of the +-- target graph, or @[]@ if the query cannot be matched. +-- +-- 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 -> RDFGraph -> [RDFVarBinding] +rdfQueryFind = + rdfQueryPrim1 matchQueryVariable nullRDFVarBinding . getArcs + +-- Helper function to match query against a graph. +-- A node-query function is supplied to determine how query nodes +-- are matched against target graph nodes. Also supplied is +-- an initial variable binding. +-- +rdfQueryPrim1 :: + NodeQuery RDFLabel -> RDFVarBinding -> [Arc RDFLabel] + -> RDFGraph + -> [RDFVarBinding] +rdfQueryPrim1 _ initv [] _ = [initv] +rdfQueryPrim1 nodeq initv (qa:qas) tg = + let + qam = fmap (applyVarBinding initv) qa -- subst vars already bound + newv = rdfQueryPrim2 nodeq qam tg -- new bindings, or null + in + concat + [ rdfQueryPrim1 nodeq v2 qas tg + | v1 <- newv + , let v2 = joinVarBindings initv v1 + ] + +-- Match single query term against graph, and return any new sets +-- of variable bindings thus defined, or [] if the query term +-- cannot be matched. Each of the RDFVarBinding values returned +-- represents an alternative possible match for the query arc. +-- +rdfQueryPrim2 :: + NodeQuery RDFLabel -> Arc RDFLabel + -> RDFGraph + -> [RDFVarBinding] +rdfQueryPrim2 nodeq qa tg = + mapMaybe (getBinding nodeq qa) (getArcs tg) + +-- |RDF query filter. +-- +-- This function applies a supplied query binding +-- filter to the result from a call of 'rdfQueryFind'. +-- +-- If none of the query bindings found satisfy the filter, a null +-- list is returned (which is what 'rdfQueryFind' returns if the +-- query cannot be satisfied). +-- +-- (Because of lazy evaluation, this should be as efficient as +-- applying the filter as the search proceeds. I started to build +-- the filter logic into the query function itself, with consequent +-- increase in complexity, until I remembered lazy evaluation lets +-- me keep things separate.) +-- +rdfQueryFilter :: + RDFVarBindingFilter -> [RDFVarBinding] -> [RDFVarBinding] +rdfQueryFilter qbf = filter (vbfTest qbf) + +------------------------------------------------------------ +-- Backward-chaining RDF graph queries +------------------------------------------------------------ + +-- |Reverse graph-query function. +-- +-- Similar to 'rdfQueryFind', but with different success criteria. +-- The query graph is matched against the supplied graph, +-- but not every triple of the query is required to be matched. +-- Rather, every triple of the target graph must be matched, +-- and substitutions for just the variables thus bound are +-- returned. In effect, these are subsitutions in the query +-- that entail the target graph (where @rdfQueryFind@ returns +-- substitutions that are entailed by the target graph). +-- +-- Multiple substitutions may be used together, so the result +-- returned is a list of lists of query bindings. Each inner +-- list contains several variable bindings that must all be applied +-- separately to the closure antecendents to obtain a collection of +-- expressions that together are antecedent to the supplied +-- conclusion. A null list of bindings returned means the +-- conclusion can be inferred without any antecedents. +-- +-- Note: in back-chaining, the conditions required to prove each +-- target triple are derived independently, using the inference rule +-- for each such triple, so there are no requirements to check +-- consistency with previously determined variable bindings, as +-- there are when doing forward chaining. A result of this is that +-- there may be redundant triples generated by the back-chaining +-- process. Any process using back-chaining should deal with the +-- results returned accordingly. +-- +-- An empty outer list is returned if no combination of +-- substitutions can infer the supplied target. +-- +rdfQueryBack :: RDFGraph -> RDFGraph -> [[RDFVarBinding]] +rdfQueryBack qg tg = + rdfQueryBack1 matchQueryVariable [] (getArcs qg) (getArcs tg) + +rdfQueryBack1 :: + NodeQuery RDFLabel -> [RDFVarBinding] -> [Arc RDFLabel] -> [Arc RDFLabel] + -> [[RDFVarBinding]] +rdfQueryBack1 _ initv _ [] = [initv] +rdfQueryBack1 nodeq initv qas (ta:tas) = concat + [ rdfQueryBack1 nodeq (nv:initv) qas tas + | nv <- rdfQueryBack2 nodeq qas ta ] + +-- Match a query against a single graph term, and return any new sets of +-- variable bindings thus defined. Each member of the result is an +-- alternative possible set of variable bindings. An empty list returned +-- means no match. +-- +rdfQueryBack2 :: + NodeQuery RDFLabel -> [Arc RDFLabel] -> Arc RDFLabel + -> [RDFVarBinding] +rdfQueryBack2 nodeq qas ta = + [ fromJust b | qa <- qas, let b = getBinding nodeq qa ta, isJust b ] + +-- |RDF back-chaining query filter. This function applies a supplied +-- query binding filter to the result from a call of 'rdfQueryBack'. +-- +-- Each inner list contains bindings that must all be used to satisfy +-- the backchain query, so if any query binding does not satisfy the +-- filter, the entire corresponding row is removed +rdfQueryBackFilter :: + RDFVarBindingFilter -> [[RDFVarBinding]] -> [[RDFVarBinding]] +rdfQueryBackFilter qbf = filter (all (vbfTest qbf)) + +-- |RDF back-chaining query modifier. This function applies a supplied +-- query binding modifier to the result from a call of 'rdfQueryBack'. +-- +-- Each inner list contains bindings that must all be used to satisfy +-- a backchaining query, so if any query binding does not satisfy the +-- filter, the entire corresponding row is removed +-- +rdfQueryBackModify :: + VarBindingModify a b -> [[VarBinding a b]] -> [[VarBinding a b]] +rdfQueryBackModify qbm = concatMap (rdfQueryBackModify1 qbm) + +-- Auxiliary back-chaining query variable binding modifier function: +-- for a supplied list of variable bindings, all of which must be used +-- together when backchaining: +-- (a) make each list member into a singleton list +-- (b) apply the binding modifier to each such list, which may result +-- in a list with zero, one or more elements. +-- (c) return the listProduct of these, each member of which is +-- an alternative list of variable bindings, where the members of +-- each alternative must be used together. +-- +rdfQueryBackModify1 :: + VarBindingModify a b -> [VarBinding a b] -> [[VarBinding a b]] +rdfQueryBackModify1 qbm qbs = listProduct $ map (vbmApply qbm . (:[])) qbs + +------------------------------------------------------------ +-- Simple entailment graph query +------------------------------------------------------------ + +-- |Simple entailment (instance) graph query. +-- +-- This function queries a graph to find instances of the +-- query graph in the target graph. It is very similar +-- to the normal forward chaining query 'rdfQueryFind', +-- except that blank nodes rather than query variable nodes +-- in the query graph are matched against nodes in the target +-- graph. Neither graph should contain query variables. +-- +-- An instance is defined by the RDF semantics specification, +-- per , and is obtained by replacing +-- blank nodes with URIs, literals or other blank nodes. RDF +-- simple entailment can be determined in terms of instances. +-- This function looks for a subgraph of the target graph that +-- is an instance of the query graph, which is a necessary and +-- sufficient condition for RDF entailment (see the Interpolation +-- Lemma in RDF Semantics, section 1.2). +-- +-- It is anticipated that this query function can be used in +-- conjunction with backward chaining to determine when the +-- search for sufficient antecendents to determine some goal +-- has been concluded. +rdfQueryInstance :: RDFGraph -> RDFGraph -> [RDFVarBinding] +rdfQueryInstance = + rdfQueryPrim1 matchQueryBnode nullRDFVarBinding . getArcs + +------------------------------------------------------------ +-- Primitive RDF graph query support functions +------------------------------------------------------------ + +-- |Type of query node testing function. Return value is: +-- +-- * @Nothing@ if no match +-- +-- * @Just True@ if match with new variable binding +-- +-- * @Just False@ if match with new variable binding +-- +type NodeQuery a = a -> a -> Maybe Bool + +-- Extract query binding from matching a single query triple with a +-- target triple, returning: +-- - Nothing if the query is not matched +-- - Just nullVarBinding if there are no new variable bindings +-- - Just binding is a new query binding for this match +getBinding :: + NodeQuery RDFLabel -> Arc RDFLabel -> Arc RDFLabel + -> Maybe RDFVarBinding +getBinding nodeq (Arc s1 p1 o1) (Arc s2 p2 o2) = + makeBinding [(s1,s2),(p1,p2),(o1,o2)] [] + where + makeBinding [] bs = Just $ makeVarBinding bs + makeBinding (vr@(v,r):bvrs) bs = + case nodeq v r of + Nothing -> Nothing + Just False -> makeBinding bvrs bs + Just True -> makeBinding bvrs (vr:bs) + +-- Match variable node against target node, returning +-- Nothing if they do not match, Just True if a variable +-- node is matched (thereby creating a new variable binding) +-- or Just False if a non-blank node is matched. +matchQueryVariable :: NodeQuery RDFLabel +matchQueryVariable (Var _) _ = Just True +matchQueryVariable q t + | q == t = Just False + | otherwise = Nothing + +-- Match blank query node against target node, returning +-- Nothing if they do not match, Just True if a blank node +-- is matched (thereby creating a new equivalence) or +-- Just False if a non-blank node is matched. +matchQueryBnode :: NodeQuery RDFLabel +matchQueryBnode (Blank _) _ = Just True +matchQueryBnode q t + | q == t = Just False + | otherwise = Nothing + +------------------------------------------------------------ +-- Substitute results from RDF query back into a graph +------------------------------------------------------------ + +-- |Graph substitution function. +-- +-- Uses the supplied variable bindings to substitute variables in +-- a supplied graph, returning a list of result graphs corresponding +-- to each set of variable bindings applied to the input graph. +-- This function is used for formward chaining substitutions, and +-- returns only those result graphs for which all query variables +-- are bound. +rdfQuerySubs :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] +rdfQuerySubs vars gr = + map fst $ filter (null . snd) $ rdfQuerySubsAll vars gr + +-- |Graph back-substitution function. +-- +-- Uses the supplied variable bindings from 'rdfQueryBack' to perform +-- a series of variable substitutions in a supplied graph, returning +-- a list of lists of result graphs corresponding to each set of variable +-- bindings applied to the input graphs. +-- +-- The outer list of the result contains alternative antecedent lists +-- that satisfy the query goal. Each inner list contains graphs that +-- must all be inferred to satisfy the query goal. +rdfQueryBackSubs :: + [[RDFVarBinding]] -> RDFGraph -> [[(RDFGraph,[RDFLabel])]] +rdfQueryBackSubs varss gr = [ rdfQuerySubsAll v gr | v <- varss ] + +-- |Graph substitution function. +-- +-- This function performs the substitutions and returns a list of +-- result graphs each paired with a list unbound variables in each. +rdfQuerySubsAll :: [RDFVarBinding] -> RDFGraph -> [(RDFGraph,[RDFLabel])] +rdfQuerySubsAll vars gr = [ rdfQuerySubs2 v gr | v <- vars ] + +-- |Graph substitution function. +-- +-- This function performs each of the substitutions in 'vars', and +-- replaces any nodes corresponding to unbound query variables +-- with new blank nodes. +rdfQuerySubsBlank :: [RDFVarBinding] -> RDFGraph -> [RDFGraph] +rdfQuerySubsBlank vars gr = + [ remapLabels vs bs makeBlank g + | v <- vars + , let (g,vs) = rdfQuerySubs2 v gr + , let bs = allLabels isBlank g + ] + +-- |Graph back-substitution function, replacing variables with bnodes. +-- +-- Uses the supplied variable bindings from 'rdfQueryBack' to perform +-- a series of variable substitutions in a supplied graph, returning +-- a list of lists of result graphs corresponding to each set of variable +-- bindings applied to the input graphs. +-- +-- The outer list of the result contains alternative antecedent lists +-- that satisfy the query goal. Each inner list contains graphs that +-- must all be inferred to satisfy the query goal. +rdfQueryBackSubsBlank :: [[RDFVarBinding]] -> RDFGraph -> [[RDFGraph]] +rdfQueryBackSubsBlank varss gr = [ rdfQuerySubsBlank v gr | v <- varss ] + +-- This function applies a substitution for a single set of variable +-- bindings, returning the result and a list of unbound variables. +-- It uses a state transformer monad to collect the list of +-- unbound variables. +-- +-- Adding an empty graph forces elimination of duplicate arcs. +rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph,[RDFLabel]) +rdfQuerySubs2 varb gr = (add emptyRDFGraph g,vs) + where + (g,vs) = runState ( T.traverse (mapNode varb) gr ) [] + -- (g,vs) = runState ( fmapM (mapNode varb) gr ) [] + +-- Auxiliary monad function for rdfQuerySubs2. +-- This returns a state transformer Monad which in turn returns the +-- substituted node value based on the supplied query variable bindings. +-- The monad state is a list of labels which accumulates all those +-- variables seen for which no substitution was available. +mapNode :: RDFVarBinding -> RDFLabel -> State [RDFLabel] RDFLabel +mapNode varb lab = + case vbMap varb lab of + Just v -> return v + Nothing -> + if isQueryVar lab then + do { modify (addVar lab) + ; return lab + } + else + return lab + +-- Add variable to list of variables, if not already there +addVar :: RDFLabel -> [RDFLabel] -> [RDFLabel] +addVar var vars = if var `elem` vars then vars else var:vars + +------------------------------------------------------------ +-- Simple lightweight query primitives +------------------------------------------------------------ +-- +-- [[[TODO: modify above code to use these for all graph queries]]] + +-- |rdfFindArcs is the main function here: it takes 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: +-- @rdfQuerySimple (rdfSubjEq s)@ +-- +-- * find all statements with given property: +-- @rdfQuerySimple (rdfPredEq p)@ +-- +-- * find all statements with given object: +-- @rdfQuerySimple (rdfObjEq o)@ +-- +-- * find all statements matching conjunction of these conditions: +-- @rdfQuerySimple ('allp' [...])@ +-- +-- * find all statements matching disjunction of these conditions: +-- @rdfQuerySimple ('anyp' [...])@ +-- +-- Custom predicates can also be used. +-- +rdfFindArcs :: (RDFTriple -> Bool) -> RDFGraph -> [RDFTriple] +rdfFindArcs p = filter p . getArcs + +-- |Test if statement has given subject +rdfSubjEq :: RDFLabel -> RDFTriple -> Bool +rdfSubjEq s = (s==) . arcSubj + +-- |Test if statement has given predicate +rdfPredEq :: RDFLabel -> RDFTriple -> Bool +rdfPredEq p = (p==) . arcPred + +-- |Test if statement has given object +rdfObjEq :: RDFLabel -> RDFTriple -> Bool +rdfObjEq o = (o==) . arcObj + +{- +-- |Find statements with given subject +rdfFindSubj :: RDFLabel -> RDFGraph -> [RDFTriple] +rdfFindSubj s = rdfFindArcs (rdfSubjEq s) + +-- |Find statements with given predicate +rdfFindPred :: RDFLabel -> RDFGraph -> [RDFTriple] +rdfFindPred p = rdfFindArcs (rdfPredEq p) +-} + +-- |Find values of given predicate for a given subject +rdfFindPredVal :: RDFLabel -> RDFLabel -> 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 -> RDFLabel -> RDFGraph -> [Integer] +rdfFindPredInt s p = mapMaybe getint . filter isint . pvs + where + pvs = rdfFindPredVal s p + isint = anyp + [ isDatatyped xsd_integer + , isDatatyped xsd_nonneg_integer + ] + getint = mapL2V mapXsdInteger . getLiteralText + +-- |Find all subjects that have a of given value for for a given predicate +rdfFindValSubj :: RDFLabel -> RDFLabel -> 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 some arbitrary value is returned. +-- +rdfFindList :: RDFGraph -> RDFLabel -> [RDFLabel] +rdfFindList gr hd = findhead $ rdfFindList gr findrest + where + findhead = headOr (const []) $ + map (:) (rdfFindPredVal hd res_rdf_first gr) + findrest = headOr res_rdf_nil (rdfFindPredVal hd res_rdf_rest gr) + {- + findhead = headOr (const []) + [ (ob:) | Arc _ sb ob <- subgr, sb == res_rdf_first ] + findrest = headOr res_rdf_nil + [ ob | Arc _ sb ob <- subgr, sb == res_rdf_rest ] + subgr = filter ((==) hd . arcSubj) $ getArcs gr + -} + headOr = foldr const + -- headOr _ (x:_) = x + -- headOr x [] = x + +------------------------------------------------------------ +-- Interactive tests +------------------------------------------------------------ + +{- +s1 = Blank "s1" +p1 = Blank "p1" +o1 = Blank "o1" +s2 = Blank "s2" +p2 = Blank "p2" +o2 = Blank "o2" +qs1 = Var "s1" +qp1 = Var "p1" +qo1 = Var "o1" +qs2 = Var "s2" +qp2 = Var "p2" +qo2 = Var "o2" + +qa1 = Arc qs1 qp1 qo1 +qa2 = Arc qs2 qp2 qo2 +qa3 = Arc qs2 p2 qo2 +ta1 = Arc s1 p1 o1 +ta2 = Arc s2 p2 o2 + +g1 = toRDFGraph [ta1,ta2] +g2 = toRDFGraph [qa3] + +gb1 = getBinding matchQueryVariable qa1 ta1 -- ?s1=_:s1, ?p1=_:p1, ?o1=_:o1 +gvs1 = qbMap (fromJust gb1) qs1 -- _:s1 +gvp1 = qbMap (fromJust gb1) qp1 -- _:p1 +gvo1 = qbMap (fromJust gb1) qo1 -- _:o1 +gvs2 = qbMap (fromJust gb1) qs2 -- Nothing + +gb3 = getBinding matchQueryVariable qa3 ta1 -- Nothing +gb4 = getBinding matchQueryVariable qa3 ta2 -- ?s2=_:s1, ?o2=_:o1 + +mqvs1 = matchQueryVariable qs2 s1 +mqvp1 = matchQueryVariable p2 p1 + +-- rdfQueryFind + +qfa = rdfQueryFind g2 g1 + +qp2a = rdfQueryPrim2 matchQueryVariable qa3 g1 +-} + +{- more tests + +qb1a = rdfQueryBack1 [] [qa1] [ta1,ta2] +qb1 = rdfQueryBack1 [] [qa1,qa2] [ta1,ta2] +ql1 = length qb1 +qv1 = map (qb1!!0!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv2 = map (qb1!!0!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv3 = map (qb1!!1!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv4 = map (qb1!!1!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv5 = map (qb1!!2!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv6 = map (qb1!!2!!1) [qs1,qp1,qo1,qs2,qp2,qo2] +qv7 = map (qb1!!3!!0) [qs1,qp1,qo1,qs2,qp2,qo2] +qv8 = map (qb1!!3!!1) [qs1,qp1,qo1,qs2,qp2,qo2] + +qb2 = rdfQueryBack2 matchQueryVariable [qa1,qa2] ta1 +ql2 = length qb2 +qv1 = map (qbMap $ head qb2) [qs1,qp1,qo1,qs2,qp2,qo2] +qv2 = map (qbMap $ head $ tail qb2) [qs1,qp1,qo1,qs2,qp2,qo2] +qb3 = rdfQueryBack2 matchQueryVariable [qa1,qa3] ta1 + +-} + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFRuleset.hs b/Swish/RDF/RDFRuleset.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFRuleset.hs @@ -0,0 +1,535 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFRuleset +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines some datatypes and functions that are +-- used to define rules and rulesets over RDF graphs +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleMap + , RDFClosure, RDFRuleset, RDFRulesetMap + , nullRDFFormula + , GraphClosure(..), makeGraphClosureRule + , makeRDFGraphFromN3String + , makeRDFFormula + , makeRDFClosureRule + , makeN3ClosureRule + , makeN3ClosureSimpleRule + , makeN3ClosureModifyRule + , makeN3ClosureAllocatorRule + , makeNodeAllocTo + -- for debugging + , graphClosureFwdApply, graphClosureBwdApply + ) +where + +import Swish.RDF.RDFQuery + ( rdfQueryFind + , rdfQueryBack, rdfQueryBackModify + , rdfQuerySubs + , rdfQuerySubsBlank + ) + +import Swish.RDF.RDFGraph + ( RDFLabel(..), RDFGraph + , makeBlank, newNodes + , merge, allLabels + , toRDFGraph, emptyRDFGraph ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding, RDFVarBindingModify ) + +import Swish.RDF.N3Parser + ( parseN3fromString ) + +import Swish.RDF.Ruleset + ( Ruleset(..), RulesetMap + ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..), RuleMap + , fwdCheckInference + , nullScope + ) + +import Swish.RDF.VarBinding + ( makeVarBinding + , applyVarBinding, joinVarBindings + , VarBindingModify(..) + , vbmCompose + , varBindingId + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) ) + +import Swish.RDF.Vocabulary + ( swishName ) + +{- +import Swish.RDF.Proof + ( Proof(..), Step(..) ) +-} + +import Swish.RDF.GraphClass + ( Label(..), Arc(..), LDGraph(..) ) + +import Swish.Utils.ListHelpers + ( equiv, flist ) + +import Data.List (nub) +import Data.Maybe (fromMaybe) + +------------------------------------------------------------ +-- Datatypes for RDF ruleset +------------------------------------------------------------ + +type RDFFormula = Formula RDFGraph + +type RDFRule = Rule RDFGraph + +type RDFRuleMap = RuleMap RDFGraph + +type RDFClosure = GraphClosure RDFLabel + +type RDFRuleset = Ruleset RDFGraph + +type RDFRulesetMap = RulesetMap RDFGraph + +------------------------------------------------------------ +-- Declare null RDF formula +------------------------------------------------------------ + +nullRDFFormula :: Formula RDFGraph +nullRDFFormula = Formula + { formName = ScopedName nullScope "nullRDFGraph" + , formExpr = emptyRDFGraph + } + +------------------------------------------------------------ +-- Datatype for graph closure rule +------------------------------------------------------------ + +-- |Datatype for constructing a graph closure rule +data GraphClosure lb = GraphClosure + { nameGraphRule :: ScopedName -- ^ Name of rule for proof display + , ruleAnt :: [Arc lb] -- ^ Antecedent triples pattern + -- (may include variable nodes) + , ruleCon :: [Arc lb] -- ^ Consequent triples pattern + -- (may include variable nodes) + , ruleModify :: VarBindingModify lb lb + -- ^ Structure that defines additional + -- constraints and/or variable + -- bindings based on other matched + -- query variables. Matching the + -- antecedents. Use 'varBindingId' if + -- no additional variable constraints + -- or bindings are added beyond those + -- arising from graph queries. + } + +instance (Label lb) => Eq (GraphClosure lb) where + c1 == c2 = nameGraphRule c1 == nameGraphRule c2 && + ruleAnt c1 `equiv` ruleAnt c2 && + ruleCon c1 `equiv` ruleCon c2 + +instance (Label lb) => Show (GraphClosure lb) where + show c = "GraphClosure " ++ show (nameGraphRule c) + +------------------------------------------------------------ +-- Define inference rule based on RDF graph closure rule +------------------------------------------------------------ + +-- |Define a value of type Rule based on an RDFClosure value. +makeGraphClosureRule :: GraphClosure RDFLabel -> Rule RDFGraph +makeGraphClosureRule grc = newrule + where + newrule = Rule + { ruleName = nameGraphRule grc + , fwdApply = graphClosureFwdApply grc + , bwdApply = graphClosureBwdApply grc + , checkInference = fwdCheckInference newrule + } + +-- Forward chaining function based on RDF graph closure description +-- +-- Note: antecedents here are presumed to share bnodes. +-- +graphClosureFwdApply :: GraphClosure RDFLabel -> [RDFGraph] -> [RDFGraph] +graphClosureFwdApply grc grs = + let gr = if null grs then emptyRDFGraph else foldl1 add grs + vars = queryFind (ruleAnt grc) gr + varm = vbmApply (ruleModify grc) vars + cons = querySubs varm (ruleCon grc) + in + {- + seq cons $ + seq (trace "\ngraphClosureFwdApply") $ + seq (traceShow "\nvars: " vars) $ + seq (traceShow "\nvarm: " varm) $ + seq (traceShow "\ncons: " cons) $ + seq (trace "\n") $ + -} + -- Return null list or single result graph that is the union + -- (not merge) of individual results: + if null cons then [] else [foldl1 add cons] + -- cons {- don't merge results -} + +-- Backward chaining function based on RDF graph closure description +graphClosureBwdApply :: GraphClosure RDFLabel -> RDFGraph -> [[RDFGraph]] +graphClosureBwdApply grc gr = + let vars = rdfQueryBackModify (ruleModify grc) $ + queryBack (ruleCon grc) gr + -- This next function eliminates duplicate variable bindings. + -- It is strictly redundant, but comparing variable + -- bindings is much cheaper than comparing graphs. + -- I don't know if many duplicate graphs will be result + -- of exact duplicate variable bindings, so this may be + -- not very effective. + varn = map nub vars + in + -- The 'nub ante' below eliminates duplicate antecedent graphs, + -- based on graph matching, which tests for equivalence under + -- bnode renaming, with a view to reducing redundant arcs in + -- the merged antecedent graph, hence less to prove in + -- subsequent back-chaining steps. + -- + -- Each antecedent is reduced to a single RDF graph, when + -- bwdApply specifies a list of expressions corresponding to + -- each antecedent. + [ [foldl1 merge (nub ante)] + | vs <- varn + , let ante = querySubsBlank vs (ruleAnt grc) ] + +------------------------------------------------------------ +-- RDF graph query and substitution support functions +------------------------------------------------------------ + +queryFind :: [Arc RDFLabel] -> RDFGraph -> [RDFVarBinding] +queryFind qas = rdfQueryFind (toRDFGraph qas) + +queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] +queryBack qas = rdfQueryBack (toRDFGraph qas) + +querySubs :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubs vars = rdfQuerySubs vars . toRDFGraph + +querySubsBlank :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubsBlank vars = rdfQuerySubsBlank vars . toRDFGraph + +------------------------------------------------------------ +-- Method for creating an RDF formula value from N3 text +------------------------------------------------------------ + +-- |Helper function to parse a string containing Notation3 +-- and return the corresponding RDFGraph value. +makeRDFGraphFromN3String :: String -> RDFGraph +makeRDFGraphFromN3String str = case parseN3fromString str of + Left msg -> error msg + Right gr -> gr + +-- |Create an RDF formula. +makeRDFFormula :: + Namespace + -> String -- ^ local name + -> String -- ^ graph in Notation 3 format + -> RDFFormula +makeRDFFormula scope local gr = Formula + { formName = ScopedName scope local + , formExpr = makeRDFGraphFromN3String gr + } + +------------------------------------------------------------ +-- Create an RDF closure rule from supplied graphs +------------------------------------------------------------ + +-- |Constructs an RDF graph closure rule. That is, a rule that +-- given some set of antecedent statements returns new statements +-- that may be added to the graph. +-- +makeRDFClosureRule :: + ScopedName -- ^ scoped name for the new rule + -> [RDFGraph] -- ^ RDFGraphs that are the entecedent of the rule. + -- + -- (Note: bnodes and variable names are assumed to be shared + -- by all the entecedent graphs supplied. /is this right?/) + -> RDFGraph -- ^ the consequent graph + -> RDFVarBindingModify -- ^ is a variable binding modifier value that may impose + -- additional conditions on the variable bindings that + -- can be used for this inference rule, or which may + -- cause new values to be allocated for unbound variables. + -- These modifiers allow for certain inference patterns + -- that are not captured by simple "closure rules", such + -- as the allocation of bnodes corresponding to literals, + -- and are an extension point for incorporating datatypes + -- into an inference process. + -- + -- If no additional constraints or variable bindings are + -- to be applied, use value 'varBindingId' + -- + -> RDFRule +makeRDFClosureRule sname antgrs congr vmod = makeGraphClosureRule + GraphClosure + { nameGraphRule = sname + , ruleAnt = concatMap getArcs antgrs + , ruleCon = getArcs congr + , ruleModify = vmod + } + +------------------------------------------------------------ +-- Methods to create an RDF closure rule from N3 input +------------------------------------------------------------ +-- +-- These functions are used internally by Swish to construct +-- rules from textual descriptions. + +-- |Constructs an RDF graph closure rule. That is, a rule that +-- given some set of antecedent statements returns new statements +-- that may be added to the graph. This is the basis for +-- implementation of most of the inference rules given in the +-- RDF formal semantics document. +-- +-- scope is a namespace to which the rule is allocated +-- local is a local name for the rule in the given namespace +-- ant is a string containing +-- con is a string containing +-- +makeN3ClosureRule :: + Namespace -- ^ namespace to which the rule is allocated + -> String -- ^ local name for the rule in the namespace + -> String + -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> String -- ^ 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 value 'varBindingId' + -> RDFRule +makeN3ClosureRule scope local ant con = + makeRDFClosureRule (ScopedName scope local) [antgr] congr + where + antgr = makeRDFGraphFromN3String ant + congr = makeRDFGraphFromN3String con + +-- |Construct a simple RDF graph closure rule without +-- additional node allocations or variable binding constraints. +-- +makeN3ClosureSimpleRule :: + Namespace -> String -> String -> String -> 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 + -> String -- ^ local name for the rule in the given namespace + -> String -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> String -- ^ 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. +-- +-- scope is a +-- local is a +-- ant is a string containing +-- con is a string containing +-- vflt is a +-- aloc is a +-- +makeN3ClosureAllocatorRule :: + Namespace -- ^ namespace to which the rule is allocated + -> String -- ^ local name for the rule in the given namespace + -> String -- ^ the Notation3 representation + -- of the antecedent graph. (Note: multiple antecedents + -- can be handled by combining multiple graphs.) + -> String -- ^ 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 (ScopedName scope local) [antgr] congr modc + where + antgr = makeRDFGraphFromN3String ant + congr = makeRDFGraphFromN3String con + vmod = aloc (allLabels labelIsVar antgr) + modc = fromMaybe varBindingId $ vbmCompose vmod vflt + + +------------------------------------------------------------ +-- Query binding modifier for "allocated to" logic +------------------------------------------------------------ + +-- |This function defines a variable binding mofifier that +-- allocates a new blank node for each value bound to +-- a query variable, and binds it to another variable +-- in each query binding. +-- +-- This provides a single binding for query variables that would +-- otherwise be unbound by a query. For example, consider the +-- inference pattern: +-- +-- > ?a hasUncle ?c => ?a hasFather ?b . ?b hasBrother ?c . +-- +-- For a given @?a@ and @?c@, there is insufficient information +-- here to instantiate a value for variable @?b@. Using this +-- function as part of a graph instance closure rule allows +-- forward chaining to allocate a single bnode for each +-- occurrence of @?a@, so that given: +-- +-- > Jimmy hasUncle Fred . +-- > Jimmy hasUncle Bob . +-- +-- leads to exactly one bnode inference of: +-- +-- > Jimmy hasFather _:f . +-- +-- giving: +-- +-- > Jimmy hasFather _:f . +-- > _:f hasBrother Fred . +-- > _:f hasBrother Bob . +-- +-- rather than: +-- +-- > Jimmy hasFather _:f1 . +-- > _:f1 hasBrother Fred . +-- > Jimmy hasFather _:f2 . +-- > _:f2 hasBrother Bob . +-- +-- This form of constrained allocation of bnodes is also required for +-- some of the inference patterns described by the RDF formal semantics, +-- particularly those where bnodes are substituted for URIs or literals. +-- +makeNodeAllocTo :: + RDFLabel -- ^ variable node to which a new blank node is bound + -> RDFLabel -- ^ variable which is bound in each query to a graph + -- node to which new blank nodes are allocated. + -> [RDFLabel] + -> RDFVarBindingModify +makeNodeAllocTo bindvar alocvar exbnode = VarBindingModify + { vbmName = swishName "makeNodeAllocTo" + , vbmApply = applyNodeAllocTo bindvar alocvar exbnode + , vbmVocab = [alocvar,bindvar] + , vbmUsage = [[bindvar]] + } + +-- Auxiliary function that performs the node allocation defined +-- by makeNodeAllocTo. +-- +-- bindvar is a variable node to which a new blank node is bound +-- alocvar is a variable which is bound in each query to a graph +-- node to which new blank nodes are allocated. +-- exbnode is a list of existing blank nodes, to be avoided by +-- the new blank node allocator. +-- vars is a list of variable bindings to which new bnode +-- allocations for the indicated bindvar are to be added. +-- +applyNodeAllocTo :: + RDFLabel -> RDFLabel -> [RDFLabel] -> [RDFVarBinding] -> [RDFVarBinding] +applyNodeAllocTo bindvar alocvar exbnode vars = + let + app = applyVarBinding + alocnodes = zip (nub $ flist (map app vars) alocvar) + (newNodes (makeBlank bindvar) exbnode) + newvb var = joinVarBindings + ( makeVarBinding $ head + [ [(bindvar,b)] | (v,b) <- alocnodes, app var alocvar == v ] ) + var + in + map newvb vars + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/RDFVarBinding.hs b/Swish/RDF/RDFVarBinding.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/RDFVarBinding.hs @@ -0,0 +1,185 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFVarBinding +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module instantiates the `VarBinding` types and methods for use +-- with RDF graph labels. +-- +-------------------------------------------------------------------------------- + +-- See module RDFQueryTest for test cases. + +module Swish.RDF.RDFVarBinding + ( RDFVarBinding, nullRDFVarBinding + , RDFVarBindingModify, RDFOpenVarBindingModify, RDFOpenVarBindingModifyMap + , RDFVarBindingFilter + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) +where + +import Swish.RDF.RDFGraph + ( RDFLabel(..) + , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral + , isDatatyped, isMemberProp, isUri, isBlank + ) + +import Swish.RDF.VarBinding + ( VarBinding(..), nullVarBinding + , applyVarBinding + , VarBindingModify(..), OpenVarBindingModify + , VarBindingFilter(..) + , makeVarTestFilter + ) + +import Swish.RDF.Vocabulary + ( swishName ) + +import Swish.Utils.LookupMap + ( LookupMap(..) ) + +------------------------------------------------------------ +-- Types for RDF query variable bindings and modifiers +------------------------------------------------------------ + +-- |@RDFVarBinding@ is the specific type type of a variable +-- binding value used with RDF graph queries. +type RDFVarBinding = VarBinding RDFLabel RDFLabel + +-- | maps no query variables. +nullRDFVarBinding :: RDFVarBinding +nullRDFVarBinding = nullVarBinding + +-- |Define type of query binding modifier for RDF graph inference +type RDFVarBindingModify = VarBindingModify RDFLabel RDFLabel + +-- |Open variable binding modifier that operates on RDFLabel values +-- +type RDFOpenVarBindingModify = OpenVarBindingModify RDFLabel RDFLabel + +-- |Define type for lookup map of open query binding modifiers +type RDFOpenVarBindingModifyMap = LookupMap RDFOpenVarBindingModify + +-- |@RDFVarBindingFilter@ is a function type that tests to see if +-- a query binding satisfies some criterion, and is used to +-- create a variable binding modifier that simply filers +-- given variable bindings. +-- +-- Queries often want to apply some kind of filter or condition +-- to the variable bindings that are processed. In inference rules, +-- it sometimes seems desirable to stipulate additional conditions on +-- the things that are matched. +-- +-- This function type is used to perform such tests. +-- A number of simple implementations are included. +-- +type RDFVarBindingFilter = VarBindingFilter RDFLabel RDFLabel + +------------------------------------------------------------ +-- Declare some query binding filters +------------------------------------------------------------ + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a URI reference. +rdfVarBindingUriRef :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingUriRef = + makeVarTestFilter (swishName "rdfVarBindingUriRef") isUri + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a blank node. +rdfVarBindingBlank :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingBlank = + makeVarTestFilter (swishName "rdfVarBindingBlank") isBlank + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a literal value. +rdfVarBindingLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingLiteral = + makeVarTestFilter (swishName "rdfVarBindingLiteral") isLiteral + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to an untyped literal value. +rdfVarBindingUntypedLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingUntypedLiteral = + makeVarTestFilter (swishName "rdfVarBindingUntypedLiteral") isUntypedLiteral + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a typed literal value. +rdfVarBindingTypedLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingTypedLiteral = + makeVarTestFilter (swishName "rdfVarBindingTypedLiteral") isTypedLiteral + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to an XML literal value. +rdfVarBindingXMLLiteral :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingXMLLiteral = + makeVarTestFilter (swishName "rdfVarBindingXMLLiteral") isXMLLiteral + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to container membership property. +rdfVarBindingMemberProp :: RDFLabel -> RDFVarBindingFilter +rdfVarBindingMemberProp = + makeVarTestFilter (swishName "rdfVarBindingMemberProp") isMemberProp + +-- |This function generates a query binding filter that ensures +-- an indicated variable is bound to a literal value with a +-- datatype whose URI is bound to another node +-- +rdfVarBindingDatatyped :: + RDFLabel -- ^ variable bound to the required datatype. + -> RDFLabel -- ^ variable bound to the literal node to be tested. + -> RDFVarBindingFilter +rdfVarBindingDatatyped dvar lvar = VarBindingFilter + { vbfName = swishName "rdfVarBindingDatatyped" + , vbfVocab = [dvar,lvar] + , vbfTest = \vb -> testDatatyped vb dvar lvar + } + +testDatatyped :: RDFVarBinding -> RDFLabel -> RDFLabel -> Bool +testDatatyped vb dvar lvar = and + [ isUri dtype + , isDatatyped dqnam $ applyVarBinding vb lvar + ] + where + dtype = applyVarBinding vb dvar + -- NOTE: dqnam is not evaluated unless (isUri dtype) + -- but add in a _ handler to appease -Wall + -- dqnam = case dtype of { (Res x) -> x } + dqnam = case dtype of + Res x -> x + _ -> error $ "dqnam should not be evaluated with " ++ show dtype + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/Rule.hs b/Swish/RDF/Rule.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/Rule.hs @@ -0,0 +1,214 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Rule +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses +-- +-- This module defines a framework for defining inference rules +-- over some expression form. It is intended to be used with +-- RDF graphs, but the structures aim to be quite generic with +-- respect to the expression forms allowed. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Rule + ( Expression(..), Formula(..), Rule(..), RuleMap + , nullScope, nullFormula, nullRule + , fwdCheckInference, bwdCheckInference + , showsFormula, showsFormulae, showsWidth + ) +where + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + ) + +import Swish.Utils.ShowM + ( ShowM(..) ) + +------------------------------------------------------------ +-- Expressions +------------------------------------------------------------ + +-- |Expression is a type class for values over which proofs +-- may be constructed. +class (Eq ex) => Expression ex where + -- |Is expression true in all interpretations? + -- If so, then its truth is assumed without justification. + isValid :: ex -> Bool + +------------------------------------------------------------ +-- Formula: a named expression +------------------------------------------------------------ + +-- |A Formula is a named expression. +data Formula ex = Formula + { formName :: ScopedName -- ^ Name used for formula in proof chain + , formExpr :: ex -- ^ Named formula value + } deriving Show + +-- |Define equality of formulae as equality of formula names +instance Eq (Formula ex) where + f1 == f2 = formName f1 == formName f2 + +-- |Define ordering of formulae based on formula names +instance Ord (Formula ex) where + f1 <= f2 = formName f1 <= formName f2 + +instance LookupEntryClass (Formula ex) ScopedName (Formula ex) + where + newEntry (_,form) = form + keyVal form = (formName form, form) + +-- | The namespace @http://id.ninebynine.org/2003/Ruleset/null@ +nullScope :: Namespace +nullScope = Namespace "null" "http://id.ninebynine.org/2003/Ruleset/null" + +nullFormula :: Formula ex +nullFormula = Formula + { formName = ScopedName 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 :: (ShowM ex) => String -> [Formula ex] -> String -> ShowS +showsFormulae _ [] _ = id +showsFormulae newline [f] after = showsFormula newline f . + showString after +showsFormulae newline (f:fs) after = showsFormula newline f . + showString newline . + showsFormulae newline fs after + +-- |Create a displayable form of a labelled formula +showsFormula :: (ShowM ex) => String -> Formula ex -> ShowS +showsFormula newline f = + showsWidth 16 ("["++show (formName f)++"] ") . + showms (newline ++ replicate 16 ' ') (formExpr f) + +------------------------------------------------------------ +-- Rule +------------------------------------------------------------ + +-- |Rule is a data type for inference rules that can be used +-- to construct a step in a proof. +data Rule ex = Rule + { + -- |Name of rule, for use when displaying a proof + ruleName :: ScopedName, + + -- |Forward application of a rule, takes a list of + -- expressions and returns a list (possibly empty) + -- of forward applications of the rule to combinations + -- of the antecedent expressions. + -- Note that all of the results returned can be assumed to + -- be (simultaneously) true, given the antecedents provided. + fwdApply :: [ex] -> [ex], + + -- |Backward application of a rule, takes an expression + -- and returns a list of alternative antecedents, each of + -- which is a list of expressions that jointly yield the + -- given consequence through application of the inference + -- rule. An empty list is returned if no antecedents + -- will allow the consequence to be inferred. + bwdApply :: ex -> [[ex]], + + -- |Inference check. Takes a list of antecedent expressions + -- and a consequent expression, returning True if the + -- consequence can be obtained from the antecedents by + -- application of the rule. When the antecedents and + -- consequent are both given, this is generally more efficient + -- that using either forward or backward chaining. + -- Also, a particular rule may not fully support either + -- forward or backward chaining, but all rules are required + -- to fully support this function. + -- + -- A default implementation based on forward chaining is + -- given below. + checkInference :: [ex] -> ex -> Bool + } + +-- |Define equality of rules as equality of rule names +instance Eq (Rule ex) where + r1 == r2 = ruleName r1 == ruleName r2 + +-- |Define ordering of rules based on rule names +instance Ord (Rule ex) where + r1 <= r2 = ruleName r1 <= ruleName r2 + +instance Show (Rule ex) where + show rl = "Rule "++show (ruleName rl) + +instance LookupEntryClass (Rule ex) ScopedName (Rule ex) + where + newEntry (_,rule) = rule + keyVal rule = (ruleName rule, rule) + +type RuleMap ex = LookupMap (Rule ex) + +fwdCheckInference :: (Eq ex) => Rule ex -> [ex] -> ex -> Bool +fwdCheckInference rule ante cons = + cons `elem` fwdApply rule ante + +bwdCheckInference :: (Eq ex) => Rule ex -> [ex] -> ex -> Bool +bwdCheckInference rule ante cons = any checkAnts (bwdApply rule cons) + where + checkAnts = all (`elem` ante) + +nullRule :: Rule ex +nullRule = Rule + { ruleName = ScopedName nullScope "nullRule" + , fwdApply = \ _ -> [] + , bwdApply = \ _ -> [] + , checkInference = \ _ _ -> False + } + +------------------------------------------------------------ +-- Shows formatting support functions +----------------------------------------------------------- + +-- |Show a string left justified in a field of at least the specified +-- number of characters width. +showsWidth :: Int -> String -> ShowS +showsWidth wid str more = str++replicate pad ' '++more + where + pad = wid - length str + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/Ruleset.hs b/Swish/RDF/Ruleset.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/Ruleset.hs @@ -0,0 +1,136 @@ +{-# LANGUAGE MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Ruleset +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses +-- +-- This module defines a ruleset data type, used to collect information +-- about a ruleset that may contribute torwards inferences in RDF; +-- e.g. RDF and RDFS are rulesets. +-- +-- A ruleset consists of a namespace, a collection of axioms and +-- a collection of rules. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Ruleset + ( Ruleset(..), RulesetMap + , makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules + , getRulesetAxiom, getRulesetRule + , getContextAxiom, getMaybeContextAxiom + , getContextRule, getMaybeContextRule + ) +where + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..) ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , mapFindMaybe + ) + +import Data.Maybe + ( fromMaybe, listToMaybe, mapMaybe ) + +-- | Ruleset, having namespace, axioms and rules + +data Ruleset ex = Ruleset + { rsNamespace :: Namespace + , rsAxioms :: [Formula ex] + , rsRules :: [Rule ex] + } + +instance Eq (Ruleset ex) where + r1 == r2 = rsNamespace r1 == rsNamespace r2 + +instance LookupEntryClass (Ruleset ex) Namespace (Ruleset ex) + where + keyVal r@(Ruleset k _ _) = (k,r) + newEntry (_,r) = r + +type RulesetMap ex = LookupMap (Ruleset ex) + +makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex +makeRuleset nsp fms rls = Ruleset + { rsNamespace = nsp + , rsAxioms = fms + , rsRules = rls + } + +getRulesetNamespace :: Ruleset ex -> Namespace +getRulesetNamespace = rsNamespace + +getRulesetAxioms :: Ruleset ex -> [Formula ex] +getRulesetAxioms = rsAxioms + +getRulesetRules :: Ruleset ex -> [Rule ex] +getRulesetRules = rsRules + +-- | Find a named axiom or rule in a ruleset or proof context + +getRulesetAxiom :: ScopedName -> Ruleset ex -> Maybe (Formula ex) +getRulesetAxiom nam rset = + mapFindMaybe nam (LookupMap (getRulesetAxioms rset)) + -- listToMaybe $ filter ( (matchName nam) . formName ) $ getRulesetAxioms rset + +getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) +getRulesetRule nam rset = + mapFindMaybe nam (LookupMap (getRulesetRules rset)) + -- listToMaybe $ filter ( (matchName nam) . ruleName ) $ getRulesetRules rset + +getContextAxiom :: ScopedName -> Formula ex -> [Ruleset ex] -> Formula ex +getContextAxiom nam def rsets = fromMaybe def (getMaybeContextAxiom nam rsets) + {- + foldr (flip fromMaybe) def $ map (getRulesetAxiom nam) rsets + -} + +getMaybeContextAxiom :: ScopedName -> [Ruleset ex] -> Maybe (Formula ex) +getMaybeContextAxiom nam rsets = + listToMaybe $ mapMaybe (getRulesetAxiom nam) rsets + +getContextRule :: ScopedName -> Rule ex -> [Ruleset ex] -> Rule ex +getContextRule nam def rsets = fromMaybe def (getMaybeContextRule nam rsets) + {- + foldr (flip fromMaybe) def $ map (getRulesetRule nam) rsets + -} + +getMaybeContextRule :: ScopedName -> [Ruleset ex] -> Maybe (Rule ex) +getMaybeContextRule nam rsets = + listToMaybe $ mapMaybe (getRulesetRule nam) rsets + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/SwishCommands.hs b/Swish/RDF/SwishCommands.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/SwishCommands.hs @@ -0,0 +1,421 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : SwishCommands +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- SwishCommands: functions to deal with indivudual Swish command options. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.SwishCommands + ( swishFormat + , swishBase + -- , swishVerbose + , swishInput + , swishOutput + , swishMerge + , swishCompare + , swishGraphDiff + , swishScript + ) +where + +import Swish.RDF.SwishMonad + ( SwishStateIO, SwishState(..), SwishStatus(..) + , setFormat, setBase, setGraph + , resetInfo, resetError, setStatus + -- , setVerbose + , SwishFormat(..) + , swishError + , reportLine + ) + +import Swish.RDF.SwishScript + ( parseScriptFromString + ) + +import Swish.RDF.GraphPartition + ( GraphPartition(..) + , partitionGraph, comparePartitions + , partitionShowP + ) + +import Swish.RDF.RDFGraph + ( RDFGraph, merge ) + +import qualified Swish.RDF.N3Formatter as N3F +import qualified Swish.RDF.NTFormatter as NTF + +import Swish.RDF.N3Parser (parseN3) -- (parseN3fromString) +import Swish.RDF.NTParser (parseNT) + +import Swish.RDF.GraphClass + ( LDGraph(..) + , Label(..) + ) + +import Swish.Utils.QName (QName, qnameFromURI, qnameFromFilePath, getQNameURI) + +import System.IO + ( Handle, openFile, IOMode(..) + , hPutStr, hPutStrLn, hClose, hGetContents + , hIsReadable, hIsWritable + , stdin, stdout + ) + +import Network.URI (URI, + relativeTo, + parseURI, parseURIReference, uriToString) + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (modify, gets) +import Control.Monad (liftM, when) + +import System.IO.Error + +------------------------------------------------------------ +-- Set file format to supplied value +------------------------------------------------------------ + +-- the second argument allows for options to be passed along +-- with the format (a la cwm) but this is not supported yet +-- +swishFormat :: SwishFormat -> Maybe String -> SwishStateIO () +swishFormat fmt _ = modify (setFormat fmt) + +------------------------------------------------------------ +-- Set base URI to supplied value +------------------------------------------------------------ + +-- the Maybe String argument is ignored (a result of a lack of +-- design with the command-line processing) +-- +swishBase :: Maybe QName -> Maybe String -> SwishStateIO () +swishBase mb _ = modify (setBase mb) + +------------------------------------------------------------ +-- Read graph from named file +------------------------------------------------------------ + +swishInput :: Maybe String -> SwishStateIO () +swishInput fnam = + swishReadGraph fnam >>= maybe (return ()) (modify . setGraph) + +------------------------------------------------------------ +-- Merge graph from named file +------------------------------------------------------------ + +swishMerge :: Maybe String -> SwishStateIO () +swishMerge fnam = + swishReadGraph fnam >>= maybe (return ()) (modify . mergeGraph) + +mergeGraph :: RDFGraph -> SwishState -> SwishState +mergeGraph gr state = state { graph = newgr } + where + newgr = merge gr (graph state) + +------------------------------------------------------------ +-- Compare graph from named file +------------------------------------------------------------ + +swishCompare :: Maybe String -> SwishStateIO () +swishCompare fnam = + swishReadGraph fnam >>= maybe (return ()) compareGraph + +compareGraph :: RDFGraph -> SwishStateIO () +compareGraph gr = do + oldGr <- gets graph + let exitCode = if gr == oldGr then SwishSuccess else SwishGraphCompareError + modify $ setStatus exitCode + +------------------------------------------------------------ +-- Display graph differences from named file +------------------------------------------------------------ + +swishGraphDiff :: Maybe String -> SwishStateIO () +swishGraphDiff fnam = + swishReadGraph fnam >>= maybe (return ()) diffGraph + +diffGraph :: RDFGraph -> SwishStateIO () +diffGraph gr = do + oldGr <- gets graph + let p1 = partitionGraph (getArcs oldGr) + p2 = partitionGraph (getArcs gr) + diffs = comparePartitions p1 p2 + maybehandleclose <- swishWriteFile Nothing + case maybehandleclose of + Just (h,c) -> do + swishOutputDiffs "" h diffs + when c (lift $ hClose h) + + _ -> return () + +swishOutputDiffs :: (Label lb) => + String -> Handle + -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))] + -> SwishStateIO () +swishOutputDiffs fnam hnd diffs = do + lift $ hPutStrLn hnd ("Graph differences: "++show (length diffs)) + mapM_ (swishOutputDiff fnam hnd) (zip [1..] diffs) + +swishOutputDiff :: (Label lb) => + 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) => + String -> Handle -> Maybe (GraphPartition lb) -> SwishStateIO () +swishOutputPart _ hnd part = + let out = maybe "\n(No arcs)" (partitionShowP "\n") part + in lift $ hPutStrLn hnd out + +------------------------------------------------------------ +-- Execute script from named file +------------------------------------------------------------ + +swishScript :: Maybe String -> SwishStateIO () +swishScript fnam = swishReadScript fnam >>= mapM_ swishCheckResult + +swishReadScript :: Maybe String -> SwishStateIO [SwishStateIO ()] +swishReadScript fnam = + let hdlr (h,i) = do + res <- swishParseScript fnam i + lift $ hClose h + return res + + in swishOpenFile fnam >>= maybe (return []) hdlr + +{-| +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 = qnameFromURI "http://id.ninebynine.org/2003/Swish/" + +calculateBaseURI :: + Maybe FilePath -- ^ file name + -> SwishStateIO QName -- ^ base URI + +calculateBaseURI Nothing = maybe defURI id `liftM` gets base + +calculateBaseURI (Just fnam) = do + mbase <- gets base + case mbase of + Just buri -> case appendUris (getQNameURI buri) fnam of + Left emsg -> fail emsg -- TODO: think about this ... + Right res -> return $ qnameFromURI $ showURI res + Nothing -> lift $ qnameFromFilePath fnam + +-- this is also in N3Parser +showURI :: URI -> String +showURI u = uriToString id u "" + +-- this is also in N3Parser +appendUris :: String -> String -> Either String URI +appendUris buri uri = + case parseURI uri of + Just absuri -> Right absuri + _ -> case parseURIReference uri of + Just reluri -> case parseURI buri of + Just baseuri -> case relativeTo reluri baseuri of + Just resuri -> Right resuri + _ -> Left $ "Unable to append <" ++ uri ++ "> to base=<" ++ buri ++ ">" + + _ -> Left $ "Invalid base URI: <" ++ buri ++ ">" + _ -> Left $ "Invalid URI: <" ++ uri ++ ">" + +swishParseScript :: + Maybe String -- file name (or "stdin" if Nothing) + -> String -- script contents + -> SwishStateIO [SwishStateIO ()] +swishParseScript mfpath inp = do + buri <- calculateBaseURI mfpath + case parseScriptFromString (Just buri) inp of + Left err -> do + let inName = maybe "standard input" ("file " ++) mfpath + swishError ("Script syntax error in " ++ inName ++ ": "++err) SwishDataInputError + return [] + + Right scs -> return scs + +swishCheckResult :: SwishStateIO () -> SwishStateIO () +swishCheckResult swishcommand = do + swishcommand + er <- gets errormsg + case er of + Just x -> swishError x SwishExecutionError >> modify resetError + _ -> return () + + ms <- gets infomsg + case ms of + Just x -> reportLine x >> modify resetInfo + _ -> return () + +------------------------------------------------------------ +-- Output graph to named file +------------------------------------------------------------ + +swishOutput :: Maybe String -> SwishStateIO () +swishOutput fnam = + let hdlr (h,c) = swishOutputGraph fnam h >> when c (lift $ hClose h) + in swishWriteFile fnam >>= maybe (return ()) hdlr + +swishOutputGraph :: Maybe String -> Handle -> SwishStateIO () +swishOutputGraph _ hnd = do + fmt <- gets format + + let writeOut formatter = do + out <- gets $ formatter . graph + lift $ hPutStrLn hnd (out "") + + case fmt of + N3 -> writeOut N3F.formatGraphAsShowS + NT -> writeOut NTF.formatGraphAsShowS + -- _ -> 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 fnam = + let reader (h,i) = do + res <- swishParse fnam i + lift $ hClose h + return res + + in swishOpenFile fnam >>= maybe (return Nothing) reader + +-- Open and read file, returning its handle and content, or Nothing +-- WARNING: the handle must not be closed until input is fully evaluated +-- +swishOpenFile :: Maybe String -> SwishStateIO (Maybe (Handle,String)) +swishOpenFile Nothing = readFromHandle stdin "standard input." +swishOpenFile (Just fnam) = do + o <- lift $ try $ openFile fnam ReadMode + case o of + Left _ -> do + swishError ("Cannot open file: "++fnam) SwishDataAccessError + return Nothing + + Right hnd -> readFromHandle hnd ("file: " ++ fnam) + +readFromHandle :: Handle -> String -> SwishStateIO (Maybe (Handle, String)) +readFromHandle hdl lbl = do + hrd <- lift $ hIsReadable hdl + if hrd + then do + fc <- lift $ hGetContents hdl + return $ Just (hdl,fc) + + else do + -- closing stdin should not be an issue here? + lift $ hClose hdl + swishError ("Cannot read from " ++ lbl) SwishDataAccessError + return Nothing + +swishParse :: + Maybe String -- ^ filename (if not stdin) + -> String -- ^ 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 + N3 -> readIn (flip parseN3 (Just buri)) + NT -> readIn parseNT + {- + _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError >> + return Nothing + -} + +-- 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). +swishWriteFile :: Maybe String -> SwishStateIO (Maybe (Handle,Bool)) +swishWriteFile Nothing = do + hwt <- lift $ hIsWritable stdout + if hwt + then return $ Just (stdout, False) + else do + swishError ("Cannot write to standard output") SwishDataAccessError + return Nothing + +swishWriteFile (Just fnam) = do + o <- lift $ try $ openFile fnam WriteMode + case o of + Left _ -> do + swishError ("Cannot open file for writing: " ++ fnam) SwishDataAccessError + return Nothing + + Right hnd -> do + hwt <- lift $ hIsWritable hnd + if hwt + then return $ Just (hnd, True) + else do + lift $ hClose hnd + swishError ("Cannot write to file: "++fnam) SwishDataAccessError + return Nothing + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/SwishMain.hs b/Swish/RDF/SwishMain.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/SwishMain.hs @@ -0,0 +1,285 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : SwishMain +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- 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. +-- I anticipate that this module may be used as a starting point for +-- creating new programs rathar 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). As such, it is part of +-- another experiment along the lines described in [3]. +-- +-- (1) Semantic web: +-- +-- (2) CWM: +-- +-- (3) Motivation: +-- +-- (4) Notation 3: +-- +-- (5) RDF: +-- +-------------------------------------------------------------------------------- + +-- TODO: +-- +-- * Add RDF/XML input and output +-- +-- * Add Turtle and related formats for input and output +-- + +module Swish.RDF.SwishMain ( + SwishStatus(..), SwishAction, + runSwish, + runSwishActions, + displaySwishHelp, + splitArguments, + validateCommands + ) where + +import Swish.RDF.SwishCommands + ( swishFormat + , swishBase + , swishInput + , swishOutput + , swishMerge + , swishCompare + , swishGraphDiff + , swishScript + ) + +import Swish.RDF.SwishMonad + ( SwishStateIO, SwishState(..), SwishStatus(..) + , emptyState + , SwishFormat(..) + ) + +import Swish.Utils.QName (qnameFromURI) +import Swish.Utils.ListHelpers (breakAll) + +import Control.Monad.State (execStateT) +import Control.Monad (liftM) + +import Network.URI (parseURI) + +import Data.Char (isSpace) +import Data.Either (partitionEithers) + +import System.Exit (ExitCode(ExitSuccess, ExitFailure)) + +------------------------------------------------------------ +-- Command line description +------------------------------------------------------------ + +-- we do not display the version in the help file to avoid having +-- to include the Paths_swish module (so that we can use this from +-- an interactive environment). +-- + +usageText :: [String] +usageText = + [ "Swish: Read, merge, write, compare and process RDF graphs." + , "" + , "Usage: swish option option ..." + , "" + , "where the options are processed from left to right, and may be" + , "any of the following:" + , "-h display this message." + , "-? display this message." + , "-v display Swish version and quit." + , "-q do not display Swish version on start up." + , "-nt use Ntriples format for subsequent input and output." + , "-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 an Swish action, with an optional argument and +-- the Swish routine to act on that argument. +-- +-- At present this type is a black box to external modules. +newtype SwishAction = SA (Maybe String, Maybe String -> SwishStateIO ()) + +-- | 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 (marg, f) + in case nam of + "-nt" -> wrap $ swishFormat NT + "-n3" -> wrap $ swishFormat N3 + "-i" -> wrap swishInput + "-m" -> wrap swishMerge + "-c" -> wrap swishCompare + "-d" -> wrap swishGraphDiff + "-o" -> wrap swishOutput + "-b" -> validateBase 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 (marg,act)) = act marg + +validateBase :: Maybe String -> Either (String, SwishStatus) SwishAction +validateBase Nothing = Right $ SA (Nothing, swishBase Nothing) +validateBase (Just b) = + case parseURI b of + Just _ -> Right $ SA (Nothing, swishBase (Just (qnameFromURI b))) + _ -> Left ("Invalid base URI <" ++ b ++ ">", SwishArgumentError) + +------------------------------------------------------------ +-- Interactive test function (e.g. for use in Hugs) +------------------------------------------------------------ + +-- this ignores the "flags" options, namely +-- -q / -h / -? / -v + +-- | Parse and run the given string as if given at the command +-- line. The \"quiet\", \"version\" and \"help\" options are +-- ignored. +-- +runSwish :: String -> IO ExitCode +runSwish cmdline = do + let args = breakAll isSpace cmdline + (_, cmds) = splitArguments args + + case validateCommands cmds of + Left (emsg, ecode) -> do + putStrLn $ "Swish exit: " ++ emsg + return $ ExitFailure $ fromEnum ecode + + Right acts -> do + ec <- runSwishActions acts + case ec of + SwishSuccess -> return ExitSuccess + _ -> do + putStrLn $ "Swish exit: " ++ show ec + return $ ExitFailure $ fromEnum ec + +-- | Execute the given set of actions. +runSwishActions :: [SwishAction] -> IO SwishStatus +runSwishActions acts = exitcode `liftM` execStateT (swishCommands acts) emptyState + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/SwishMonad.hs b/Swish/RDF/SwishMonad.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/SwishMonad.hs @@ -0,0 +1,268 @@ +{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : SwishMonad +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, MultiParamTypeClasses +-- +-- Composed state and IO monad for Swish +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.SwishMonad + ( SwishStateIO, SwishState(..), SwishStatus(..) + , setFormat, setBase, setGraph + , modGraphs, findGraph, findFormula + , modRules, findRule + , modRulesets, findRuleset + , findOpenVarModify, findDatatype + , setInfo, resetInfo, setError, resetError + , setStatus + -- , setVerbose + , emptyState + , SwishFormat(..) + , NamedGraph(..), NamedGraphMap + , swishError + , reportLines, reportLine + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, emptyRDFGraph ) + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleMap, RDFRuleset, RDFRulesetMap ) + +import Swish.RDF.RDFDatatype + ( RDFDatatype ) + +import Swish.RDF.RDFVarBinding + ( RDFOpenVarBindingModify + ) + +import Swish.RDF.BuiltInMap + ( findRDFOpenVarBindingModifier + , findRDFDatatype + , rdfRulesetMap + ) + +import Swish.RDF.Ruleset + ( getMaybeContextAxiom + , getMaybeContextRule + ) + +import Swish.RDF.Rule + ( Formula(..) + ) + +import Swish.Utils.Namespace (ScopedName(..)) +import Swish.Utils.QName (QName) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , emptyLookupMap + , mapFindMaybe + , mapVals + ) + +import Control.Monad.Trans (MonadTrans(..)) +import Control.Monad.State (StateT(..), modify) + +import System.IO (hPutStrLn, stderr) + +{-| +The supported input and output formats. +-} +data SwishFormat = + N3 -- ^ N3 format + | NT -- ^ NTriples format + deriving Eq + +instance Show SwishFormat where + show N3 = "N3" + show NT = "Ntriples" + -- show RDF = "RDF/XML" + +-- | The State for a Swish \"program\". + +data SwishState = SwishState + { format :: SwishFormat -- ^ format to use for I/O + , base :: Maybe QName -- ^ base to use rather than file name + , graph :: RDFGraph -- ^ current graph + , graphs :: NamedGraphMap -- ^ script processor named graphs + , rules :: RDFRuleMap -- ^ script processor named rules + , rulesets :: RDFRulesetMap -- ^ script processor rulesets + , infomsg :: Maybe String -- ^ information message, or Nothing + , errormsg :: Maybe String -- ^ error message, or Nothing + , exitcode :: SwishStatus -- ^ current status message + } + +-- | Status of the processor +-- +data SwishStatus = + SwishSuccess -- ^ successful run + | SwishGraphCompareError -- ^ graphs do not compare + | SwishDataInputError -- ^ input data problem (ie format/syntax) + | SwishDataAccessError -- ^ data access error + | SwishArgumentError -- ^ command-line argument error + | SwishExecutionError -- ^ error executing a Swish script + deriving (Eq, Enum) + +instance Show SwishStatus where + show SwishSuccess = "Success." + show SwishGraphCompareError = "The graphs do not compare as equal." + show SwishDataInputError = "There was a format or syntax error in the input data." + show SwishDataAccessError = "There was a problem accessing data." + show SwishArgumentError = "Argument error: use -h or -? for help." + show SwishExecutionError = "There was a problem executing a Swish script." + +type SwishStateIO a = StateT SwishState IO a + +emptyState :: SwishState +emptyState = SwishState + { format = N3 + , base = Nothing + , graph = emptyRDFGraph + , graphs = emptyLookupMap + , rules = emptyLookupMap + , rulesets = rdfRulesetMap + , infomsg = Nothing + , errormsg = Nothing + , exitcode = SwishSuccess + } + +setFormat :: SwishFormat -> SwishState -> SwishState +setFormat fm state = state { format = fm } + +setBase :: Maybe QName -> SwishState -> SwishState +setBase bs state = state { base = bs } + +setGraph :: RDFGraph -> SwishState -> SwishState +setGraph gr state = state { graph = gr } + +modGraphs :: + ( NamedGraphMap -> NamedGraphMap ) -> SwishState -> SwishState +modGraphs grmod state = state { graphs = grmod (graphs state) } + +findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph] +findGraph nam state = mapFindMaybe nam (graphs state) + +findFormula :: ScopedName -> SwishState -> Maybe RDFFormula +findFormula nam state = case findGraph nam state of + Nothing -> getMaybeContextAxiom nam (mapVals $ rulesets state) + Just [] -> Just $ Formula nam emptyRDFGraph + Just grs -> Just $ Formula nam (head grs) + +modRules :: + ( RDFRuleMap -> RDFRuleMap ) -> SwishState -> SwishState +modRules rlmod state = state { rules = rlmod (rules state) } + +findRule :: ScopedName -> SwishState -> Maybe RDFRule +findRule nam state = + let + localrule = mapFindMaybe nam (rules state) + contextrule = getMaybeContextRule nam $ mapVals $ rulesets state + in + case localrule of + Nothing -> contextrule + justlr -> justlr + +modRulesets :: + ( RDFRulesetMap -> RDFRulesetMap ) -> SwishState -> SwishState +modRulesets rsmod state = state { rulesets = rsmod (rulesets state) } + +findRuleset :: + ScopedName -> SwishState -> Maybe RDFRuleset +findRuleset nam state = mapFindMaybe (snScope nam) (rulesets state) + +findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify +findOpenVarModify nam _ = findRDFOpenVarBindingModifier nam + +findDatatype :: ScopedName -> SwishState -> Maybe RDFDatatype +findDatatype nam _ = findRDFDatatype nam + +setInfo :: String -> SwishState -> SwishState +setInfo msg state = state { infomsg = Just msg } + +resetInfo :: SwishState -> SwishState +resetInfo state = state { infomsg = Nothing } + +setError :: String -> SwishState -> SwishState +setError msg state = state { errormsg = Just msg } + +resetError :: SwishState -> SwishState +resetError state = state { errormsg = Nothing } + +setStatus :: SwishStatus -> SwishState -> SwishState +setStatus ec state = state { exitcode = ec } + +{- +setVerbose :: Bool -> SwishState -> SwishState +setVerbose f state = state { banner = f } +-} + +-- | The graphs dictionary contains named graphs and/or lists +-- of graphs that are created and used by script statements. + +data NamedGraph = NamedGraph + { ngName :: ScopedName + , ngGraph :: [RDFGraph] + } + +instance LookupEntryClass NamedGraph ScopedName [RDFGraph] + where + keyVal (NamedGraph k v) = (k,v) + newEntry (k,v) = NamedGraph k v + +type NamedGraphMap = LookupMap NamedGraph + +-- | Report error and set exit status code + +swishError :: String -> SwishStatus -> SwishStateIO () +swishError msg sts = do + reportLines [msg, show sts ++ "\n"] + -- when (sts == 4) $ reportLine "Use 'Swish -h' or 'Swish -?' for help\n" + modify $ setStatus sts + +-- | Output text to the standard error stream +-- +-- Each string in the supplied list is a line of text to +-- be displayed. + +reportLines :: [String] -> SwishStateIO () +reportLines = mapM_ reportLine + +reportLine :: String -> SwishStateIO () +reportLine line = + -- lift putStrLn line + lift $ hPutStrLn stderr line + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/SwishScript.hs b/Swish/RDF/SwishScript.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/SwishScript.hs @@ -0,0 +1,961 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : SwishScript +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- 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. +-- +-- The script syntax is based loosely on Notation3, and the script parser is an +-- extension of the Notation3 parser in the module "Swish.RDF.N3Parser". +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.SwishScript + ( parseScriptFromString ) +where + +import Swish.RDF.SwishMonad + ( SwishStateIO, SwishStatus(..) + , modGraphs, findGraph, findFormula + , modRules, findRule + , modRulesets, findRuleset + , findOpenVarModify, findDatatype + , setInfo, setError, setStatus + , NamedGraph(..) + ) + +import Swish.RDF.RDFDatatype + ( RDFDatatype ) + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule + , RDFRuleset + , makeRDFClosureRule + ) + +import Swish.RDF.RDFProof + ( RDFProofStep, makeRDFProof, makeRDFProofStep ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBindingModify + ) + +import Swish.RDF.RDFGraphShowM() + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , emptyRDFGraph + , NamespaceMap + , setNamespaces + , merge, add + ) + +import Swish.RDF.N3Parser + ( parseAnyfromString + , parseN3 + , N3Parser, N3State(..) + , whiteSpace, symbol, eof, identLetter + , getPrefix + , subgraph + , n3symbol -- was uriRef2, + , quickVariable -- was varid + , lexUriRef + , newBlankNode + ) + +import Swish.RDF.N3Formatter + ( formatGraphAsShowS ) + +import Swish.RDF.Datatype + ( typeMkRules ) + +import Swish.RDF.Proof + ( explainProof, showsProof ) + +import Swish.RDF.Ruleset + ( makeRuleset, getRulesetRule, getMaybeContextRule ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..) -- , RuleMap + ) + +import Swish.RDF.VarBinding + ( composeSequence ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +import Swish.Utils.QName (QName, qnameFromURI) + +import Swish.Utils.LookupMap + ( mapReplaceOrAdd ) + +import Swish.Utils.ListHelpers + ( equiv, flist ) + +import Text.ParserCombinators.Parsec + ( (), (<|>) + , many, manyTill, option, sepBy, between, try, notFollowedBy + , string, char, anyChar + , getState + ) + +import Control.Monad.State + ( modify, gets, lift + -- , StateT(..), execStateT + ) + +import Control.Monad (unless, when, liftM) + +import qualified System.IO.Error as IO + +------------------------------------------------------------ +-- Parser for Swish script processor +------------------------------------------------------------ +-- +-- The parser is based on the Notation3 parser, and uses many +-- of the same syntax productions, but the top-level productions used +-- are quite different. +-- +-- NOTE: during the parser re-write we strip out some of this functionality +-- +parseScriptFromString :: Maybe QName -> String -> Either String [SwishStateIO ()] +parseScriptFromString = parseAnyfromString script + +---------------------------------------------------------------------- +-- Syntax productions +---------------------------------------------------------------------- + +script :: N3Parser [SwishStateIO ()] +script = do + whiteSpace + scs <- many command + eof + return scs + +isymbol :: String -> N3Parser () +isymbol s = symbol s >> return () + +command :: N3Parser (SwishStateIO ()) +command = + do { try $ isymbol "@prefix" + ; getPrefix + ; return $ return () + } + <|> nameItem + <|> readGraph + <|> writeGraph + <|> mergeGraphs + <|> compareGraphs + <|> assertEquiv + <|> assertMember + <|> defineRule + <|> defineRuleset + <|> defineConstraints + <|> checkProofCmd + <|> fwdChain + <|> bwdChain + + "script command" + +nameItem :: N3Parser (SwishStateIO ()) +nameItem = + -- name :- graph + -- name :- ( graph* ) + do { u <- n3symbol + ; isymbol ":-" + ; g <- graphOrList + ; return $ ssAddGraph u g + } + +readGraph :: N3Parser (SwishStateIO ()) +readGraph = + -- @read name [ ] + do { commandName "@read" + ; n <- n3symbol + ; u <- option "" lexUriRef + ; return $ ssRead n (if null u then Nothing else Just u) + } + +writeGraph :: N3Parser (SwishStateIO ()) +writeGraph = + -- @write name [ ] ; Comment + do { commandName "@write" + ; n <- n3symbol + ; let gs = ssGetList n :: SwishStateIO (Either String [RDFGraph]) + ; u <- option "" lexUriRef + ; isymbol ";" + ; c <- restOfLine + ; let muri = if null u then Nothing else Just u + ; return $ ssWriteList muri gs c + } + +mergeGraphs :: N3Parser (SwishStateIO ()) +mergeGraphs = + -- @merge ( name* ) => name + do { commandName "@merge" + ; gs <- graphList + ; isymbol "=>" + ; n <- n3symbol + ; return $ ssMerge n gs + } + +compareGraphs :: N3Parser (SwishStateIO ()) +compareGraphs = + -- @compare name name + do { commandName "@compare" + ; n1 <- n3symbol + ; n2 <- n3symbol + ; return $ ssCompare n1 n2 + } + +assertEquiv :: N3Parser (SwishStateIO ()) +assertEquiv = + -- @asserteq name name ; Comment + do { commandName "@asserteq" + ; n1 <- n3symbol + ; n2 <- n3symbol + ; isymbol ";" + ; c <- restOfLine + ; return $ ssAssertEq n1 n2 c + } + +assertMember :: N3Parser (SwishStateIO ()) +assertMember = + -- @assertin name name ; Comment + do { commandName "@assertin" + ; n1 <- n3symbol + ; n2 <- n3symbol + ; isymbol ";" + ; c <- restOfLine + ; return $ ssAssertIn n1 n2 c + } + +defineRule :: N3Parser (SwishStateIO ()) +defineRule = + -- @rule name :- ( name* ) => name [ | ( (name var*)* ) ] + do { commandName "@rule" + ; rn <- n3symbol + ; isymbol ":-" + ; ags <- graphOrList + ; isymbol "=>" + ; cg <- graphExpr + ; vms <- option [] varModifiers + ; return $ ssDefineRule rn ags cg vms + } + +defineRuleset :: N3Parser (SwishStateIO ()) +defineRuleset = + -- @ruleset name :- ( name* ) ; ( name* ) + do { commandName "@ruleset" + ; sn <- n3symbol + ; isymbol ":-" + ; ags <- nameList + ; isymbol ";" + ; rns <- nameList + ; return $ ssDefineRuleset sn ags rns + } + +defineConstraints :: N3Parser (SwishStateIO ()) +defineConstraints = + -- @constraints pref :- ( name* ) | ( name* ) + do { commandName "@constraints" + ; sn <- n3symbol + ; isymbol ":-" + ; cgs <- graphOrList + ; isymbol "|" + ; cns <- nameOrList + ; return $ ssDefineConstraints sn cgs cns + } + +checkProofCmd :: N3Parser (SwishStateIO ()) +checkProofCmd = + -- @proof name ( name* ) + -- @input name + -- @step name ( name* ) => name # rule-name, antecedents, consequent + -- @result name + do { commandName "@proof" + ; pn <- n3symbol + ; sns <- nameList + ; commandName "@input" + ; igf <- formulaExpr + ; sts <- many checkStep + ; commandName "@result" + ; rgf <- formulaExpr + ; return $ ssCheckProof pn sns igf sts rgf + } + +checkStep :: + N3Parser (Either String [RDFRuleset] + -> SwishStateIO (Either String RDFProofStep)) +checkStep = + do { commandName "@step" + ; rn <- n3symbol + ; agfs <- formulaList + ; isymbol "=>" + ; cgf <- formulaExpr + ; return $ ssCheckStep rn agfs cgf + } + +fwdChain :: N3Parser (SwishStateIO ()) +fwdChain = + -- # ruleset rule (antecedents) => result + -- @fwdchain pref name ( name* ) => name + do { commandName "@fwdchain" + ; sn <- n3symbol + ; rn <- n3symbol + ; ags <- graphOrList + ; isymbol "=>" + ; cn <- n3symbol + ; s <- getState :: N3Parser N3State + ; let prefs = prefixUris s :: NamespaceMap + ; return $ ssFwdChain sn rn ags cn prefs + } + +bwdChain :: N3Parser (SwishStateIO ()) +bwdChain = + -- # ruleset rule consequent <= (antecedent-alts) + -- @bwdchain pref name graph <= name + do { commandName "@bwdchain" + ; sn <- n3symbol + ; rn <- n3symbol + ; cg <- graphExpr + ; isymbol "<=" + ; an <- n3symbol + ; s <- getState :: N3Parser N3State + ; let prefs = prefixUris s :: NamespaceMap + ; return $ ssBwdChain sn rn cg an prefs + } + +---------------------------------------------------------------------- +-- Syntax clause helpers +---------------------------------------------------------------------- + +commandName :: String -> N3Parser () +commandName cmd = try $ + do { _ <- string cmd + ; notFollowedBy identLetter + ; whiteSpace + } + +restOfLine :: N3Parser String +restOfLine = + do { s <- manyTill anyChar (char '\n') + ; whiteSpace + ; return s + } + +nameList :: N3Parser [ScopedName] +nameList = + do { isymbol "(" + ; ns <- many n3symbol + ; isymbol ")" + ; return ns + } + +nameOrList :: N3Parser [ScopedName] +nameOrList = + do { n <- n3symbol + ; return [n] + } + <|> + nameList + + "Name, or list of names" + +graphExpr :: N3Parser (SwishStateIO (Either String RDFGraph)) +graphExpr = + graphOnly + <|> + do { f <- formulaExpr + ; return $ liftM (liftM formExpr) f + } + + "Graph expression, graph name or named graph definition" + +graphOnly :: N3Parser (SwishStateIO (Either String RDFGraph)) +graphOnly = + do { isymbol "{" + ; b <- newBlankNode + ; g <- subgraph b :: N3Parser RDFGraph + ; isymbol "}" + ; s <- getState + ; let gp = setNamespaces (prefixUris s) g + ; return $ return (Right gp) + } + +graphList :: N3Parser [SwishStateIO (Either String RDFGraph)] +graphList = between (symbol "(") (symbol ")") (many graphExpr) + + "List of graphs" + +graphOrList :: N3Parser [SwishStateIO (Either String RDFGraph)] +graphOrList = + do { g <- graphExpr + ; return [g] + } + <|> + graphList + + "Graph, or list of graphs" + +formulaExpr :: N3Parser (SwishStateIO (Either String RDFFormula)) +formulaExpr = + do { n <- n3symbol + ; namedGraph n + } + "Formula (name or named graph)" + +namedGraph :: ScopedName -> N3Parser (SwishStateIO (Either String RDFFormula)) +namedGraph n = + do { isymbol ":-" + ; g <- graphOnly + ; return $ ssAddReturnFormula n g + } + <|> + return (ssGetFormula n) + +formulaList :: N3Parser [SwishStateIO (Either String RDFFormula)] +formulaList = between (symbol "(") (symbol ")") (many formulaExpr) + + "List of formulae (names or named graphs)" + +varModifiers :: N3Parser [(ScopedName,[RDFLabel])] +varModifiers = + do { isymbol "|" + ; varModList + } + +varModList :: N3Parser [(ScopedName,[RDFLabel])] +varModList = + do { isymbol "(" + ; vms <- sepBy varMod (symbol ",") + ; isymbol ")" + ; return vms + } + <|> + do { vm <- varMod + ; return [vm] + } + +varMod :: N3Parser (ScopedName,[RDFLabel]) +varMod = + do { rn <- n3symbol + ; vns <- many quickVariable + ; return (rn,vns) + } + +---------------------------------------------------------------------- +-- SwishState helper functions +---------------------------------------------------------------------- +-- +-- The functions below operate in the SwishStateIO monad, and are used +-- to assemble an executable version of the parsed script. + +ssAddReturnFormula :: + ScopedName -> SwishStateIO (Either String RDFGraph) + -> SwishStateIO (Either String RDFFormula) +ssAddReturnFormula nam gf = + do { egr <- gf + ; ssAddGraph nam [return egr] + ; return $ liftM (Formula nam) egr + } + +ssAddGraph :: + ScopedName -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO () +ssAddGraph nam gf = + let errmsg = "Graph/list not added: "++show nam++"; " + in + do { esg <- sequence gf -- [Either String RDFGraph] + ; let egs = sequence esg -- Either String [RDFGraph] + ; let fgs = case egs of + Left er -> setError (errmsg++er) + Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam gs)) + ; modify fgs + } + +ssGetGraph :: ScopedName -> SwishStateIO (Either String RDFGraph) +ssGetGraph nam = + do { grs <- ssGetList nam + ; return $ liftM head grs + } + +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 String -> SwishStateIO () +ssRead nam muri = ssAddGraph nam [ssReadGraph muri] + +ssReadGraph :: Maybe String -> SwishStateIO (Either String RDFGraph) +ssReadGraph muri = + let gf inp = case inp of + Left es -> Left es + Right is -> parseN3 is (fmap qnameFromURI muri) + + in gf `liftM` getResourceData muri + +ssWriteList :: + Maybe String -> 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 [gr] -> ssWriteGraph muri gr comment + Right grs -> sequence_ writegrs where + writegrs = if null grs + then [putResourceData Nothing ("+ Swish: Writing empty list"++)] + else map writegr (zip [(0::Int)..] grs) + writegr (n,gr) = ssWriteGraph (murin muri n) gr + ("["++show n++"] "++comment) + murin Nothing _ = Nothing + murin (Just uri) n = Just (inituri++show n++lasturi) + where + splituri1 = splitBy (=='/') uri + splituri2 = splitBy (=='.') (lastseg splituri1) + inituri = concat (initseg splituri1 ++ initseg splituri2) + lasturi = lastseg splituri2 + } + +splitBy :: (a->Bool) -> [a] -> [[a]] +splitBy _ [] = [] +splitBy p (s0:str) = let (s1,sr) = break p str in + (s0:s1):splitBy p sr + +lastseg :: [[a]] -> [a] +lastseg [] = [] +lastseg [_] = [] +lastseg ass = last ass + +initseg :: [[a]] -> [[a]] +initseg [] = [] +initseg [as] = [as] +initseg ass = init ass + +{- +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 String -> RDFGraph -> String -> SwishStateIO () +ssWriteGraph muri gr comment = + putResourceData muri ((c++) . formatGraphAsShowS gr) + where + c = "# "++comment++"\n" + +ssMerge :: + ScopedName -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO () +ssMerge nam gfs = + let errmsg = "Graph merge not defined: "++show nam++"; " + in + do { esg <- sequence gfs -- [Either String RDFGraph] + ; let egs = sequence esg -- Either String [RDFGraph] + ; let fgs = case egs of + Left er -> setError (errmsg++er) + Right [] -> setError (errmsg++"No graphs to merge") + Right gs -> modGraphs (mapReplaceOrAdd (NamedGraph nam [g])) + where g = foldl1 merge gs + ; modify fgs + } + +ssCompare :: ScopedName -> ScopedName -> SwishStateIO () +ssCompare n1 n2 = + do { 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 { g1 <- ssGetList n1 + ; g2 <- ssGetList n2 + ; case (g1,g2) of + (Left er,_) -> modify $ setError (comment++er1++"\n "++er) + (_,Left er) -> modify $ setError (comment++er1++"\n "++er) + (Right gr1,Right gr2) -> + unless (equiv gr1 gr2) $ modify $ + setError (comment++":\n Graph "++show n1 + ++" differs from "++show n2++".") + } + +ssAssertIn :: ScopedName -> ScopedName -> String -> SwishStateIO () +ssAssertIn n1 n2 comment = + let er1 = ":\n Membership test not performed: invalid graph." + er2 = ":\n Membership test not performed: invalid list." + in + do { g1 <- ssGetGraph n1 + ; g2 <- ssGetList n2 + ; case (g1,g2) of + (Left er,_) -> modify $ setError (comment++er1++"\n "++er) + (_,Left er) -> modify $ setError (comment++er2++"\n "++er) + (Right gr,Right gs) -> + unless (gr `elem` gs) $ modify $ + setError (comment++":\n Graph "++show n1 + ++" not a member of "++show n2) + } + +-- Note: this is probably incomplete, though it should work in simple cases. +-- A complete solution would have the binding modifiers subject to +-- re-arrangement to suit the actual bound variables encountered. +-- See VarBinding.findCompositions and VarBinding.findComposition +-- +-- This code should be adequate if variable bindings are always used +-- in combinations consisting of a single modifier followed by any number +-- of filters. +-- +ssDefineRule :: + ScopedName + -> [SwishStateIO (Either String RDFGraph)] + -> SwishStateIO (Either String RDFGraph) + -> [(ScopedName,[RDFLabel])] + -> SwishStateIO () +ssDefineRule rn agfs cgf vmds = + let errmsg1 = "Rule definition error in antecedent graph(s): " + errmsg2 = "Rule definition error in consequent graph: " + errmsg3 = "Rule definition error in variable modifier(s): " + errmsg4 = "Incompatible variable binding modifier sequence" + in + do { aesg <- sequence agfs -- [Either String RDFGraph] + ; let ags = sequence aesg :: Either String [RDFGraph] + ; cg <- cgf -- Either String RDFGraph + ; let vmfs = map ssFindVarModify vmds + ; evms <- sequence vmfs -- [Either String RDFVarBindingModify] + ; let vms = sequence evms :: Either String [RDFVarBindingModify] + ; let frl = case (ags,cg,vms) of + (Left er,_,_) -> setError (errmsg1++er) + (_,Left er,_) -> setError (errmsg2++er) + (_,_,Left er) -> setError (errmsg3++er) + (Right agrs,Right cgr,Right vbms) -> + let + newRule = makeRDFClosureRule rn agrs cgr + in + case composeSequence vbms of + Just vm -> modRules (mapReplaceOrAdd (newRule vm)) + Nothing -> setError errmsg4 + ; modify frl + } + +ssFindVarModify :: + (ScopedName,[RDFLabel]) -> SwishStateIO (Either String RDFVarBindingModify) +ssFindVarModify (nam,lbs) = gets $ \st -> + case findOpenVarModify nam st of + Just ovbm -> Right (ovbm lbs) + Nothing -> Left ("Undefined modifier: "++show nam) + +ssDefineRuleset :: + ScopedName + -> [ScopedName] + -> [ScopedName] + -> SwishStateIO () +ssDefineRuleset sn ans rns = + let errmsg1 = "Error in ruleset axiom(s): " + errmsg2 = "Error in ruleset rule(s): " + in + do { let agfs = mapM ssGetFormula ans + :: SwishStateIO [Either String RDFFormula] + ; aesg <- agfs -- [Either String RDFFormula] + ; let eags = sequence aesg :: Either String [RDFFormula] + ; let erlf = mapM ssFindRule rns + :: SwishStateIO [Either String RDFRule] + ; rles <- erlf -- [Either String RDFRule] + ; let erls = sequence rles :: Either String [RDFRule] + ; let frs = case (eags,erls) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right ags,Right rls) -> + modRulesets (mapReplaceOrAdd rs) + where + rs = makeRuleset (snScope sn) ags rls + ; modify frs + } + +ssFindRule :: ScopedName -> SwishStateIO (Either String RDFRule) +ssFindRule nam = gets find + where + find st = case findRule nam st of + Nothing -> Left ("Rule not found: "++show nam) + Just rl -> Right rl + +ssDefineConstraints :: + ScopedName + -> [SwishStateIO (Either String RDFGraph)] + -> [ScopedName] + -> SwishStateIO () +ssDefineConstraints sn cgfs dtns = + let errmsg1 = "Error in constraint graph(s): " + errmsg2 = "Error in datatype(s): " + in + do { cges <- sequence cgfs -- [Either String RDFGraph] + ; let ecgs = sequence cges :: Either String [RDFGraph] + ; let ecgr = case ecgs of + Left er -> Left er + Right [] -> Right emptyRDFGraph + Right grs -> Right $ foldl1 merge grs + ; edtf <- mapM ssFindDatatype dtns + -- [Either String RDFDatatype] + ; let edts = sequence edtf :: Either String [RDFDatatype] + ; let frs = case (ecgr,edts) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right cgr,Right dts) -> + modRulesets (mapReplaceOrAdd rs) + where + rs = makeRuleset (snScope 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 $ + (("Proof "++show pn++"\n")++) + . showsProof "\n" pr + ; let checkproof = case proof of + (Left er) -> setError er + (Right pr) -> + case explainProof pr of + Nothing -> setInfo (infmsg1++show pn) + Just ex -> setError (errmsg5++show pn++", "++ex) + {- + if not $ checkProof pr then + setError (errmsg5++show pn) + else + setInfo (infmsg1++show pn) + -} + ; modify checkproof + } + +ssCheckStep :: + ScopedName -- rule name + -> [SwishStateIO (Either String RDFFormula)] -- antecedent graph formulae + -> SwishStateIO (Either String RDFFormula) -- consequent graph formula + -> Either String [RDFRuleset] -- rulesets + -> SwishStateIO (Either String RDFProofStep) -- resulting proof step +ssCheckStep _ _ _ (Left er) = return $ Left er +ssCheckStep rn eagf ecgf (Right rss) = + let + errmsg1 = "Rule not in proof step ruleset(s): " + errmsg2 = "Error in proof step antecedent graph(s): " + errmsg3 = "Error in proof step consequent graph: " + in + do { let mrul = getMaybeContextRule rn rss :: Maybe RDFRule + ; esag <- sequence eagf -- [Either String RDFFormula]] + ; let eags = sequence esag :: Either String [RDFFormula] + ; ecg <- ecgf -- Either String RDFFormula + ; let est = case (mrul,eags,ecg) of + (Nothing,_,_) -> Left (errmsg1++show rn) + (_,Left er,_) -> Left (errmsg2++er) + (_,_,Left er) -> Left (errmsg3++er) + (Just rul,Right ags,Right cg) -> + Right $ makeRDFProofStep rul ags cg + ; return est + } + +ssFwdChain :: + ScopedName -- ruleset name + -> ScopedName -- rule name + -> [SwishStateIO (Either String RDFGraph)] -- antecedent graphs + -> ScopedName -- consequent graph name + -> NamespaceMap -- prefixes for new graph + -> SwishStateIO () +ssFwdChain sn rn agfs cn prefs = + let + errmsg1 = "FwdChain rule error: " + errmsg2 = "FwdChain antecedent error: " + in + do { erl <- ssFindRulesetRule sn rn + ; aesg <- sequence agfs -- [Either String RDFGraph] + ; let eags = sequence aesg :: Either String [RDFGraph] + ; let fcr = case (erl,eags) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right rl,Right ags) -> + modGraphs (mapReplaceOrAdd (NamedGraph cn [cg])) + where + cg = case fwdApply rl ags of + [] -> emptyRDFGraph + grs -> setNamespaces prefs $ foldl1 add grs + ; modify fcr + } + +ssFindRulesetRule :: + ScopedName -> ScopedName -> SwishStateIO (Either String RDFRule) +ssFindRulesetRule sn rn = gets find + where + find st = case findRuleset sn st of + Nothing -> Left ("Ruleset not found: "++show sn) + Just rs -> find1 rs + find1 rs = case getRulesetRule rn rs of + Nothing -> Left ("Rule not in ruleset: "++show sn++": "++show rn) + Just rl -> Right rl + +ssFindRuleset :: + ScopedName -> SwishStateIO (Either String RDFRuleset) +ssFindRuleset sn = gets find + where + find st = case findRuleset sn st of + Nothing -> Left ("Ruleset not found: "++show sn) + Just rs -> Right rs + +ssBwdChain :: + ScopedName -- ruleset name + -> ScopedName -- rule name + -> SwishStateIO (Either String RDFGraph) -- consequent graphs + -> ScopedName -- antecedent alts name + -> NamespaceMap -- prefixes for new graphs + -> SwishStateIO () +ssBwdChain sn rn cgf an prefs = + let + errmsg1 = "BwdChain rule error: " + errmsg2 = "BwdChain goal error: " + in + do { erl <- ssFindRulesetRule sn rn + ; ecg <- cgf -- Either String RDFGraph + ; let fcr = case (erl,ecg) of + (Left er,_) -> setError (errmsg1++er) + (_,Left er) -> setError (errmsg2++er) + (Right rl,Right cg) -> + modGraphs (mapReplaceOrAdd (NamedGraph an ags)) + where + ags = map mergegr (bwdApply rl cg) + mergegr grs = case grs of + [] -> emptyRDFGraph + _ -> setNamespaces prefs $ foldl1 add grs + ; modify fcr + } + +-- Temporary implementation: just read local file WNH +-- (Add logic to separate filenames from URIs, and +-- attempt HTTP GET, or similar.) +getResourceData :: Maybe String -> SwishStateIO (Either String String) +getResourceData muri = + case muri of + Nothing -> fromStdin + Just uri -> fromUri uri + where + fromStdin = + do { dat <- lift getContents + ; return $ Right dat + } + fromUri = fromFile + fromFile uri = + do { dat <- lift $ readFile uri + ; return $ Right dat + } + +-- Temporary implementation: just write local file +-- (Need to add logic to separate filenames from URIs, and +-- attempt HTTP PUT, or similar.) +putResourceData :: Maybe String -> ShowS -> SwishStateIO () +putResourceData muri gsh = + do { ios <- lift $ IO.try $ + case muri of + Nothing -> toStdout + Just uri -> toUri uri + ; case ios of + Left ioe -> modify $ setError + ("Error writing graph: "++ + IO.ioeGetErrorString ioe) + Right a -> return a + } + where + toStdout = putStrLn gstr + toUri uri = writeFile uri gstr + gstr = gsh "" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/VarBinding.hs b/Swish/RDF/VarBinding.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/VarBinding.hs @@ -0,0 +1,541 @@ +{-# LANGUAGE MultiParamTypeClasses, TypeSynonymInstances #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : VarBinding +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : MultiParamTypeClasses, TypeSynonymInstances +-- +-- This module defines functions for representing and manipulating query +-- binding variable sets. This is the key data that mediates between +-- query and back substitution when performing inferences. A framework +-- of query variable modifiers is provided that can be used to +-- implement richer inferences, such as filtering of query results, +-- or replacing values based on known relationships. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.VarBinding + ( VarBinding(..), nullVarBinding + , boundVars, subBinding, makeVarBinding + , applyVarBinding, joinVarBindings, addVarBinding + , VarBindingModify(..), OpenVarBindingModify + , vbmCompatibility, vbmCompose + , composeSequence, findCompositions, findComposition + , VarBindingFilter(..) + , makeVarFilterModify + , makeVarTestFilter, makeVarCompareFilter + , varBindingId, nullVarBindingModify + , varFilterDisjunction, varFilterConjunction + , varFilterEQ, varFilterNE + ) +where + +import Swish.Utils.LookupMap + ( LookupEntryClass(..) + , makeLookupMap, mapFindMaybe + ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +import Swish.RDF.Vocabulary + ( swishName ) + +import Swish.Utils.ListHelpers + ( equiv, subset, flist, headOrNothing, permutations ) + +import Data.Maybe + ( mapMaybe, fromMaybe, isJust, fromJust, listToMaybe ) + +import Data.List + ( find, intersect, union, (\\) ) + + +------------------------------------------------------------ +-- 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 :: [(a,b)] + , vbNull :: Bool + } + +-- |VarBinding is an instance of class Eq, so that variable +-- bindings can be compared for equivalence +-- +instance (Eq a, Eq b) => Eq (VarBinding a b) where + vb1 == vb2 = vbEnum vb1 `equiv` vbEnum vb2 + +-- |VarBinding is an instance of class Show, so that variable +-- bindings can be displayed +-- +instance (Show a, Show b) => Show (VarBinding a b) where + show = show . vbEnum + +-- | maps no query variables. +-- +nullVarBinding :: VarBinding a b +nullVarBinding = VarBinding + { vbMap = const Nothing + , vbEnum = [] + , vbNull = True + } + +-- |Return a list of the variables bound by a supplied variable binding +-- +boundVars :: VarBinding a b -> [a] +boundVars = map fst . vbEnum + +-- |VarBinding subset function, tests to see if one query binding +-- is a subset of another; i.e. every query variable mapping defined +-- by one is also defined by the other. +-- +subBinding :: (Eq a, Eq b) => VarBinding a b -> VarBinding a b -> Bool +subBinding vb1 vb2 = vbEnum vb1 `subset` vbEnum vb2 + +-- |Function to make a variable binding from a list of +-- pairs of variable and corresponding assigned value. +-- +makeVarBinding :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> VarBinding a b +makeVarBinding vrbs = + if null vrbs then nullVarBinding -- (nullVarBinding :: VarBinding a b) + else VarBinding + { vbMap = selectFrom vrbs + , vbEnum = vrbs + , vbNull = null vrbs + } + where + selectFrom = flip mapFindMaybe . makeLookupMap + -- selectFrom bs is the VarBinding lookup function + {- + selectFrom :: (Eq a) => [(a,b)] -> a -> Maybe b + selectFrom [] _ = Nothing + selectFrom ((v,r):bs) l = if l == v then Just r + else selectFrom bs l + -} + +-- |Apply query binding to a supplied value, returning the value +-- unchanged if no binding is defined +-- +applyVarBinding :: VarBinding a a -> a -> a +applyVarBinding vbind v = fromMaybe v (vbMap vbind v) + +-- |Join a pair of query bindings, returning a new binding that +-- maps all variables recognized by either of the input bindings. +-- If the bindings should overlap, such overlap is not detected and +-- the value from the first binding provided is used arbitrarily. +-- +joinVarBindings :: (Eq a) => VarBinding a b -> VarBinding a b -> VarBinding a b +joinVarBindings vb1 vb2 + | vbNull vb1 = vb2 + | vbNull vb2 = vb1 + | otherwise = VarBinding + { vbMap = mv12 + , vbEnum = map (\v -> (v,fromJust (mv12 v))) bv12 + , vbNull = False + } + where + -- flist fs a = map ($ a) fs; see also monad function 'ap' + mv12 = headOrNothing . filter isJust . flist [ vbMap vb1, vbMap vb2 ] + bv12 = boundVars vb1 `union` boundVars vb2 + +-- |Add a single new value to a variable binding and return the resulting +-- new variable binding. +-- +addVarBinding :: (Eq a, Show a, Eq b, Show b) => a -> b -> VarBinding a b + -> VarBinding a b +addVarBinding lb val vbind = joinVarBindings vbind $ makeVarBinding [(lb,val)] + +------------------------------------------------------------ +-- Datatypes for variable binding modifiers +------------------------------------------------------------ + +-- |Define the type of a function to modify variable bindings in +-- forward chaining based on rule antecedent matches. This +-- function is used to implement the \"allocated to\" logic described +-- in Appendix B of the RDF semantics document, in which a specific +-- blank node is associated with all matches of some specific value +-- by applications of the rule on a given graph. +-- Use 'id' if no modification of the variable bindings is required. +-- +-- This datatype consists of the modifier function itself, which +-- operates on a list of variable bindings rather than a single +-- variable binding (because some modifications share context across +-- a set of bindings), and some additional descriptive information +-- that allows possible usage patterns to be analyzed. +-- +-- Some usage patterns (see 'vbmUsage' for more details): +-- +-- [filter] all variables are input variables, and the effect +-- of the modifier function is to drop variable bindings that +-- don't satisfy some criterion. +-- Identifiable by an empty element in @vbmUsage@. +-- +-- [source] all variables are output variables: a raw query +-- could be viewed as a source of variable bindings. +-- Identifiable by an element of @vbmUsage@ equal to @vbmVocab@. +-- +-- [modifier] for each supplied variable binding, one or more +-- new variable bindings may be created that contain the +-- input variables bound as supplied plus some additional variables. +-- Identifiable by an element of @vbmUsage@ some subset of @vbmVocab@. +-- +-- A variety of variable usage patterns may be supported by a given +-- modifier: a modifier may be used to define new variable bindings +-- from existing bindings in a number of ways, or simply to check that +-- some required relationship between bindings is satisfied. +-- (Example, for @a + b = c@, any one variable can be deduced from the +-- other two, or all three may be supplied to check that the relationship +-- does indeed hold.) +-- +data VarBindingModify a b = VarBindingModify + { vbmName :: ScopedName + -- ^Name used to identify this variable binding + -- modifier when building inference rules. + , vbmApply :: [VarBinding a b] -> [VarBinding a b] + -- ^Apply variable binding modifier to a + -- list of variable bindings, returning a + -- new list. The result list is not + -- necessarily the same length as the + -- supplied list. + , vbmVocab :: [a] -- ^List of variables used by this modifier. + -- All results of applying this modifier contain + -- bindings for these variables. + , vbmUsage :: [[a]] -- ^List of binding modifier usage patterns + -- supported. Each pattern is characterized as + -- a list of variables for which new bindings + -- may be created by some application of this + -- modifier, assuming that bindings for all other + -- variables in @vbmVocab@ are supplied. + } + +-- |Allow a VarBindingModify value to be accessed using a 'LookupMap'. +-- +instance LookupEntryClass + (VarBindingModify a b) ScopedName (VarBindingModify a b) + where + keyVal vbm = (vbmName vbm,vbm) + newEntry (_,vbm) = vbm + +-- |Type for variable binding modifier that has yet to be instantiated +-- with respect to the variables that it operates upon. +-- +type OpenVarBindingModify lb vn = [lb] -> VarBindingModify lb vn + +-- |Extract variable binding name from @OpenVarBindingModify@ value +-- +-- (Because only the name is required, the application to an undefined +-- list of variable labels should never be evaluated, as long as the +-- name is not dependent on the variable names in any way.) +-- +-- NOT QUITE... some of the functions that create @OpenVarBindingModify@ +-- instances also pattern-match the number of labels provided, forcing +-- evaluation of the labels parameter, even though it's not used. +-- +openVbmName :: OpenVarBindingModify lb vn -> ScopedName +openVbmName ovbm = vbmName (ovbm (error "Undefined labels in variable binding")) + +-- |Allow an @OpenVarBindingModify@ value to be accessed using a @LookupMap@. +-- +instance LookupEntryClass + (OpenVarBindingModify a b) ScopedName (OpenVarBindingModify a b) + where + keyVal ovbm = (openVbmName ovbm,ovbm) + newEntry (_,ovbm) = ovbm + +-- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. +-- +instance Show (OpenVarBindingModify a b) + where + show = show . openVbmName + +-- |Variable binding modifier compatibility test. +-- +-- Given a list of bound variables and a variable binding modifier, return +-- a list of new variables that may be bound, or @Nothing@. +-- +-- Note: if the usage pattern component is well-formed (i.e. all +-- elements different) then at most one element can be compatible with +-- a given input variable set. +-- +vbmCompatibility :: (Eq a) => VarBindingModify a b -> [a] -> Maybe [a] +vbmCompatibility vbm vars = find compat (vbmUsage vbm) + where + compat = vbmCompatibleVars vars (vbmVocab vbm) + +-- |Variable binding usage compatibility test. +-- +-- Returns @True@ if the supplied variable bindings can be compatibly +-- processed by a variable binding usage with supplied vocabulary and +-- usage pattern. +-- +vbmCompatibleVars :: + (Eq a) + => [a] -- ^ variables supplied with bindings + -> [a] -- ^ variables returned with bindings by a modifier + -> [a] -- ^ variables assigned new bindings by a modifier + -> Bool +vbmCompatibleVars bvars vocab ovars = + null (ivars `intersect` ovars) && -- ivars and ovars don't overlap + null ((vocab \\ ovars) \\ ivars) -- ovars and ivars cover vocab + where + ivars = bvars `intersect` vocab + +-- |Compose variable binding modifiers. +-- +-- Returns @Just a@ new variable binding modifier that corresponds to +-- applying the first supplied modifier and then applying the second +-- one, or @Nothing@ if the two modifiers cannot be compatibly composed. +-- +-- NOTE: this function does not, in general, commute. +-- +-- NOTE: if there are different ways to achieve the same usage, that +-- usage is currently repeated in the result returned. +-- +vbmCompose :: (Eq a) => VarBindingModify a b -> VarBindingModify a b + -> Maybe (VarBindingModify a b) +vbmCompose + (VarBindingModify nam1 app1 voc1 use1) + (VarBindingModify nam2 app2 voc2 use2) + | not (null use12) = Just VarBindingModify + { vbmName = swishName ("_"++ snLocal nam1 ++"_"++ snLocal nam2 ++"_") + , vbmApply = app2 . app1 + , vbmVocab = voc1 `union` voc2 + , vbmUsage = use12 + } + | otherwise = Nothing + where + use12 = compatibleUsage voc1 use1 use2 + +-- |Determine compatible ways in which variable binding modifiers may +-- be combined. +-- +-- The total vocabulary of a modifier is the complete set of variables +-- that are used or bound by the modifier. After the modifier has been +-- applied, bindings must exist for all of these variables. +-- +-- A usage pattern of a modifier is a set of variables for which new +-- bindings may be generated by the modifier. +-- +-- The only way in which two variable binding modifiers can be incompatible +-- with each other is when they both attempt to create a new binding for +-- the same variable. (Note that this does not mean the composition will +-- be compatible with all inputs: see 'vbmCompatibleVars'.) +-- +-- NOTE: if there are different ways to achieve the same usage, that +-- usage is currently repeated in the result returned. +-- +compatibleUsage :: + (Eq a) + => [a] -- ^ the total vocabulary of the first modifier to be applied + -> [[a]] -- ^ usage patterns for the first modifier + -> [[a]] -- ^ usage patterns for the second modifier + -> [[a]] -- ^ a list of possible usage patterns for the composition of + -- the first modifier with the second modifier, or an empty list if + -- the modifiers are incompatible. +compatibleUsage voc1 use1 use2 = + [ u1++u2 | u2 <- use2, null (voc1 `intersect` u2), u1 <- use1 ] + +-- |Find all compatible compositions of a list of variable binding +-- modifiers for a given set of supplied bound variables. +findCompositions :: (Eq a) => [VarBindingModify a b] -> [a] + -> [VarBindingModify a b] +findCompositions vbms vars = + mapMaybe (composeCheckSequence vars) (permutations vbms) + +-- |Compose sequence of variable binding modifiers, and check +-- that the result can be used compatibly with a supplied list +-- of bound variables, returning @Just (composed modifier)@, +-- or @Nothing@. +-- +composeCheckSequence :: (Eq a) => [a] -> [VarBindingModify a b] + -> Maybe (VarBindingModify a b) +composeCheckSequence vars vbms = useWith vars $ composeSequence vbms + where + -- Check that a Maybe modifier is compatible for use with an + -- indicated set of bound variables, and return (Just modifier) + -- or Nothing. + useWith _ Nothing = Nothing + useWith vs v@(Just vbm) + | isJust $ vbmCompatibility vbm vs = v + | otherwise = Nothing + +-- |Compose sequence of variable binding modifiers. +-- +composeSequence :: (Eq a) => [VarBindingModify a b] + -> Maybe (VarBindingModify a b) +composeSequence [] = Just varBindingId +composeSequence (vbm:vbms) = + foldl composePair (Just vbm) vbms + +-- |Compose a pair of variable binding modifiers, returning +-- @Just (composed modifier)@, or @Nothing@. +-- +composePair :: (Eq a) => Maybe (VarBindingModify a b) -> VarBindingModify a b + -> Maybe (VarBindingModify a b) +composePair Nothing _ = Nothing +composePair (Just vbm1) vbm2 = vbmCompose vbm1 vbm2 + +-- |Return @Just a@ compatible composition of variable binding modifiers +-- for a given set of supplied bound variables, or @Nothing@ if there +-- is no compatible composition +-- +findComposition :: (Eq a) => [VarBindingModify a b] -> [a] + -> Maybe (VarBindingModify a b) +findComposition = listToMaybe `c2` findCompositions + where + c2 = (.) . (.) -- compose with function of two arguments + +-- |Variable binding modifier that returns exactly those +-- variable bindings presented. +-- +varBindingId :: VarBindingModify a b +varBindingId = VarBindingModify + { vbmName = swishName "varBindingId" + , vbmApply = id + , vbmVocab = [] + , vbmUsage = [[]] + } + +-- |Null variable binding modifier +-- +-- This is like 'varBindingId' except parameterized by some labels. +-- I think this is redundant, and should be eliminated. +-- +nullVarBindingModify :: OpenVarBindingModify a b +nullVarBindingModify lbs = VarBindingModify + { vbmName = swishName "nullVarBindingModify" + , vbmApply = id + , vbmVocab = lbs + , vbmUsage = [[]] + } + +------------------------------------------------------------ +-- Query binding filters +------------------------------------------------------------ + +-- |VarBindingFilter is a function type that tests to see if +-- a query binding satisfies some criterion. +-- +-- Queries often want to apply some kind of filter or condition +-- to the variable bindings that are processed. In inference rules, +-- it sometimes seems desirable to stipulate additional conditions on +-- the things that are matched. +-- +-- This function type is used to perform such tests. +-- A number of simple implementations are included below. +data VarBindingFilter a b = VarBindingFilter + { vbfName :: ScopedName + , vbfVocab :: [a] + , vbfTest :: VarBinding a b -> Bool + } + +-- |Make a variable binding modifier from a variable binding filter value. +makeVarFilterModify :: VarBindingFilter a b -> VarBindingModify a b +makeVarFilterModify vbf = VarBindingModify + { vbmName = vbfName vbf + , vbmApply = filter (vbfTest vbf) + , vbmVocab = vbfVocab vbf + , vbmUsage = [[]] + } + +-- |Make a variable test filter for a named variable using a +-- supplied value testing function. +makeVarTestFilter :: + ScopedName -> (b -> Bool) -> a -> VarBindingFilter a b +makeVarTestFilter nam vtest var = VarBindingFilter + { vbfName = nam + , vbfVocab = [var] + , vbfTest = \vb -> case vbMap vb var of + Just val -> vtest val + _ -> False + } + +-- |Make a variable comparison filter for named variables using +-- a supplied value comparison function. +makeVarCompareFilter :: + ScopedName -> (b -> b -> Bool) -> a -> a -> VarBindingFilter a b +makeVarCompareFilter nam vcomp v1 v2 = VarBindingFilter + { vbfName = nam + , vbfVocab = [v1,v2] + , vbfTest = \vb -> case (vbMap vb v1,vbMap vb v2) of + (Just val1, Just val2) -> vcomp val1 val2 + _ -> False + } + +------------------------------------------------------------ +-- Declare some generally useful query binding filters +------------------------------------------------------------ + +-- |This function generates a query binding filter that ensures that +-- two indicated query variables are mapped to the same value. +varFilterEQ :: (Eq b) => a -> a -> VarBindingFilter a b +varFilterEQ = + makeVarCompareFilter (swishName "varFilterEQ") (==) + +-- |This function generates a query binding filter that ensures that +-- two indicated query variables are mapped to different values. +varFilterNE :: (Eq b) => a -> a -> VarBindingFilter a b +varFilterNE = + makeVarCompareFilter (swishName "varFilterNE") (/=) + +-- |This function composes a number of query binding filters +-- into a composite filter that accepts any query binding that +-- satisfies at least one of the component values. +varFilterDisjunction :: (Eq a) => [VarBindingFilter a b] + -> VarBindingFilter a b +varFilterDisjunction vbfs = VarBindingFilter + { vbfName = swishName "varFilterDisjunction" + , vbfVocab = foldl1 union (map vbfVocab vbfs) + , vbfTest = or . flist (map vbfTest vbfs) + } + +-- |This function composes a number of query binding filters +-- into a composite filter that accepts any query binding that +-- satisfies all of the component values. +-- +-- The same function could be achieved by composing the component +-- filter-based modifiers, but this function is more convenient +-- as it avoids the need to check for modifier compatibility. +-- +varFilterConjunction :: (Eq a) => [VarBindingFilter a b] + -> VarBindingFilter a b +varFilterConjunction vbfs = VarBindingFilter + { vbfName = swishName "varFilterConjunction" + , vbfVocab = foldl1 union (map vbfVocab vbfs) + , vbfTest = and . flist (map vbfTest vbfs) + } + +-------------------------------------------------------------------------------- +-- +-- (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/Vocabulary.hs b/Swish/RDF/Vocabulary.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/Vocabulary.hs @@ -0,0 +1,264 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Vocabulary +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines some commonly used vocabulary terms, +-- using the 'Namespace' and 'ScopedName' data types. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Vocabulary + ( namespaceNull + , namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceOWL + , namespaceXSD + , namespaceXsdType + , namespaceMATH + , namespaceLOG + , namespaceDAML + , namespaceDefault + , namespaceSwish, swishName + , namespaceLang, langName, langTag, isLang + , scopeRDF + , scopeRDFS + , scopeRDFD + , rdf_datatype, rdf_resource, rdf_about, rdf_ID + , rdf_type + , rdf_first, rdf_rest, rdf_nil, rdf_XMLLiteral + , rdfs_member + , rdfd_GeneralRestriction + , rdfd_onProperties, rdfd_constraint, rdfd_maxCardinality + , owl_sameAs, log_implies + , xsd_type, xsd_string, xsd_boolean + , xsd_decimal, xsd_integer + , xsd_nonneg_integer, xsd_nonpos_integer, xsd_pos_integer, xsd_neg_integer + , xsd_float, xsd_double + , default_base + ) +where + +import Swish.Utils.Namespace + ( Namespace(..), ScopedName(..) ) + +import Swish.Utils.MiscHelpers + ( lower ) + +------------------------------------------------------------ +-- Define some common namespace values +------------------------------------------------------------ + +namespaceNull :: Namespace +namespaceNull + = Namespace "" "" + +namespaceRDF :: Namespace +namespaceRDF = + Namespace "rdf" "http://www.w3.org/1999/02/22-rdf-syntax-ns#" + +namespaceRDFS :: Namespace +namespaceRDFS = + Namespace "rdfs" "http://www.w3.org/2000/01/rdf-schema#" + +namespaceRDFD :: Namespace +namespaceRDFD = + Namespace "rdfd" "http://id.ninebynine.org/2003/rdfext/rdfd#" + +namespaceOWL :: Namespace +namespaceOWL = + Namespace "owl" "http://www.w3.org/2002/07/owl#" + +namespaceXSD :: Namespace +namespaceXSD = + Namespace "xsd" "http://www.w3.org/2001/XMLSchema#" + +namespaceXsdType :: String -> Namespace +namespaceXsdType dtname = + Namespace ("xsd_"++dtname) + ("http://id.ninebynine.org/2003/XMLSchema/"++dtname++"#") + +namespaceMATH :: Namespace +namespaceMATH = + Namespace "math" "http://www.w3.org/2000/10/swap/math#" + +namespaceLOG :: Namespace +namespaceLOG = + Namespace "log" "http://www.w3.org/2000/10/swap/log#" + -- Namespace "log" "http://www.w3.org/2000/10/swap/log.n3#" + +namespaceDAML :: Namespace +namespaceDAML = + Namespace "daml" "http://www.daml.org/2000/10/daml-ont#" + +namespaceDefault :: Namespace +namespaceDefault + -- = Namespace "default" "#" + = Namespace "default" "http://id.ninebynine.org/default/" + +namespaceSwish :: Namespace +namespaceSwish + = Namespace "swish" "http://id.ninebynine.org/2003/Swish/" + +swishName :: String -> ScopedName +swishName = ScopedName namespaceSwish + +----------------------------------------------------------- +-- Language tags +------------------------------------------------------------ +-- +-- Note: simple language tag URIs may be abbreviated as lang:tag, +-- but if the tag contains ahyphen, 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 m,ay change that). + +namespaceLang :: Namespace +namespaceLang + = Namespace "lang" "http://id.ninebynine.org/2003/Swish/Lang/" + -- To be replaced by urn:ietf:params:lang? + +langName :: String -> ScopedName +langName tag = ScopedName namespaceLang (lower tag) + +langTag :: ScopedName -> String +langTag = snLocal + +isLang :: ScopedName -> Bool +isLang sname = snScope sname == namespaceLang + +------------------------------------------------------------ +-- Define namespaces for RDF rules, axioms, etc +------------------------------------------------------------ + +scopeRDF :: Namespace +scopeRDF = + Namespace "rs_rdf" "http://id.ninebynine.org/2003/Ruleset/rdf#" + +scopeRDFS :: Namespace +scopeRDFS = + Namespace "rs_rdfs" "http://id.ninebynine.org/2003/Ruleset/rdfs#" + +scopeRDFD :: Namespace +scopeRDFD = + Namespace "rs_rdfd" "http://id.ninebynine.org/2003/Ruleset/rdfd#" + +------------------------------------------------------------ +-- Define some common vocabulary terms +------------------------------------------------------------ + +rdf_datatype :: ScopedName +rdf_datatype = ScopedName namespaceRDF "datatype" + +rdf_resource :: ScopedName +rdf_resource = ScopedName namespaceRDF "resource" + +rdf_about :: ScopedName +rdf_about = ScopedName namespaceRDF "about" + +rdf_ID :: ScopedName +rdf_ID = ScopedName namespaceRDF "ID" + +rdf_type :: ScopedName +rdf_type = ScopedName namespaceRDF "type" + +rdf_first :: ScopedName +rdf_first = ScopedName namespaceRDF "first" + +rdf_rest :: ScopedName +rdf_rest = ScopedName namespaceRDF "rest" + +rdf_nil :: ScopedName +rdf_nil = ScopedName namespaceRDF "nil" + +rdf_XMLLiteral :: ScopedName +rdf_XMLLiteral = ScopedName namespaceRDF "XMLLiteral" + +rdfs_member :: ScopedName +rdfs_member = ScopedName namespaceRDFS "member" + +rdfd_GeneralRestriction :: ScopedName +rdfd_GeneralRestriction = ScopedName namespaceRDFD "GeneralRestriction" + +rdfd_onProperties :: ScopedName +rdfd_onProperties = ScopedName namespaceRDFD "onProperties" + +rdfd_constraint :: ScopedName +rdfd_constraint = ScopedName namespaceRDFD "constraint" + +rdfd_maxCardinality :: ScopedName +rdfd_maxCardinality = ScopedName namespaceRDFD "maxCardinality" + +xsd_type :: String -> ScopedName +xsd_type = ScopedName namespaceXSD + +xsd_string :: ScopedName +xsd_string = xsd_type "string" + +xsd_boolean :: ScopedName +xsd_boolean = xsd_type "boolean" + +xsd_decimal :: ScopedName +xsd_decimal = xsd_type "decimal" + +xsd_integer :: ScopedName +xsd_integer = xsd_type "integer" + +xsd_nonneg_integer :: ScopedName +xsd_nonneg_integer = xsd_type "nonNegativeInteger" + +xsd_nonpos_integer :: ScopedName +xsd_nonpos_integer = xsd_type "nonPositiveInteger" + +xsd_pos_integer :: ScopedName +xsd_pos_integer = xsd_type "positiveInteger" + +xsd_neg_integer :: ScopedName +xsd_neg_integer = xsd_type "negativeInteger" + +xsd_float :: ScopedName +xsd_float = xsd_type "float" + +xsd_double :: ScopedName +xsd_double = xsd_type "double" + +owl_sameAs :: ScopedName +owl_sameAs = ScopedName namespaceOWL "sameAs" + +log_implies :: ScopedName +log_implies = ScopedName namespaceLOG "implies" + +default_base :: ScopedName +default_base = ScopedName namespaceDefault "base" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/DateTime.hs b/Swish/Utils/DateTime.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/DateTime.hs @@ -0,0 +1,325 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : DateTime +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module defines a collection of date/time manipulation functions. It +-- should probably be replaced by standard modules from Hackage. +-- +-- Date/time value manipulation. +-- +-- Date/time can be date-only or time-only +-- +-- type DateTime is an instance of built-in classes Eq and Show +-- +-- type DateTime has a constructor that accepts a string in the format +-- defined by RFC 3339. +-- Timezone interpretation is per RFC3339. +-- +-------------------------------------------------------------------------------- +-- +-- year,month,day,hour,min,sec,millisec,timezone +--class (Show a,Eq a) => DateTimeClass a where +-- newDateTime :: Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> a +-- toString :: a -> String +-- size :: a -> Int +-- toDateTime :: String -> a +-- toDate :: String -> a +-- toTime :: String -> a +-- (==) :: a -> a -> Bool -- same date/time +-- (<) :: a -> a -> Bool -- first precedes second +-- (+) :: a -> a -> a -- advance by time +-- (-) :: a -> a -> a -- difference between times +-- dtShow :: a -> String -- return string form +-- dtYear :: a -> Int +-- dtMonth :: a -> Int +-- dtDay :: a -> Int +-- dtHour :: a -> Int +-- dtMinute :: a -> Int +-- dtSecond :: a -> Int +-- dtMillisecs :: a -> Int +-- dtTimezone :: a -> Int -- time zone offset in minutes +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.DateTime where + +data DateTime + = DateTime Int Int Int Int Int Int Int Int + +instance Eq DateTime where + d1 == d2 = simpleEq ( normTZ d1 ) ( normTZ d2 ) + +instance Show DateTime where + show = dtShow + +instance Ord DateTime where + dt1 < dt2 = simpleLT ( normTZ dt1 ) ( normTZ dt2 ) + dt1 > dt2 = dt2 < dt1 + dt1 <= dt2 = (dt1 < dt2)||(dt1==dt2) + dt1 >= dt2 = (dt2 < dt1)||(dt1==dt2) + +leapYear :: Int -> Bool +leapYear year + | ( year `mod` 4 == 0 ) && + not ( ( year `mod` 100 == 0 ) && + ( (year `mod` 400) /= 0 ) ) = True + | otherwise = False + +daysInMonth :: Int -> Int -> Int +daysInMonth month year + | month==1 = 31 --Jan + | month==2 = if leapYear year then 29 else 28 --Feb + | month==3 = 31 --Mar + | month==4 = 30 --Apr + | month==5 = 31 --May + | month==6 = 30 --Jun + | month==7 = 31 --Jul + | month==8 = 31 --Aug + | month==9 = 30 --Sep + | month==10 = 31 --Oct + | month==11 = 30 --Nov + | month==12 = 31 --Dec + | otherwise = 0 + +validJulianDate :: Int -> Int -> Int -> Bool +validJulianDate yr mo da + | yr < 1900 = False + | mo > 12 = False + | da > daysInMonth mo yr = False + | otherwise = True + +toJulianDate1 :: DateTime -> Int +toJulianDate1 (DateTime y m d _ _ _ _ _) = toJulianDate y m d + +toJulianDate :: Int -> Int -> Int -> Int +toJulianDate year month day +-- | not (validJulianDate year month day) = -1 + | year==1900 && month<=2 = if month==2 then day + 30 else day - 1 + | month>=3 = toJD1 (year-1900) (month-3) day + | otherwise = toJD1 (year-1901) (month+9) day + where + toJD1 :: Int -> Int -> Int -> Int + toJD1 y m d + = ( (1461*y) `div` 4 ) - + (y `div` 100) + + ((y+300) `div` 400) + + ( ( (153*m) + 2 ) `div` 5 ) + + d + 58 + +fromJulianDate:: Int -> DateTime +fromJulianDate jdate + | jdate <= 58 = fromJD1 jdate + | otherwise = fromJD2 jdate + where + fromJD1 :: Int -> DateTime + fromJD1 j + | j<=30 = DateTime 1900 1 (j+1 ) 0 0 0 0 0 + | otherwise = DateTime 1900 2 (j-30) 0 0 0 0 0 + + fromJD2 :: Int -> DateTime + fromJD2 j + = DateTime y2 m2 d1 0 0 0 0 0 + where +-- t1 = (400*(j+((j+36467)`div`36525)-((j+109517)`div`dc))) - 23638 -- 1/400-days from 1900-02-28 [t] + t1 = (400* + (j + +((4*(j+36465))`div`146097) + -((j+109513)`div`146097))) - 23638 -- 1/400-days from 1900-02-28 [t] + dc = 146100 -- days in cycle period (400 years) = 1/400-days in year + t2 = ( ( t1 `mod` dc ) `div` 400 )*5 + 2 -- fifth-days into year, +2 [j3] + d1 = ( t2 `mod` 153 ) `div` 5 + 1 -- day of month (magic number 153) [d] + m1 = t2 `div` 153 -- month Mar=0 -> Feb=11 [j4] + m2 = if m1 <= 9 then m1+3 else m1-9 -- correct month to Jan=1 -> Dec=12 [m] + y1 = t1 `div` dc + 1900 -- year from 1900-02-28 + y2 = if m1 <= 9 then y1 else y1+1 -- correct year for month wrap-around + -- 36525 = days/century, not counting century adjustments + -- 109517 = 146100 * (1900-1600)/400 - 58 + -- 23238 = 58*400 + 38 ??? 38=152/4 ?? + +{- -- this code works for dates before 2100 only + t1 = (4*j) - 233 -- quarter-days from 1900-02-28 + dc = 1461 -- days in cycle period (4 years) = quarter-days in year + t2 = ( ( t1 `mod` dc ) `div` 4 )*5 + 2 -- fifth-days into year, +2 + d1 = ( t2 `mod` 153 ) `div` 5 + 1 -- day of month (magic number 153) + m1 = t2 `div` 153 -- month Mar=0 -> Feb=11 + m2 = if m1 <= 9 then m1+3 else m1-9 -- correct month to Jan=1 -> Dec=12 + y1 = t1 `div` dc + 1900 -- year from 1900-02-28 + y2 = if m1 <= 9 then y1 else y1+1 -- correct year for month wrap-around +-} + +date :: Int -> Int -> Int -> DateTime +date y m d = DateTime y m d 0 0 0 0 0 + +time :: Int -> Int -> Int -> Int -> Int -> DateTime +time = DateTime 0 0 0 + +dtYear :: DateTime -> Int +dtMonth :: DateTime -> Int +dtDay :: DateTime -> Int +dtHour :: DateTime -> Int +dtMinute :: DateTime -> Int +dtSecond :: DateTime -> Int +dtMillisecs :: DateTime -> Int +dtTimezone :: DateTime -> Int -- time zone offset in minutes +dtYear ( DateTime x _ _ _ _ _ _ _ ) = x +dtMonth ( DateTime _ x _ _ _ _ _ _ ) = x +dtDay ( DateTime _ _ x _ _ _ _ _ ) = x +dtHour ( DateTime _ _ _ x _ _ _ _ ) = x +dtMinute ( DateTime _ _ _ _ x _ _ _ ) = x +dtSecond ( DateTime _ _ _ _ _ x _ _ ) = x +dtMillisecs ( DateTime _ _ _ _ _ _ x _ ) = x +dtTimezone ( DateTime _ _ _ _ _ _ _ x ) = x + +lenFix :: String -> Int -> String +lenFix inStr newLen + | length inStr >= newLen = inStr + | otherwise = lenFix ('0':inStr) newLen + +showTZ :: Int -> String +showTZ tz + | tz<0 = '-' : showTZabs (-tz) + | tz==0 = showTZabs tz + | otherwise = '+' : showTZabs tz + +showTZabs :: Int -> String +showTZabs tz + | tz==0 = "Z" + | otherwise = lenFix ( show ( tz `div` 60 ) ) 2 ++ ":" ++ + lenFix ( show ( tz `mod` 60 ) ) 2 + +showTime :: DateTime -> String +showTime ( DateTime _ _ _ hr mi se ms _ ) + | ms==0 = lenFix ( show hr ) 2 ++ ":" ++ + lenFix ( show mi ) 2 ++ ":" ++ + lenFix ( show se ) 2 + | otherwise = lenFix ( show hr ) 2 ++ ":" ++ + lenFix ( show mi ) 2 ++ ":" ++ + lenFix ( show se ) 2 ++ "." ++ + lenFix ( show ms ) 3 + +showDate :: DateTime -> String +showDate ( DateTime yr mo da _ _ _ _ _ ) + = lenFix ( show yr ) 4 ++ "-" ++ + lenFix ( show mo ) 2 ++ "-" ++ + lenFix ( show da ) 2 + +dtShow :: DateTime -> String -- return string form +dtShow ( DateTime yr mo da hr mi se ms tz ) + = showDate ( DateTime yr mo da hr mi se ms tz ) ++ "T" ++ + showTime ( DateTime yr mo da hr mi se ms tz ) ++ showTZ tz + +carryMins :: DateTime -> DateTime +carryMins ( DateTime yr mo da hr mi se ms tz ) + | newhrs >= 24 = carryHours ( DateTime yr mo da newhrs (mi`mod`60) se ms tz ) + | otherwise = DateTime yr mo da newhrs (mi`mod`60) se ms tz + where + newhrs = hr + (mi`div`60) + +carryHours :: DateTime -> DateTime +carryHours ( DateTime yr mo da hr mi se ms tz ) + = DateTime y m d (hr`mod`24) mi se ms tz + where + (DateTime y m d _ _ _ _ _) = fromJulianDate (toJulianDate yr mo da + (hr`div`24)) + +normTZ :: DateTime -> DateTime +normTZ ( DateTime yr mo da hr mi se ms tz ) + = carryMins ( DateTime yr mo da hr (mi-tz) se ms 0 ) +-- = addMinutes (-tz) ( DateTime yr mo da hr mi se ms tz ) + +{- another way -} + +addMilliSecs :: Int -> DateTime -> DateTime +addMilliSecs addms ( DateTime yr mo da hr mi se ms tz ) + | totms < 1000 = DateTime yr mo da hr mi se totms tz + | otherwise = addSeconds addse ( DateTime yr mo da hr mi se newms tz ) + where + totms = ms + addms + newms = totms `mod` 1000 + addse = totms `div` 1000 + +addSeconds :: Int -> DateTime -> DateTime +addSeconds addse ( DateTime yr mo da hr mi se ms tz ) + | totse < 60 = DateTime yr mo da hr mi totse ms tz + | otherwise = addMinutes addmi ( DateTime yr mo da hr mi newse ms tz ) + where + totse = se + addse + newse = totse `mod` 60 + addmi = totse `div` 60 + +addMinutes :: Int -> DateTime -> DateTime +addMinutes addmi ( DateTime yr mo da hr mi se ms tz ) + | totmi < 60 = DateTime yr mo da hr totmi se ms tz + | otherwise = addHours addhr ( DateTime yr mo da hr newmi se ms tz ) + where + totmi = mi + addmi + newmi = totmi `mod` 60 + addhr = totmi `div` 60 + +addHours :: Int -> DateTime -> DateTime +addHours addhr ( DateTime yr mo da hr mi se ms tz ) + | tothr < 24 = DateTime yr mo da tothr mi se ms tz + | otherwise = addDays addda ( DateTime yr mo da newhr mi se ms tz ) + where + tothr = hr + addhr + newhr = tothr `mod` 24 + addda = tothr `div` 24 + +addDays :: Int -> DateTime -> DateTime +addDays addda ( DateTime yr mo da hr mi se ms tz ) + = DateTime newyr newmo newda hr mi se ms tz + where + -- newdate = fromJulianDate (toJulianDate yr mo (da+addda) ) + -- newyr = dtYear newdate + -- newmo = dtMonth newdate + -- newda = dtDay newdate + DateTime newyr newmo newda _ _ _ _ _ = fromJulianDate ( toJulianDate yr mo da + addda ) + +{- another way -} + +simpleEq :: DateTime -> DateTime -> Bool +--simpleEq ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) = ( ( yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) == ( yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) ) +simpleEq ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 tz1 ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 tz2 ) = + ( yr1 == yr2 ) && ( mo1 == mo2 ) && ( da1 == da2 ) && ( hr1 == hr2 ) && ( mi1 == mi2 ) && ( se1 == se2 ) && ( ms1 == ms2 ) && ( tz1 == tz2 ) + +simpleLT :: DateTime -> DateTime -> Bool +simpleLT ( DateTime yr1 mo1 da1 hr1 mi1 se1 ms1 _ ) ( DateTime yr2 mo2 da2 hr2 mi2 se2 ms2 _ ) + | yr1 < yr2 = True + | (yr1==yr2)&&(mo1 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" + +-- |Collect set of values from list under supplied mapping function +mapset :: Eq b => ( a -> b ) -> [a] -> [b] +mapset _ [] = [] +mapset f (e:l) = [f e] `union` mapset f l + +-- |Delete the n'th element of a list, returning the result +-- +-- If the list doesn't have an n'th element, return the list unchanged. +-- +deleteIndex :: [a] -> Int -> [a] +deleteIndex [] _ = [] +deleteIndex xxs@(x:xs) n + | n < 0 = xxs + | n == 0 = xs + | otherwise = x:deleteIndex xs (n-1) + +{- +testdi1 = deleteIndex [1,2,3,4] 0 == [2,3,4] +testdi2 = deleteIndex [1,2,3,4] 1 == [1,3,4] +testdi3 = deleteIndex [1,2,3,4] 2 == [1,2,4] +testdi4 = deleteIndex [1,2,3,4] 3 == [1,2,3] +testdi5 = deleteIndex [1,2,3,4] 4 == [1,2,3,4] +testdi6 = deleteIndex [1,2,3,4] (-1) == [1,2,3,4] +testdi = and + [ testdi1, testdi2, testdi3, testdi4, testdi5, testdi6 ] +-} + +------------------------------------------------------------ +-- Set functions +------------------------------------------------------------ + +-- |Subset test + +subset :: (Eq a) => [a] -> [a] -> Bool +a `subset` b = and [ ma `elem` b | ma <- a ] + +-- |Set equivalence test + +equiv :: (Eq a) => [a] -> [a] -> Bool +a `equiv` b = a `subset` b && b `subset` a + +-- |Set partition test +-- +-- Is it possible to be more efficient here? +-- Maybe something like sort\/merge\/compare? +hasPartitions :: (Eq a) => [a] -> ([a],[a]) -> Bool +a `hasPartitions` (b1,b2) = + null (b1 `intersect` b2) && (a `equiv` (b1 `union` b2)) + +-- |Add element to set + +addSetElem :: (Eq a) => a -> [a] -> [a] +addSetElem e es = if e `elem` es then es else e:es + +------------------------------------------------------------ +-- Lists and Maybes +------------------------------------------------------------ + +-- |Return head of a list of @Maybe@'s, or @Nothing@ if list is empty +-- +-- Use with @filter isJust@ to select a non-Nothing value from a +-- list when such a value is present. +-- +headOrNothing :: [Maybe a] -> Maybe a +headOrNothing [] = Nothing +headOrNothing (a:_) = a + +------------------------------------------------------------ +-- Filter, ungroup, sort and group pairs by first member +------------------------------------------------------------ + +{- +pairSelect :: ((a,b) -> Bool) -> ((a,b) -> c) -> [(a,b)] -> [c] +pairSelect p f as = map f (filter p as) +-} + +pairUngroup :: (a,[b]) -> [(a,b)] +pairUngroup (a,bs) = [ (a,b) | b <- bs ] + +pairsUngroup :: [(a,[b])] -> [(a,b)] +pairsUngroup ps = [ (a,b) | (a,bs) <- ps, b <- bs ] + +pairSort :: (Ord a) => [(a,b)] -> [(a,b)] +pairSort = sortBy (comparing fst) + +pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])] +pairGroup = map (factor . unzip) . groupBy eqFirst . pairSort + where + -- as is not [] by construction, but would be nice to have + -- this enforced by the types + factor (as, bs) = (head as,bs) + eqFirst a b = fst a == fst b + +------------------------------------------------------------ +-- Separate list into sublists +------------------------------------------------------------ + +-- |Break list into a list of sublists, separated by element +-- satisfying supplied condition. +breakAll :: (a -> Bool) -> [a] -> [[a]] +breakAll _ [] = [] +breakAll p s = let (h,s') = break p s + in h : breakAll p (drop 1 s') + +------------------------------------------------------------ +-- Powerset +------------------------------------------------------------ + +-- [[[TBD... there's a much better implementation in my email, +-- from Christopher Hendrie. This is the raw code.]]] +{- +>ranked_powerset :: [a] -> [[[a]]] +>ranked_powerset = takeWhile (not . null) . foldr next_powerset ([[]] : +repeat []) +> +>next_powerset :: a -> [[[a]]] -> [[[a]]] +>next_powerset x r = zipWith (++) ([] : map (map (x:)) r) r +> +>powerset :: [a] -> [[a]] +>powerset = tail . concat . ranked_powerset +-} + +-- |Powerset of a list, in ascending order of size. +-- Assumes the supplied list has no duplicate elements. +powerSet :: [a] -> [[a]] +powerSet as = + concatMap (`combinations` as) [1..length as] + +-- |Combinations of n elements from a list, each being returned in the +-- order that they appear in the list. +combinations :: Int -> [a] -> [[a]] +combinations _ [] = [] -- Don't include empty combinations +combinations n as@(ah:at) + | n <= 0 = [[]] + | n > length as = [] + | n == length as = [as] + | otherwise = map (ah:) (combinations (n-1) at) ++ + combinations n at + +{- +-- |Return list of integers from lo to hi. +intRange :: Int -> Int -> [Int] +intRange lo hi = take (hi-lo+1) (iterate (+1) 1) +-} + +{- +-- Tests +testcomb0 = combinations 0 "abcd" -- [] +testcomb1 = combinations 1 "abcd" -- ["a","b","c","d"] +testcomb2 = combinations 2 "abcd" -- ["ab","ac","ad","bc","bd","cd"] +testcomb3 = combinations 3 "abcd" -- ["abc","abd","acd","bcd"] +testcomb4 = combinations 4 "abcd" -- ["abcd"] +testcomb5 = combinations 5 "abcd" -- [] +testpower = powerSet "abc" -- ["a","b","c","ab","ac","bc","abc"] +-} + +------------------------------------------------------------ +-- Permutations of a list +------------------------------------------------------------ + +-- This algorithm is copied from an email by S.D.Mechveliani +-- http://www.dcs.gla.ac.uk/mail-www/haskell/msg01936.html +permutations :: [a] -> [[a]] +permutations [] = [[]] +permutations (j:js) = addOne $ permutations js + where + addOne = foldr ((++) . ao) [] + + ao [] = [[j]] + ao (k:ks) = (j:k:ks) : map (k:) (ao ks) + +{- +testperm = permutations [1,2,3] == + [[1,2,3],[2,1,3],[2,3,1],[1,3,2],[3,1,2],[3,2,1]] +-} + +------------------------------------------------------------ +-- List product +------------------------------------------------------------ + +-- |Given a list of lists, construct a new list of lists where +-- each member of the new list is the same length as the original +-- list, and each member corresponds to a different choice of +-- one element from each of the original members in the +-- corresponding position. Thus: +-- +-- > listProduct [[a1,a2],[b1],[c1,c2]] = +-- > [ [a1,b1,c1], [a1,b1,c2], [a2,b1,c1], [a2,b1,c2] ] +-- +-- Note: The length of the resulting list is the prodicty of +-- lengths of the components of the original list. Thus, if +-- any member of the original list is empty then so is the +-- resulting list: +-- +-- > listProduct [[a1,a2],[],[c1,c2]] = [] +-- +-- NOTE: this is subsumed by 'sequence' +-- +listProduct :: [[a]] -> [[a]] +listProduct [] = [[]] +listProduct (as:ass) = concat [ map (a:) (listProduct ass) | a <- as ] + +{- +test1 = listProduct [["a1","a2"],["b1"],["c1","c2"]] +test2 = listProduct [["a1","a2"],[],["c1","c2"]] + +lp [] = [[]] +lp (as:ass) = concatMap (\a -> (map (a:) (lp ass))) as +-} + +------------------------------------------------------------ +-- Powersequence (?) -- all sequences from some base values +------------------------------------------------------------ + +-- |Function to choose all sequences of any length +-- from a supplied set of values, returned in +-- increasing length. +powerSequences :: [a] -> [[a]] +powerSequences rs = concat $ powerSeq_bylen rs [[]] + +-- |Construct list of lists of sequences of increasing length +powerSeq_bylen :: [a] -> [[a]] -> [[[a]]] +powerSeq_bylen rs ps = ps : powerSeq_bylen rs (powerSeq_next rs ps) + +-- |Return sequences of length n+1 given original sequence +-- and list of all sequences of length n +powerSeq_next :: [a] -> [[a]] -> [[a]] +powerSeq_next rs rss = [ h:t | t <- rss, h <- rs ] + +-- |Return all powersequences of a given length +powerSequences_len :: Int -> [a] -> [[a]] +powerSequences_len len rs = powerSeq_bylen rs [[]] !! len + +-- |Return all powersequences of indefinite length +-- Observe that any such powersequence will consist of a sequence +-- of a finite length sequence followed by an indefinite number of +-- copies of the head of the base set. To prevent duplicates, the +-- generator constructs only sequences that do not end in the first +-- member of the base set. +powerSequences_inf :: [a] -> [[a]] +powerSequences_inf rs = + map (++pst) $ [] : concat (powerSeq_bylen rs psh) + where + psh = map (:[]) (tail rs) + pst = repeat $ head rs + +{- Powersequence tests +t0 = [1,2,3,4,5,6] +t1 = powerSequences t0 +t2 = take 15 t1 +t3 = powerSequences_len 3 t0 +t4 = powerSequences_inf t0 +t5 = map (take 6) $ take 15 t4 +t6 = take 15 (powerSequences_len 6 t0) +t7 = t5 == t6 +t8 = powerSequences_len1 3 t0 +t9 = t8 == t3 +-} + +------------------------------------------------------------ +-- Functions, lists and monads +------------------------------------------------------------ + +-- |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] +-} + +-- |Fold result from list of functions applied to some value, +-- returning the result of the fold. +-- +-- This is similar to the 'ap' function in the Monad library. +-- +ffold :: (b->c->c) -> c -> [a->b] -> a -> c +ffold rf ri fs v = foldr rf ri (flist fs v) + +{- +ffoldtest0 = ffold ge4and True [(1+),(2+),(3+)] 0 -- False +ffoldtest1 = ffold ge4and True [(1+),(2+),(3+)] 1 -- False +ffoldtest2 = ffold ge4and True [(1+),(2+),(3+)] 2 -- False +ffoldtest3 = ffold ge4and True [(1+),(2+),(3+)] 3 -- True +ge4and v b = (v>=4 && b) +ffoldtest = and [not ffoldtest0,not ffoldtest1,not ffoldtest2,ffoldtest3] +-} + +-- |Test if application of all functions in list to a given value +-- satisfies a given condition +-- +allf :: (b->Bool) -> [a->b] -> a -> Bool +allf pf fs a = all pf (flist fs a) + +{- +allftest0 = allf (>=4) [(1+),(2+),(3+)] 0 -- False +allftest1 = allf (>=4) [(1+),(2+),(3+)] 1 -- False +allftest2 = allf (>=4) [(1+),(2+),(3+)] 2 -- False +allftest3 = allf (>=4) [(1+),(2+),(3+)] 3 -- True +allftest = and [not allftest0,not allftest1,not allftest2,allftest3] +-} + +-- |Test if application of any functions in list to a given value +-- satisfies a given condition +-- +anyf :: (b->Bool) -> [a->b] -> a -> Bool +anyf pf fs a = any pf (flist fs a) + +{- +anyftest0 = anyf (>=4) [(1+),(2+),(3+)] 0 -- False +anyftest1 = anyf (>=4) [(1+),(2+),(3+)] 1 -- True +anyftest2 = anyf (>=4) [(1+),(2+),(3+)] 2 -- True +anyftest3 = anyf (>=4) [(1+),(2+),(3+)] 3 -- True +anyftest = and [not anyftest0,anyftest1,anyftest2,anyftest3] +-} + +-- |Test if a value satisfies all predicates in a list +-- +allp :: [a->Bool] -> a -> Bool +allp ps a = and (flist ps a) + +{- +allptest0 = allp [(>=1),(>=2),(>=3)] 0 -- False +allptest1 = allp [(>=1),(>=2),(>=3)] 1 -- False +allptest2 = allp [(>=1),(>=2),(>=3)] 2 -- False +allptest3 = allp [(>=1),(>=2),(>=3)] 3 -- True +allptest = and [not allptest0,not allptest1,not allptest2,allptest3] +-} + +-- |Test if a value satisfies any predicate in a list +-- +anyp :: [a->Bool] -> a -> Bool +anyp ps a = or (flist ps a) + +{- +anyptest0 = anyp [(>=1),(>=2),(>=3)] 0 -- False +anyptest1 = anyp [(>=1),(>=2),(>=3)] 1 -- True +anyptest2 = anyp [(>=1),(>=2),(>=3)] 2 -- True +anyptest3 = anyp [(>=1),(>=2),(>=3)] 3 -- True +anyptest = and [not anyptest0,anyptest1,anyptest2,anyptest3] +-} + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/LookupMap.hs b/Swish/Utils/LookupMap.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/LookupMap.hs @@ -0,0 +1,451 @@ +{-# LANGUAGE MultiParamTypeClasses, FunctionalDependencies #-} +{-# LANGUAGE FlexibleContexts, FlexibleInstances, TypeSynonymInstances #-} +{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : LookupMap +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : A lot of LANGUAGE extensions... +-- +-- This module defines a lookup table format and associated functions +-- used by the graph matching code. +-- +-------------------------------------------------------------------------------- + +------------------------------------------------------------ +-- Generic list-of-pairs lookup functions +------------------------------------------------------------ + +module Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , emptyLookupMap, makeLookupMap, listLookupMap + , reverseLookupMap + , keyOrder + , mapFind, mapFindMaybe, mapContains + , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap + , mapAdd, mapAddIfNew + , mapDelete, mapDeleteAll + , mapApplyToAll, mapTranslate + , mapEq, mapKeys, mapVals + , mapSelect, mapMerge + , mapSortByKey, mapSortByVal + , mapTranslateKeys, mapTranslateVals + , mapTranslateEntries, mapTranslateEntriesM + ) + where + +import qualified Data.Foldable as F +import qualified Data.Traversable as T +import qualified Data.List as L + +import Data.Ord (comparing) + +import Swish.Utils.ListHelpers ( equiv ) + +------------------------------------------------------------ +-- Class for lookup map entries +------------------------------------------------------------ + +-- |@LookupEntryClass@ defines essential functions of any datatype +-- that can be used to make a 'LookupMap'. +-- +-- Minimal definition: @newEntry@ and @keyVal@ +-- +class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v + where + newEntry :: (k,v) -> a + keyVal :: a -> (k,v) + entryKey :: a -> k + entryKey e = k where (k,_) = keyVal e + entryVal :: a -> v + entryVal e = v where (_,v) = keyVal e + entryEq :: (Eq v) => a -> a -> Bool + entryEq e1 e2 = keyVal e1 == keyVal e2 + entryShow :: (Show v) => a -> String + entryShow e = show k ++ ":" ++ show v where (k,v) = keyVal e + kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2 + kmap f e = newEntry (f $ entryKey e,entryVal e) + vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2 + vmap f e = newEntry (entryKey e,f $ entryVal e) + +-- |Predefine a pair of appropriate values as a valid lookup table entry +-- (i.e. an instance of LookupEntryClass). +-- +instance (Eq k, Show k) => LookupEntryClass (k,v) k v where + newEntry = id + keyVal = id + +-- |Define a lookup map based on a list of values. +-- +-- Note: the class constraint that a is an instance of 'LookupEntryClass' +-- is not defined here, for good reasons (which I forget right now, but +-- something to do with the method dictionary being superfluous on +-- an algebraic data type). +-- +data LookupMap a = LookupMap [a] + deriving (Functor, F.Foldable, T.Traversable) + +gLM :: LookupMap a -> [a] +gLM (LookupMap es) = es + +-- |Define equality of 'LookupMap' values based on equality of entries. +-- +-- (This is possibly a poor definition, as it is dependent on ordering +-- of list members. But it passes all current test cases, and is used +-- only for testing.) +-- +-- See also 'mapEq' +-- (why not just use that here? I don't know: it's probably historic.) +-- +instance (Eq a) => Eq (LookupMap a) where + LookupMap es1 == LookupMap es2 = es1 == es2 + +-- |Define Show instance for LookupMap based on Showing the +-- list of entries. +-- +instance (Show a ) => Show (LookupMap a) where + show (LookupMap es) = "LookupMap " ++ show es + +{- +TODO: should the LookupEntryClass constraint be removed from +emptyLookupMap and makeLookupMap? + +I guess not since LookupMap is exported, so users can use +that if they do not need the constraint. +-} + +-- |Empty lookup map of arbitrary (i.e. polymorphic) type. +-- +emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a +emptyLookupMap = LookupMap [] + +-- |Function to create a `LookupMap` from a list of entries. +-- +-- Currently, this is trivial but future versions could be +-- more substantial. +-- +makeLookupMap :: (LookupEntryClass a k v) => [a] -> LookupMap a +makeLookupMap = LookupMap + +-- |Return list of lookup map entries. +-- +-- Currently, this is trivial but future versions could be +-- more substantial. +-- +listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a] +listLookupMap = gLM + +-- |Given a lookup map entry, return a new entry that can be used +-- in the reverse direction of lookup. This is used to construct +-- a reverse LookupMap. +-- +reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k) + => a1 -> a2 +reverseEntry e = newEntry (v,k) where (k,v) = keyVal e + +-- |Given a lookup map, return a new map that can be used +-- in the opposite direction of lookup. +-- +reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b) + => LookupMap a1 -> LookupMap a2 +reverseLookupMap = fmap reverseEntry + +-- |Given a pair of lookup entry values, return the ordering of their +-- key values. +-- +keyOrder :: (LookupEntryClass a k v, Ord k) + => a -> a -> Ordering +keyOrder e1 e2 = compare k1 k2 + where + (k1,_) = keyVal e1 + (k2,_) = keyVal e2 + +-- Local helper function to build a new LookupMap from +-- a new entry and an exiting map. +-- +mapCons :: a -> LookupMap a -> LookupMap a +mapCons e (LookupMap es) = LookupMap (e:es) + +-- |Find key in lookup map and return corresponding value, +-- otherwise return default supplied. +-- +mapFind :: (LookupEntryClass a k v) => v -> k -> LookupMap a -> v +mapFind def key (LookupMap es) = foldr match def es where + match ent alt + | key == entryKey ent = entryVal ent + | otherwise = alt + +-- |Find key in lookup map and return Just the corresponding value, +-- otherwise return Nothing. +-- +mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v +mapFindMaybe key (LookupMap es) = foldr match Nothing es where + match ent alt + | key == entryKey ent = Just (entryVal ent) + | otherwise = alt + +-- |Test to see if key is present in the supplied map +-- +mapContains :: (LookupEntryClass a k v) => + LookupMap a -> k -> Bool +mapContains (LookupMap es) key = any match es where + match ent = key == entryKey ent + +-- |Replace an existing occurrence of a key a with a new key-value pair. +-- +-- The resulting lookup map has the same form as the original in all +-- other respects. Assumes exactly one occurrence of the supplied key. +-- +mapReplace :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapReplace (LookupMap (e:es)) newe + | entryKey e == entryKey newe = LookupMap (newe:es) + | otherwise = mapAdd more e where + more = mapReplace (LookupMap es) newe +mapReplace _ newe = + error ("mapReplace: Key value not found in lookup table: "++ + Prelude.show (entryKey newe)) + +-- |Replace an existing occurrence of a key a with a new key-value pair, +-- or add a new key-value pair if the supplied key is not already present. +-- +mapReplaceOrAdd :: (LookupEntryClass a k v) => + a -> LookupMap a -> LookupMap a +mapReplaceOrAdd newe (LookupMap (e:es)) + | entryKey e == entryKey newe = LookupMap (newe:es) + | otherwise = mapCons e more where + more = mapReplaceOrAdd newe (LookupMap es) +mapReplaceOrAdd newe (LookupMap []) = LookupMap [newe] + +-- |Replace any occurrence of a key a with a new key-value pair. +-- +-- The resulting lookup map has the same form as the original in all +-- other respects. +-- +mapReplaceAll :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapReplaceAll (LookupMap (e:es)) newe = mapCons e' more where + more = mapReplaceAll (LookupMap es) newe + e' = if entryKey e == entryKey newe then newe else e +mapReplaceAll (LookupMap []) _ = LookupMap [] + +-- |Replace any occurrence of a key in the first argument with a +-- corresponding key-value pair from the second argument, if present. +-- +-- This could be implemented by multiple applications of 'mapReplaceAll', +-- but is arranged differently so that only one new @LookupMap@ value is +-- created. +-- +-- Note: keys in the new map that are not present in the old map +-- are not included in the result map +-- +mapReplaceMap :: (LookupEntryClass a k v) => + LookupMap a -> LookupMap a -> LookupMap a +mapReplaceMap (LookupMap (e:es)) newmap = mapCons e' more where + more = mapReplaceMap (LookupMap es) newmap + e' = newEntry (k,mapFind v k newmap) + (k,v) = keyVal e +mapReplaceMap (LookupMap []) _ = LookupMap [] + +-- |Add supplied key-value pair to the lookup map. +-- +-- This is effectively an optimized case of 'mapReplaceOrAdd' or 'mapAddIfNew', +-- where the caller guarantees to avoid duplicate key values. +-- +mapAdd :: LookupMap a -> a -> LookupMap a +mapAdd emap e = mapCons e emap + +-- |Add supplied key-value pair to the lookup map, +-- only if the key value is not already present. +-- +mapAddIfNew :: (LookupEntryClass a k v) => + LookupMap a -> a -> LookupMap a +mapAddIfNew emap e = if mapContains emap (entryKey e) + then emap + else mapCons e emap + +-- |Delete supplied key value from the lookup map. +-- +-- This function assumes exactly one occurrence. +-- +mapDelete :: (LookupEntryClass a k v) => + LookupMap a -> k -> LookupMap a +mapDelete (LookupMap (e:es)) k + | k == entryKey e = LookupMap es + | otherwise = mapCons e more where + more = mapDelete (LookupMap es) k +mapDelete _ k = + error ("mapDelete: Key value not found in lookup table: " ++ Prelude.show k) + +-- |Delete any occurrence of a supplied key value from the lookup map. +-- +mapDeleteAll :: (LookupEntryClass a k v) => + LookupMap a -> k -> LookupMap a +mapDeleteAll (LookupMap (e:es)) k = + if entryKey e == k then more else mapCons e more where + more = mapDeleteAll (LookupMap es) k +mapDeleteAll (LookupMap []) _ = LookupMap [] + +-- |Return a list of values obtained by applying a function to each key +-- in the map. Creates an alternative set of values that can be +-- retrieved using mapTranslate. +-- +mapApplyToAll :: (LookupEntryClass a k v) => + LookupMap a -> (k -> w) -> [w] +mapApplyToAll es f = gLM $ fmap (f . entryKey) es + +-- |Find a node in a lookup map list, and returns the +-- corresponding value from a supplied list. The appropriate ordering +-- of the list is not specified here, but an appropriately ordered list +-- may be obtained by 'mapApplyToAll'. +-- +mapTranslate :: (LookupEntryClass a k v) => + LookupMap a -> [w] -> k -> w -> w +mapTranslate (LookupMap (e:es)) (w:ws) k def + | k == entryKey e = w + | otherwise = mapTranslate (LookupMap es) ws k def +mapTranslate _ _ _ def = def + +-- |Compare two lookup maps for equality. +-- +-- Two maps are equal if they have the same set of keys, and if +-- each key maps to an equivalent value. +-- +mapEq :: (LookupEntryClass a k v, Eq v) => + LookupMap a -> LookupMap a -> Bool +mapEq es1 es2 = + ks1 `equiv` ks2 && + and [ mapFindMaybe k es1 == mapFindMaybe k es2 | k <- ks1 ] + where + ks1 = mapKeys es1 + ks2 = mapKeys es2 + +-- |Return the list of keys in a supplied LookupMap +-- +mapKeys :: (LookupEntryClass a k v) => + LookupMap a -> [k] +mapKeys (LookupMap es) = L.nub $ map (fst . keyVal) es + +-- |Return list of distinct values in a supplied LookupMap +-- +mapVals :: (Eq v, LookupEntryClass a k v) => + LookupMap a -> [v] +mapVals (LookupMap es) = L.nub $ map (snd . keyVal) es + +-- |Select portion of a lookup map that corresponds to +-- a supplied list of keys +-- +mapSelect :: (LookupEntryClass a k v) => + LookupMap a -> [k] -> LookupMap a +mapSelect (LookupMap es) ks = + LookupMap $ filter (keyIn ks) es + where + keyIn iks e = fst (keyVal e) `elem` iks + +-- |Merge two lookup maps, ensuring that if the same key appears +-- in both maps it is associated with the same value. +-- +mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) => + LookupMap a -> LookupMap a -> LookupMap a +mapMerge (LookupMap s1) (LookupMap s2) = + LookupMap $ merge (L.sortBy keyOrder s1) (L.sortBy keyOrder s2) + where + merge es1 [] = es1 + merge [] es2 = es2 + merge es1@(e1:et1) es2@(e2:et2) = + case keyOrder e1 e2 of + LT -> e1 : merge et1 es2 + GT -> e2 : merge es1 et2 + EQ -> if e1 /= e2 + then error ("mapMerge key conflict: " ++ show e1 + ++ " with " ++ show e2) + else e1 : merge et1 et2 + +-- |Creates a new map that is the same as the supplied map, except +-- that its entries are sorted by key value. +-- +-- (What's this used for? It should be redundant.) +-- +mapSortByKey :: (LookupEntryClass a k v, Ord k) => + LookupMap a -> LookupMap a +mapSortByKey (LookupMap es) = + LookupMap $ L.sortBy (comparing entryKey) es + +-- |Creates a new map that is the same as the supplied map, except +-- that its entries are sorted by key value. +-- +-- (What's this used for? It should be redundant.) +-- +mapSortByVal :: (LookupEntryClass a k v, Ord v) => + LookupMap a -> LookupMap a +mapSortByVal (LookupMap es) = + LookupMap $ L.sortBy (comparing entryVal) es + +-- |An fmap-like function that returns a new lookup map that is a +-- copy of the supplied map with entry keys replaced according to +-- a supplied function. +-- +mapTranslateKeys :: (LookupEntryClass a1 k1 v, LookupEntryClass a2 k2 v) => + (k1 -> k2) -> LookupMap a1 -> LookupMap a2 +mapTranslateKeys f = fmap (kmap f) + +-- |An fmap-like function that returns a new lookup map that is a +-- copy of the supplied map with entry values replaced according to +-- a supplied function. +-- +mapTranslateVals :: (LookupEntryClass a1 k v1, LookupEntryClass a2 k v2) => + (v1 -> v2) -> LookupMap a1 -> LookupMap a2 +mapTranslateVals f = fmap (vmap f) + +-- |A function that returns a new lookup map that is a copy of the +-- supplied map with complete entries replaced according to +-- a supplied function. +-- +-- Since 'LookupMap' now has a 'Functor' instance this is just 'fmap' +mapTranslateEntries :: (a1 -> a2) -> LookupMap a1 -> LookupMap a2 +mapTranslateEntries = fmap + +-- |A monadic form of `mapTranslateEntries`. +-- +-- Since `LookupMap` now has a `Data.Traversable.Traversable` instance +-- this is just `T.mapM`. +-- +mapTranslateEntriesM :: (Monad m) + => (a1 -> m a2) -> LookupMap a1 -> m (LookupMap a2) +mapTranslateEntriesM = T.mapM +{- +mapTranslateEntriesM f (LookupMap es) = + do { m2 <- mapM f es + ; return $ LookupMap m2 + } +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/MiscHelpers.hs b/Swish/Utils/MiscHelpers.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/MiscHelpers.hs @@ -0,0 +1,111 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : MiscHelpers +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines some generic list and related helper functions +-- used by the graph handling code. +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.MiscHelpers + ( assert, lower, stricmp, quote, hash, hashModulus ) +where + +import Data.Char + ( toLower ) + +------------------------------------------------------------ +-- assert test +------------------------------------------------------------ + +assert :: Bool -> String -> a -> a +assert cond msg expr = if not cond then error msg else expr + +------------------------------------------------------------ +-- Generate lowercase form of supplied string +------------------------------------------------------------ + +lower :: String -> String +lower = foldr ((:) . toLower) "" + +------------------------------------------------------------ +-- Case insensitive compare. +------------------------------------------------------------ +-- +-- Should be used only for values using just the US ASCII +-- character set. Use with richer character sets can yield +-- surprising results. + +stricmp :: String -> String -> Bool +stricmp (c1:s1) (c2:s2) = toLower c1 == toLower c2 && stricmp s1 s2 +stricmp [] [] = True +stricmp _ _ = False + +------------------------------------------------------------ +-- Generate quoted form of supplied string: +------------------------------------------------------------ +-- +-- [[[TODO: The list of quoting options here is incomplete]]] + +quote :: String -> String +quote st = ['"'] ++ quote1 st ++ ['"'] + +quote1 :: String -> String +quote1 ('"': st) = '\\':'"' : quote1 st +quote1 ('\\':st) = '\\':'\\': quote1 st +quote1 ('\n':st) = '\\':'n': quote1 st +quote1 ('\r':st) = '\\':'r': quote1 st +quote1 (c:st) = c: quote1 st +quote1 [] = "" + +------------------------------------------------------------ +-- Hash function and values +------------------------------------------------------------ +-- +-- Simple hash function based on Sedgewick, Algorithms in C, p 233 +-- (choose mx*cm+255 < maxBound) +-- 'seed' is an additional parameter that allows the function +-- to be varied for re-hashing. + +hashModulus :: Int +hashModulus = 16000001 + +hash :: Int -> String -> Int +hash seed = hash1 seed (64+seed) hashModulus + +hash1 :: Int -> Int -> Int -> String -> Int +hash1 sofar cm mx (c:str) = hash1 (( sofar*cm + fromEnum c ) `rem` mx) cm mx str +hash1 sofar _ _ [] = sofar + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/Namespace.hs b/Swish/Utils/Namespace.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/Namespace.hs @@ -0,0 +1,172 @@ +{-# LANGUAGE TypeSynonymInstances, MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Namespace +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : TypeSynonymInstances, MultiParamTypeClasses +-- +-- This module defines algebraic datatypes for namespaces and scoped names. +-- +-- For these purposes, a namespace is a prefix and URI used to identify +-- a namespace (cf. XML namespaces), and a scoped name is a name that +-- is scoped by a specified namespace. +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.Namespace + ( Namespace(..) + , makeNamespaceQName + , nullNamespace + , ScopedName(..) + , getScopePrefix, getScopeURI + , getQName, getScopedNameURI + , matchName + , makeScopedName, makeQNameScopedName, makeUriScopedName + , nullScopedName + ) +where + +import Swish.Utils.QName + ( QName(..), getQNameURI ) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..) ) + +------------------------------------------------------------ +-- Namespace, having a prefix and a URI +------------------------------------------------------------ + +-- |A NameSpace value consists of a prefix and a corresponding URI. +-- The prefix may be empty (@\"\"@), in which case it is assumed to be unknown. +-- +-- NOTE: not clear whether @nsPrefix@ should be empty or set to @\"?\"@. +-- +data Namespace = Namespace { nsPrefix :: String, nsURI :: String } + +{- +getNamespacePrefix :: Namespace -> String +getNamespacePrefix = nsPrefix + +getNamespaceURI :: Namespace -> String +getNamespaceURI = nsURI +-} + +instance Eq Namespace where + (==) = nsEq + +instance Show Namespace where + show (Namespace p u) = + (if p == "?" then "" else p ++ ":") ++ "<" ++ u ++ ">" + +instance LookupEntryClass Namespace String String where + keyVal (Namespace pre uri) = (pre,uri) + newEntry (pre,uri) = Namespace pre uri + +nsEq :: Namespace -> Namespace -> Bool +nsEq (Namespace _ u1) (Namespace _ u2) = u1 == u2 + +makeNamespaceQName :: Namespace -> String -> QName +makeNamespaceQName ns = QName (nsURI ns) + +nullNamespace :: Namespace +nullNamespace = Namespace "?" "" + +------------------------------------------------------------ +-- 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 { snScope :: Namespace, snLocal :: String } + +getScopePrefix :: ScopedName -> String +getScopePrefix = nsPrefix . snScope + +getScopeURI :: ScopedName -> String +getScopeURI = nsURI . snScope + +instance Eq ScopedName where + (==) = snEq + +instance Ord ScopedName where + (<=) = snLe + +instance Show ScopedName where + show (ScopedName n l) = + if pre == "?" then "<"++uri++l++">" else pre++":"++l + where + pre = nsPrefix n + uri = nsURI n + +-- Scoped names are equal of ther corresponding QNames are equal +snEq :: ScopedName -> ScopedName -> Bool +snEq s1 s2 = getQName s1 == getQName s2 + +-- Scoped names are ordered by their QNames +snLe :: ScopedName -> ScopedName -> Bool +snLe s1 s2 = getQName s1 <= getQName s2 + +-- |Get QName corresponding to a scoped name +getQName :: ScopedName -> QName +getQName n = QName (getScopeURI n) (snLocal n) + +-- |Get URI corresponding to a scoped name (using RDF conventions) +getScopedNameURI :: ScopedName -> String +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 from prefix, URI and local name +makeScopedName :: String -> String -> String -> ScopedName +makeScopedName pre nsuri = + ScopedName (Namespace pre nsuri) + +-- |Construct a ScopedName from a QName +makeQNameScopedName :: QName -> ScopedName +makeQNameScopedName (QName u l) = makeScopedName "?" u l + +-- |Construct a ScopedName for a bare URI +makeUriScopedName :: String -> ScopedName +makeUriScopedName u = makeScopedName "?" u "" + +-- |This should never appear as a valid name +nullScopedName :: ScopedName +nullScopedName = makeScopedName "?" "" "" + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/PartOrderedCollection.hs b/Swish/Utils/PartOrderedCollection.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/PartOrderedCollection.hs @@ -0,0 +1,375 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : PartOrderedCollection +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module provides methods to support operations on partially ordered +-- collections. The partial ordering relationship is represented by +-- Maybe `Ordering`. +-- +-- Thanks to members of the haskell-cafe mailing list - +-- Robert (rvollmert-lists@gmx.net) and +-- Tom Pledger (Tom.Pledger@peace.com) - +-- who suggested key ideas on which some of the code in this module is based. +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.PartOrderedCollection + ( PartCompare + , minima, maxima + , partCompareEq, partCompareOrd, partComparePair + , partCompareListPartOrd, partCompareListOrd + , partCompareMaybe, partCompareListMaybe + , partCompareListSubset + ) +where + +------------------------------------------------------------ +-- Type of partial compare function +------------------------------------------------------------ + +type PartCompare a = a -> a -> Maybe Ordering + +------------------------------------------------------------ +-- Functions for minima and maxima of a part-ordered list +------------------------------------------------------------ + +-- |This function finds the maxima in a list of partially +-- ordered values, preserving the sequence of retained +-- values from the supplied list. +-- +-- It returns all those values in the supplied list +-- for which there is no larger element in the list. +-- +maxima :: PartCompare a -> [a] -> [a] +maxima cmp as = foldl add [] as + where + add [] e = [e] + add ms@(m:mr) e = case cmp m e of + Nothing -> m : add mr e + Just GT -> ms + Just EQ -> ms + Just LT -> add mr e + +-- |This function finds the minima in a list of partially +-- ordered values, preserving the sequence of retained +-- values from the supplied list. +-- +-- It returns all those values in the supplied list +-- for which there is no smaller element in the list. +-- +minima :: PartCompare a -> [a] -> [a] +minima cmp = maxima (flip cmp) + +------------------------------------------------------------ +-- Partial ordering comparison functions +------------------------------------------------------------ + +-- |Partial ordering for Eq values +partCompareEq :: (Eq a) => a -> a -> Maybe Ordering +partCompareEq a1 a2 = if a1 == a2 then Just EQ else Nothing + +-- |Partial ordering for Ord values +partCompareOrd :: (Ord a) => a -> a -> Maybe Ordering +partCompareOrd a1 a2 = Just $ compare a1 a2 + +-- |Part-ordering comparison on pairs of values, +-- where each has a part-ordering relationship +partComparePair :: + (a->a->Maybe Ordering) -> (b->b->Maybe Ordering) -> (a,b) -> (a,b) + -> Maybe Ordering +partComparePair cmpa cmpb (a1,b1) (a2,b2) = case (cmpa a1 a2,cmpb b1 b2) of + (_,Nothing) -> Nothing + (jc1,Just EQ) -> jc1 + (Nothing,_) -> Nothing + (Just EQ,jc2) -> jc2 + (Just c1,Just c2) -> if c1 == c2 then Just c1 else Nothing + +-- |Part-ordering comparison on lists of partially ordered values, where: +-- +-- [@as==bs@] if members of as are all equal to corresponding members of bs +-- +-- [@as<=bs@] if members of as are all less than or equal to corresponding +-- members of bs +-- +-- [@as>=bs@] if members of as are all greater than or equal to corresponding +-- members of bs +-- +-- [otherwise] as and bs are unrelated +-- +-- The comparison is restricted to the common elements in the two lists. +-- +partCompareListPartOrd :: PartCompare a -> [a] -> [a] -> Maybe Ordering +partCompareListPartOrd cmp a1s b1s = pcomp a1s b1s EQ + where + pcomp (a:as) (b:bs) ordp = case cmp a b of + Just rel -> pcomp1 as bs rel ordp + _ -> Nothing + pcomp _ _ ordp = Just ordp + -- pcomp [] [] ordp = Just ordp + + pcomp1 as bs ordn EQ = pcomp as bs ordn + pcomp1 as bs EQ ordp = pcomp as bs ordp + pcomp1 as bs ordn ordp = + if ordn == ordp then pcomp as bs ordp else Nothing + +-- |Part-ordering comparison on lists of Ord values, where: +-- +-- [@as==bs@] if members of as are all equal to corresponding members of bs +-- +-- [@as<=bs@] if members of as are all less than or equal to corresponding +-- members of bs +-- +-- [@as>=bs@] if members of as are all greater than or equal to corresponding +-- members of bs +-- +-- [otherwise] as and bs are unrelated +-- +partCompareListOrd :: (Ord a) => [a] -> [a] -> Maybe Ordering +partCompareListOrd = partCompareListPartOrd (Just `c2` compare) + where c2 = (.) . (.) + +-- |Part-ordering comparison for Maybe values. +partCompareMaybe :: (Eq a) => Maybe a -> Maybe a -> Maybe Ordering +partCompareMaybe Nothing Nothing = Just EQ +partCompareMaybe (Just _) Nothing = Just GT +partCompareMaybe Nothing (Just _) = Just LT +partCompareMaybe (Just a) (Just b) = if a == b then Just EQ else Nothing + +-- |Part-ordering comparison on lists of Maybe values. +partCompareListMaybe :: (Eq a) => [Maybe a] -> [Maybe a] -> Maybe Ordering +partCompareListMaybe = partCompareListPartOrd partCompareMaybe + +-- |Part-ordering comparison on lists based on subset relationship +partCompareListSubset :: (Eq a) => [a] -> [a] -> Maybe Ordering +partCompareListSubset a b + | aeqvb = Just EQ + | asubb = Just LT + | bsuba = Just GT + | otherwise = Nothing + where + asubb = a `subset` b + bsuba = b `subset` a + aeqvb = asubb && bsuba + x `subset` y = and [ ma `elem` y | ma <- x ] + +------------------------------------------------------------ +-- Test cases +------------------------------------------------------------ + +{- + +notTrueFalse = Nothing :: Maybe Bool + +-- partCompareListOrd +test01 = partCompareListOrd [1,2,3] [1,2,3] == Just EQ +test02 = partCompareListOrd [1,2,3] [2,3,4] == Just LT +test03 = partCompareListOrd [1,2,4] [1,2,3] == Just GT +test04 = partCompareListOrd [1,2,3] [2,1,3] == Nothing + +-- partCompareMaybe +test11 = partCompareMaybe (Just True) (Just True) == Just EQ +test12 = partCompareMaybe (Just True) (Just False) == Nothing +test13 = partCompareMaybe notTrueFalse (Just False) == Just LT +test14 = partCompareMaybe (Just True) notTrueFalse == Just GT +test15 = partCompareMaybe notTrueFalse notTrueFalse == Just EQ + +-- partCompareListMaybe +test21 = partCompareListMaybe [Just True,Just False] + [Just True,Just False] + == Just EQ +test22 = partCompareListMaybe [Just True,Just False] + [Just True,Just True] + == Nothing +test23 = partCompareListMaybe [Just False,Just True] + [Just False,Just True] + == Just EQ +test24 = partCompareListMaybe [Nothing, Just True] + [Just False,Just True] + == Just LT +test25 = partCompareListMaybe [Just False,Just True] + [Just False,Nothing] + == Just GT +test26 = partCompareListMaybe [Nothing, Just True] + [Just False,Nothing] + == Nothing +test27 = partCompareListMaybe [Nothing,Just True] + [Nothing,Nothing] + == Just GT +test28 = partCompareListMaybe [notTrueFalse,notTrueFalse] + [notTrueFalse,notTrueFalse] + == Just EQ + +-- minima, maxima +test31a = maxima partCompareListMaybe ds1a == ds1b +test31b = minima partCompareListMaybe ds1a == ds1c +ds1a = + [ [Just 'a',Just 'b',Just 'c'] + , [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Nothing ,Nothing ] + ] +ds1b = + [ [Just 'a',Just 'b',Just 'c'] + ] +ds1c = + [ [Nothing ,Nothing ,Nothing ] + ] + +test32a = maxima partCompareListMaybe ds2a == ds2b +test32b = minima partCompareListMaybe ds2a == ds2c +ds2a = + [ [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + ] +ds2b = + [ [Just 'a',Just 'b',Nothing ] + , [Just 'a',Nothing ,Just 'c'] + , [Nothing ,Just 'b',Just 'c'] + ] +ds2c = + [ [Just 'a',Nothing ,Nothing ] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + ] + +test33a = maxima partCompareListMaybe ds3a == ds3b +test33b = minima partCompareListMaybe ds3a == ds3c +ds3a = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] +ds3b = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] +ds3c = + [ [Just "a1",Just "b1",Just "c1"] + , [Just "a2",Just "b2",Nothing ] + , [Just "a3",Nothing ,Just "c3"] + , [Just "a4",Nothing ,Nothing ] + , [Nothing ,Just "b5",Just "c5"] + , [Nothing ,Just "b6",Nothing ] + , [Nothing ,Nothing ,Just "c7"] + ] + + +test34a = maxima partCompareListMaybe ds4a == ds4b +test34b = minima partCompareListMaybe ds4a == ds4c +ds4a = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + ] +ds4b = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + ] +ds4c = + [ [Nothing,Nothing] + ] + +-- Check handling of equal values +test35a = maxima partCompareListMaybe ds5a == ds5b +test35b = minima partCompareListMaybe ds5a == ds5c +ds5a = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + , [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + , [Nothing,Nothing] + ] +ds5b = + [ [Just 1, Just 1 ] + , [Just 2, Nothing] + , [Nothing,Just 3 ] + ] +ds5c = + [ [Nothing,Nothing] + ] + +-- test case 32 with different ordering of values +test36a = maxima partCompareListMaybe ds6a == ds6b +test36b = minima partCompareListMaybe ds6a == ds6c +ds6a = + [ [Just 'a',Just 'b',Nothing ] + , [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Just 'a',Nothing ,Nothing ] + , [Just 'a',Nothing ,Just 'c'] + ] +ds6b = + [ [Just 'a',Just 'b',Nothing ] + , [Nothing ,Just 'b',Just 'c'] + , [Just 'a',Nothing ,Just 'c'] + ] +ds6c = + [ [Nothing ,Nothing ,Just 'c'] + , [Nothing ,Just 'b',Nothing ] + , [Just 'a',Nothing ,Nothing ] + ] + +test = and + [ test01, test02, test03, test04 + , test11, test12, test13, test14, test15 + , test21, test22, test23, test24, test25, test26, test27, test28 + , test31a, test31b, test32a, test32b, test33a, test33b + , test34a, test34b, test35a, test35b, test36a, test36b + ] + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/QName.hs b/Swish/Utils/QName.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/QName.hs @@ -0,0 +1,175 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : QName +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines an algebraic datatype for qualified names (QNames). +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.QName + ( QName(..) -- , maybeQnEq + , newQName, qnameFromPair, qnameFromURI + , getNamespace, getLocalName, getQNameURI + , splitURI + , qnameFromFilePath + ) +where + +import Data.Char (isAlpha, isAlphaNum) + +import System.Directory (canonicalizePath) +import System.FilePath (splitDirectories) +import Data.List (intercalate) + +------------------------------------------------------------ +-- Qualified name +------------------------------------------------------------ +-- +-- cf. http://www.w3.org/TR/REC-xml-names/ + +data QName = QName { qnNsuri, qnLocal :: String } + +newQName :: String -> String -> QName +newQName = QName + +qnameFromPair :: (String,String) -> QName +qnameFromPair (ns,ln) = QName ns ln + +qnameFromURI :: String -> QName +qnameFromURI = qnameFromPair . splitURI + +getNamespace :: QName -> String +getNamespace = qnNsuri + +getLocalName :: QName -> String +getLocalName = qnLocal + +getQNameURI :: QName -> String +getQNameURI (QName ns ln) = ns++ln + +instance Eq QName where + (==) = qnEq + +instance Ord QName where + (QName u1 l1) <= (QName u2 l2) = + if up1 /= up2 then up1 <= up2 else (ur1++l1) <= (ur2++l2) + where + n = min (length u1) (length u2) + (up1,ur1) = splitAt n u1 + (up2,ur2) = splitAt n u2 + +instance Show QName where + show (QName ns ln) = "<" ++ ns ++ ln ++ ">" + +-- Original used comparison of concatenated strings, +-- but that was very inefficient. This version does the +-- comparison without constructing new values +qnEq :: QName -> QName -> Bool +qnEq (QName n1 l1) (QName n2 l2) = qnEq1 n1 n2 l1 l2 + where + qnEq1 (c1:ns1) (c2:ns2) ln1 ln2 = c1==c2 && qnEq1 ns1 ns2 ln1 ln2 + qnEq1 [] ns2 ln1@(_:_) ln2 = qnEq1 ln1 ns2 [] ln2 + qnEq1 ns1 [] ln1 ln2@(_:_) = qnEq1 ns1 ln2 ln1 [] + qnEq1 [] [] [] [] = True + qnEq1 _ _ _ _ = False + +{- +-- Define equality of (Maybe QName) +maybeQnEq :: (Maybe QName) -> (Maybe QName) -> Bool +maybeQnEq Nothing Nothing = True +maybeQnEq (Just q1) (Just q2) = q1 == q2 +maybeQnEq _ _ = False +-} + +-- Separate URI string into namespace URI and local name +splitURI :: String -> ( String, String ) + -- 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/","") +splitURI qn = splitAt (scanURI qn (-1) 0) qn + +-- helper function for splitQName +-- Takes 3 arguments: +-- QName to scan +-- index of last name-start char, or (-1) +-- number of characters scanned so far +-- Returns index of start of name, or length of list +-- +scanURI :: String -> Int -> Int -> Int +scanURI (nextch:more) (-1) nc + | isNameStartChar nextch = scanURI more nc (nc+1) + | otherwise = scanURI more (-1) (nc+1) +scanURI (nextch:more) ns nc + | not (isNameChar nextch) = scanURI more (-1) (nc+1) + | otherwise = scanURI more ns (nc+1) +scanURI "" (-1) nc = nc +scanURI "" ns _ = ns + + + +-- Definitions here per XML namespaces, NCName production, +-- restricted to characters used in URIs. +-- cf. http://www.w3.org/TR/REC-xml-names/ + +isNameStartChar :: Char -> Bool +isNameStartChar c = isAlpha c || c == '_' + +isNameChar :: Char -> Bool +isNameChar c = isAlphaNum c || c `elem` ".-_" + +{-| +Convert a filepath to a file: URI stored in a QName. If the +input file path is relative then the working directory is used +to convert it into an absolute path. + +If the input represents a directory then it *must* end in +the directory separator - e.g. @\"\/foo\/bar\/\"@ rather than +@\"\/foo\/bar\"@ +for Posix systems. + +This has not been tested on Windows. +-} +qnameFromFilePath :: FilePath -> IO QName +qnameFromFilePath = fmap qnameFromURI . filePathToURI + +filePathToURI :: FilePath -> IO String +filePathToURI fname = do + ipath <- canonicalizePath fname + let paths = splitDirectories ipath + txt = intercalate "/" $ case paths of + "/":rs -> rs + _ -> paths + + return $ "file:///" ++ txt + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/ShowM.hs b/Swish/Utils/ShowM.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/ShowM.hs @@ -0,0 +1,83 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : ShowM +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines an extension of the Show class for displaying +-- multi-line values. It serves the following purposes: +-- +-- (1) provides a method with greater layout control of multiline values, +-- +-- (2) provides a possibility to override the default Show behaviour +-- for programs that use the extended ShowM interface, and +-- +-- (3) uses a ShowS intermediate value to avoid unnecessary +-- concatenation of long strings. +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.ShowM + ( ShowM(..), showm + ) +where + +------------------------------------------------------------ +-- ShowM framework +------------------------------------------------------------ + +-- |ShowM is a type class for values that may be formatted in +-- multi-line displays. +class (Show sh) => ShowM sh where + -- |Multi-line value display method + -- Create a multiline displayable form of a value, returned + -- as a 'ShowS' value. The default implementation behaves just + -- like a normal instance of 'Show'. + -- + -- This function is intended to allow the calling function some control + -- of multiline displays by providing: + -- + -- (1) the first line of the value is not preceded by any text, so + -- it may be appended to some preceding text on the same line, + -- + -- (2) the supplied line break string is used to separate lines of the + -- formatted text, and may include any desired indentation, and + -- + -- (3) no newline is output following the final line of text. + showms :: String -> sh -> ShowS + showms _ = shows + +-- |Return a string representation of a ShowM value. +showm :: (ShowM sh) => String -> sh -> String +showm linebreak val = showms linebreak val "" + + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/TraceHelpers.hs b/Swish/Utils/TraceHelpers.hs new file mode 100644 --- /dev/null +++ b/Swish/Utils/TraceHelpers.hs @@ -0,0 +1,58 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : TraceHelpers +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module provides access to tracing functions from the pre-2003 +-- Hugs trace module. Over time, it may accumulate other tracing +-- functions that I find useful. +-- +-- This should probably just be replaced by "Debug.Trace". +-- +-------------------------------------------------------------------------------- + +module Swish.Utils.TraceHelpers + ( trace, traceShow + ) +where + +import Debug.Trace + ( trace ) + +------------------------------------------------------------ +-- traceShow function from older Hugs trace module +------------------------------------------------------------ + +traceShow :: Show a => String -> a -> a +traceShow msg x = trace (msg ++ show x) x + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish.hs b/src/Swish.hs new file mode 100644 --- /dev/null +++ b/src/Swish.hs @@ -0,0 +1,90 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Swish +-- 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(ExitSuccess,ExitFailure), exitWith) + +import Control.Monad (unless) + +import System.IO (stderr, hPutStrLn) + +import Swish.RDF.SwishMain + +------------------------------------------------------------ +-- 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 >> exitWith 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 -> exitWith 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 +-- +-------------------------------------------------------------------------------- diff --git a/swish.cabal b/swish.cabal --- a/swish.cabal +++ b/swish.cabal @@ -1,12 +1,19 @@ -Name: swish -Version: 0.2.1 -License: LGPL -License-file: LICENSE -Author: Graham Klyne - GK@ninebynine.org -Maintainer: Vasili I Galchin (William Halchin) - vigalchin@gmail.com +Name: swish +Version: 0.3.0.0 +Stability: experimental +License: LGPL +License-file: LICENSE +Author: Graham Klyne - GK@ninebynine.org +Copyright: (c) 2003, 2004 G. Klyne; 2009 Vasili I Galchin; 2011 Doug Burke; All rights reserved. +Maintainer: dburke@cfa.harvard.edu +Category: Semantic Web +Synopsis: A semantic web toolkit. -Category: Semantic Web -Synopsis: A semantic web toolkit. +Tested-With: GHC==6.12.3 +Cabal-Version: >= 1.6 +Homepage: https://bitbucket.org/doug_burke/swish/wiki/Home +Bug-reports: https://bitbucket.org/doug_burke/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 @@ -14,347 +21,303 @@ 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". - + value declarations). It explores Haskell as \"a scripting + language for the Semantic Web\". + . Swish is a work-in-progress, and currently incorporates: - - * Notation3 input and output. + . + * 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. + . + Major Changes: + . + [Version 0.3.0.0] is an attempt to update + version 0.2.1 () + to build against + a recent ghc install, with some clean ups - including support for + the current N3 specification - and the addition of the + NTriples format. It has not been tested against ghc7. + . + References: + . + - + . + - + . + - CWM: + . - References +Build-Type: Simple +Data-Files: README - 1) http://www.ninebynine.org/RDFNotes/Swish/Intro.html +Source-repository head + type: mercurial + location: https://bitbucket.org/doug_burke/swish - 2) http://www.ninebynine.org/Software/swish-0.2.1.html +Flag tests + Description: Build the test programs. + Default: False -Tested-With: GHC>=6.8.2 -Build-Type: Simple -Data-Files: README +Flag hpc + Description: Use Hpc for the tests + Default: False -Cabal-Version: >= 1.2 Library - Build-Depends: base>3 && <4, binary, bytestring, containers, array, parallel, parsec, random, old-time, mtl, HUnit - Exposed-modules: Swish.HaskellRDF.BuiltInDatatypes, - Swish.HaskellRDF.BuiltInMap, - Swish.HaskellRDF.BuiltInRules, - Swish.HaskellRDF.ClassRestrictionRule, - Swish.HaskellRDF.Dfa.Dfa - Swish.HaskellRDF.Datatype, - Swish.HaskellRDF.GraphClass - Swish.HaskellRDF.GraphMatch, - Swish.HaskellRDF.GraphMem, - Swish.HaskellRDF.GraphPartition, - Swish.HaskellRDF.MapXsdInteger, - Swish.HaskellRDF.N3Formatter, - Swish.HaskellRDF.N3Parser, - Swish.HaskellRDF.ParsecLanguage, - -- YOH ADRIAN GHC EXTENSION?? Swish.HaskellRDF.OwlAbstractSyntax, - Swish.HaskellRDF.Proof, - Swish.HaskellRDF.RDFDatatype, - Swish.HaskellRDF.RDFDatatypeXsdInteger, - Swish.HaskellRDF.RDFDatatypeXsdString, - Swish.HaskellRDF.RDFGraph, - Swish.HaskellRDF.RDFGraphShowM, - Swish.HaskellRDF.RDFProofContext, - Swish.HaskellRDF.RDFProof, - Swish.HaskellRDF.RDFQuery, - Swish.HaskellRDF.RDFRuleset, - Swish.HaskellRDF.Ruleset - Swish.HaskellRDF.SwishCommands - Swish.HaskellRDF.SwishMain - Swish.HaskellRDF.SwishMonad - Swish.HaskellRDF.SwishScript - Swish.HaskellRDF.VarBinding - Swish.HaskellRDF.Vocabulary - Swish.HaskellRDF.Sort.AdaptiveHeapSort --- WNH Swish.HaskellRDF.Sort.Benchmark - Swish.HaskellRDF.Sort.BraunHeap - Swish.HaskellRDF.Sort.CartesianTree - Swish.HaskellRDF.Sort.DigitalSort - Swish.HaskellRDF.Sort.FingerSearchtree - Swish.HaskellRDF.Sort.Force - Swish.HaskellRDF.Sort.HeapSort --- WNH Swish.HaskellRDF.Sort.Killer - Swish.HaskellRDF.Sort.LibBase - Swish.HaskellRDF.Sort.ListLib --- WNH Swish.HaskellRDF.Sort.Main - Swish.HaskellRDF.Sort.MargeSort - Swish.HaskellRDF.Sort.MergeSort - Swish.HaskellRDF.Sort.PairingHeap --- WNH Swish.HaskellRDF.Sort.QuickSortInPlace - Swish.HaskellRDF.Sort.QuickSort --- WNH Swish.HaskellRDF.Sort.RandomLib --- Swish.HaskellRDF.Sort.RandomMonad - Swish.HaskellRDF.Sort.RedBlackTree - Swish.HaskellRDF.Sort.SplaySort - Swish.HaskellRDF.Sort.Squiggol - Swish.HaskellRDF.Sort.Stable --- WNH same prob QuickSortInPlace Swish.HaskellRDF.Sort.SuffixArrays --- WNH Swish.HaskellRDF.Sort.TestData - Swish.HaskellUtils.AccumulateM - Swish.HaskellUtils.DateTime - Swish.HaskellUtils.ErrorM - Swish.HaskellUtils.FunctorM - Swish.HaskellUtils.ListHelpers - Swish.HaskellUtils.LookupMap - Swish.HaskellUtils.MiscHelpers - Swish.HaskellUtils.Namespace - Swish.HaskellUtils.Parse - Swish.HaskellUtils.ParseURI - Swish.HaskellUtils.PartOrderedCollection - Swish.HaskellUtils.ProcessURI - Swish.HaskellUtils.QName --- COMEBCK!!!! Swish.HaskellUtils.RegexParser - Swish.HaskellUtils.ShowM - Swish.HaskellUtils.TestHelpers - Swish.HaskellUtils.TraceHelpers - Swish.HaskellUtils.Network.URI - - extensions: CPP, ParallelListComp - ghc-options: -Wall -fexcess-precision -funbox-strict-fields -auto-all + Build-Depends: + base >=3 && < 5, + binary == 0.5.*, + bytestring == 0.9.*, + containers == 0.3.*, + array == 0.3.*, + parallel == 2.2.*, + parsec == 2.1.*, + random == 1.0.*, + old-time == 1.0.*, + mtl >= 1 && < 3, + HUnit == 1.2.*, + network >= 2.2 && < 2.4, + directory >= 1.0 && <= 1.1, + filepath >= 1.1 && <= 1.2 + Exposed-Modules: + Swish.RDF.BuiltInDatatypes + Swish.RDF.BuiltInMap + Swish.RDF.BuiltInRules + Swish.RDF.ClassRestrictionRule + Swish.RDF.Datatype + Swish.RDF.GraphClass + Swish.RDF.GraphMatch + Swish.RDF.GraphMem + Swish.RDF.GraphPartition + Swish.RDF.MapXsdInteger + Swish.RDF.NTFormatter + Swish.RDF.NTParser + Swish.RDF.N3Formatter + Swish.RDF.N3Parser + Swish.RDF.Proof + Swish.RDF.RDFDatatype + Swish.RDF.RDFDatatypeXsdInteger + Swish.RDF.RDFDatatypeXsdString + Swish.RDF.RDFGraph + Swish.RDF.RDFGraphShowM + Swish.RDF.RDFParser + Swish.RDF.RDFProof + Swish.RDF.RDFProofContext + Swish.RDF.RDFQuery + Swish.RDF.RDFRuleset + Swish.RDF.RDFVarBinding + Swish.RDF.Rule + Swish.RDF.Ruleset + Swish.RDF.SwishCommands + Swish.RDF.SwishMain + Swish.RDF.SwishMonad + Swish.RDF.SwishScript + Swish.RDF.VarBinding + Swish.RDF.Vocabulary + Swish.Utils.DateTime + Swish.Utils.ListHelpers + Swish.Utils.LookupMap + Swish.Utils.MiscHelpers + Swish.Utils.Namespace + Swish.Utils.PartOrderedCollection + Swish.Utils.QName + Swish.Utils.ShowM + Swish.Utils.TraceHelpers + other-modules: + -- Paths_swish + ghc-options: + -Wall -fno-warn-orphans Executable BuiltInMapTest - Main-Is: Swish/HaskellRDF/BuiltInMapTest.hs - Other-Modules: Swish.HaskellRDF.BuiltInMap - Swish.HaskellRDF.RDFDatatypeXsdInteger - Swish.HaskellRDF.Ruleset - Swish.HaskellUtils.Namespace - Swish.HaskellRDF.Vocabulary - Swish.HaskellUtils.LookupMap - Swish.HaskellUtils.ListHelpers - - --- YOH ADRIAN QNAME ISSUES Executable ClassRestrictionRuleTest --- YOH ADRIAN QNAME ISSUES Main-Is: Swish/HaskellRDF/ClassRestrictionRuleTest.hs --- YOH ADRIAN QNAME ISSUES Other_Modules: Swish.HaskellRDF.ClassRestrictionRule --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.RDFGraph --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.RDFRuleset --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.Ruleset --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.Rule --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.RDFDatatype --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.Datatype --- YOH ADRIAN QNAME ISSUES Swish.HaskellUtils.Namespace --- YOH ADRIAN QNAME ISSUES Swish.HaskellRDF.Dfa + Main-Is: tests/BuiltInMapTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable GraphPartitionTest - Main-Is: Swish/HaskellRDF/GraphPartitionTest.hs - Other-Modules: Swish.HaskellRDF.GraphPartition - Swish.HaskellRDF.GraphClass - Swish.HaskellUtils.TestHelpers - Swish.HaskellUtils.ListHelpers + Main-Is: tests/GraphPartitionTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans + Executable GraphTest - Main-Is: Swish/HaskellRDF/GraphTest.hs - Other-Modules: Swish.HaskellUtils.ListHelpers - Swish.HaskellUtils.MiscHelpers - Swish.HaskellUtils.LookupMap - Swish.HaskellRDF.GraphClass - Swish.HaskellRDF.GraphMem - Swish.HaskellRDF.GraphMatch + Main-Is: tests/GraphTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans +Executable NTTest + Main-Is: tests/NTTest.hs + if !flag(tests) + buildable: False + + if flag(hpc) + ghc-options: -fhpc + + ghc-options: + -Wall -fno-warn-orphans + Executable N3ParserTest - Main-Is: Swish/HaskellRDF/N3ParserTest.hs - Other-Modules: Swish.HaskellRDF.N3Parser - Swish.HaskellRDF.RDFGraph - Swish.HaskellUtils.QName - Swish.HaskellRDF.Vocabulary - Swish.HaskellUtils.LookupMap - Swish.HaskellRDF.GraphClass + Main-Is: tests/N3ParserTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable N3FormatterTest - Main-Is: Swish/HaskellRDF/N3FormatterTest.hs - Other-Modules: Swish.HaskellRDF.N3Formatter - Swish.HaskellRDF.N3Parser - Swish.HaskellRDF.RDFGraph - Swish.HaskellUtils.Namespace - Swish.HaskellRDF.Vocabulary - Swish.HaskellUtils.QName - Swish.HaskellUtils.LookupMap - Swish.HaskellRDF.GraphClass - Swish.HaskellUtils.ErrorM + Main-Is: tests/N3FormatterTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable RDFDatatypeXsdIntegerTest - Main-Is: Swish/HaskellRDF/RDFDatatypeXsdIntegerTest.hs - Other-Modules: Swish.HaskellRDF.RDFDatatypeXsdInteger - Swish.HaskellRDF.RDFRuleset - Swish.HaskellRDF.RDFVarBinding - Swish.HaskellRDF.RDFDatatype - Swish.HaskellRDF.RDFGraph - Swish.HaskellRDF.ClassRestrictionRule - Swish.HaskellRDF.MapXsdInteger - Swish.HaskellRDF.Datatype - Swish.HaskellRDF.Ruleset - Swish.HaskellRDF.Rule - Swish.HaskellUtils.Namespace - Swish.HaskellRDF.Vocabulary - Swish.HaskellRDF.VarBinding + Main-Is: tests/RDFDatatypeXsdIntegerTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable RDFGraphTest - Main-Is: Swish/HaskellRDF/RDFGraphTest.hs - Other-Modules: Swish.HaskellUtils.FunctorM - Swish.HaskellUtils.LookupMap - Swish.HaskellUtils.ListHelpers - Swish.HaskellRDF.GraphClass - Swish.HaskellUtils.Namespace - Swish.HaskellUtils.QName - Swish.HaskellRDF.RDFGraph - Swish.HaskellRDF.Vocabulary + Main-Is: tests/RDFGraphTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable RDFProofContextTest - Main-Is: Swish/HaskellRDF/RDFProofContextTest.hs - Other-Modules: Swish.HaskellRDF.BuiltInMap - Swish.HaskellRDF.RDFProofContext - Swish.HaskellRDF.RDFProof - Swish.HaskellRDF.RDFRuleset - Swish.HaskellRDF.RDFGraph - Swish.HaskellRDF.RDFGraphShowM - Swish.HaskellRDF.Proof - Swish.HaskellRDF.Ruleset - Swish.HaskellRDF.Rule - Swish.HaskellUtils.Namespace - Swish.HaskellUtils.LookupMap - Swish.HaskellRDF.Vocabulary + Main-Is: tests/RDFProofContextTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans -Executable RDFProofText - Main-Is: Swish/HaskellRDF/RDFProofTest.hs - Other-Modules: Swish.HaskellRDF.RDFProof - Swish.HaskellRDF.RDFQuery - Swish.HaskellRDF.RDFVarBinding - Swish.HaskellRDF.RDFRuleset - Swish.HaskellRDF.RDFGraph - Swish.HaskellRDF.VarBinding - Swish.HaskellRDF.Rule - Swish.HaskellUtils.Namespace +Executable RDFProofTest + Main-Is: tests/RDFProofTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable RDFQueryTest - Main-Is: Swish/HaskellRDF/RDFQueryTest.hs - Other-Modules: Swish.HaskellRDF.RDFQuery - Swish.HaskellRDF.RDFVarBinding - Swish.HaskellRDF.RDFGraph - Swish.HaskellUtils.Namespace - Swish.HaskellRDF.Vocabulary - Swish.HaskellRDF.N3Parser - Swish.HaskellUtils.QName - Swish.HaskellUtils.ListHelpers - Swish.HaskellUtils.ErrorM + Main-Is: tests/RDFQueryTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable RDFRulesetTest - Main-Is: Swish/HaskellRDF/RDFRulesetTest.hs - Other-Modules: Swish.HaskellRDF.RDFRuleset - Swish.HaskellRDF.RDFQuery - Swish.HaskellRDF.RDFVarBinding - Swish.HaskellRDF.RDFGraph - Swish.HaskellRDF.Ruleset - Swish.HaskellRDF.Rule - Swish.HaskellUtils.Namespace - Swish.HaskellRDF.Vocabulary - Swish.HaskellUtils.QName + Main-Is: tests/RDFRulesetTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable VarBindingTest - Main-Is: Swish/HaskellRDF/VarBindingTest.hs - Other-Modules: Swish.HaskellRDF.VarBinding - Swish.HaskellRDF.Vocabulary - Swish.HaskellUtils.ListHelpers + Main-Is: tests/VarBindingTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable LookupMapTest - Main-Is: Swish/HaskellUtils/LookupMapTest.hs - Other-Modules: Swish.HaskellUtils.LookupMap - Swish.HaskellUtils.ListHelpers - - - -Executable ParseTest - Main-Is: Swish/HaskellUtils/ParseTest.hs - Other-Modules: Swish.HaskellUtils.Parse - - - -Executable ParseURITest - Main-Is: Swish/HaskellUtils/ParseURITest.hs - Other-Modules: Swish.HaskellUtils.ParseURITest - Swish.HaskellUtils.Parse + Main-Is: tests/LookupMapTest.hs + if !flag(tests) + buildable: False + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans Executable QNameTest - Main-Is: Swish/HaskellUtils/QNameTest.hs - Other-Modules: Swish.HaskellUtils.QName - - - -Executable URITest - Main-Is: Swish/HaskellUtils/URITest.hs - Other-Modules: Swish.HaskellUtils.Parse - Swish.HaskellUtils.ProcessURI - - - -Executable SwishTest - Main-Is: Swish/HaskellRDF/SwishTest.hs - Other-Modules: Swish.HaskellRDF.SwishMain - - + Main-Is: tests/QNameTest.hs + if !flag(tests) + buildable: False - Executable SwishTestAll - Main-Is: Swish/HaskellRDF/SwishTestAll.hs - Other-Modules: Swish.HaskellUtils.DateTimeTest - Swish.HaskellUtils.ParseTest - Swish.HaskellUtils.LookupMapTest - Swish.HaskellUtils.NamespaceTest - Swish.HaskellUtils.URITest - Swish.HaskellUtils.ParseURITest - Swish.HaskellRDF.GraphTest - Swish.HaskellRDF.VarBindingTest - Swish.HaskellRDF.RDFGraphTest - Swish.HaskellRDF.RDFQueryTest - Swish.HaskellRDF.RDFProofTest - Swish.HaskellRDF.RDFRulesetTest - Swish.HaskellRDF.RDFProofContextTest - Swish.HaskellRDF.RDFDatatypeXsdIntegerTest - Swish.HaskellRDF.ClassRestrictionRuleTest - Swish.HaskellRDF.N3FormatterTest - Swish.HaskellRDF.N3ParserTest - Swish.HaskellRDF.BuiltInMapTest - Swish.HaskellRDF.SwishTest + if flag(hpc) + ghc-options: -fhpc + ghc-options: + -Wall -fno-warn-orphans + -- we do not have the data files to run this test + Executable SwishTest + Main-Is: tests/SwishTest.hs Executable Swish - Main-Is: Swish/HaskellRDF/Swish.hs - Other-Modules: Swish.HaskellRDF.SwishMain + Main-Is: src/Swish.hs + Other-Modules: Paths_swish + ghc-options: + -Wall -fno-warn-orphans diff --git a/tests/BuiltInMapTest.hs b/tests/BuiltInMapTest.hs new file mode 100644 --- /dev/null +++ b/tests/BuiltInMapTest.hs @@ -0,0 +1,288 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : BuiltInMapTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains test cases for accessing built-in variable +-- binding modifiers. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.BuiltInMap + ( findRDFOpenVarBindingModifier + , findRDFDatatype + , rdfRulesetMap + , allRulesets + ) + +import Swish.RDF.RDFDatatypeXsdInteger + ( typeNameXsdInteger, namespaceXsdInteger + ) + +import Swish.RDF.Ruleset + ( getMaybeContextAxiom + , getMaybeContextRule + ) + +import Swish.Utils.Namespace + ( ScopedName(..) ) + +import Swish.RDF.Vocabulary + ( swishName + , scopeRDF + , scopeRDFS + , scopeRDFD + , namespaceXsdType + ) + +import Swish.Utils.LookupMap + ( mapFindMaybe ) + +import Swish.Utils.ListHelpers + ( equiv ) + +import Test.HUnit + ( Test(TestCase,TestList) + , Assertion + , assertBool, assertEqual, assertFailure + , runTestTT, runTestText, putTextToHandle + ) + +import System.IO + ( IOMode(WriteMode) + , openFile, hClose + ) + +import Control.Monad (unless) +import Data.Maybe (isJust) + + +------------------------------------------------------------ +-- 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 bv = + TestCase ( assertBool ("test:"++lab) bv ) + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab a1 a2 = + TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) + +testElem :: (Eq a, Show a) => String -> a -> [a] -> Test +testElem lab a1 as = + TestCase ( assertMember ("testElem:"++lab) a1 as ) + +testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test +testLe lab eq a1 a2 = + TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) + +-- Test for Just x or Nothing + +testJust :: String -> Maybe a -> Test +testJust lab av = + TestCase ( assertBool ("testJust:"++lab) (isJust av) ) + +testNothing :: String -> Maybe a -> Test +testNothing lab av = + TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) + +-- Compare lists and lists of lists and Maybe lists for set equivalence: + +data ListTest a = ListTest [a] + +instance (Eq a) => Eq (ListTest a) where + (ListTest a1) == (ListTest a2) = a1 `equiv` a2 + +instance (Show a) => Show (ListTest a) where + show (ListTest a) = show a + +data MaybeListTest a = MaybeListTest (Maybe [a]) + +instance (Eq a) => Eq (MaybeListTest a) where + MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 + MaybeListTest Nothing == MaybeListTest Nothing = True + _ == _ = False + +instance (Show a) => Show (MaybeListTest a) where + show (MaybeListTest a) = show a + +testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testEqv lab a1 a2 = + TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) + +testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test +testEqvEqv lab a1 a2 = + TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest $ map ListTest a1 + ma2 = ListTest $ map ListTest a2 + +testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test +testHasEqv lab a1 a2 = + TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest a1 + ma2 = map ListTest a2 + +testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test +testMaybeEqv lab a1 a2 = + TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) + where + ma1 = (MaybeListTest a1) + ma2 = (MaybeListTest a2) + +------------------------------------------------------------ +-- 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 (ScopedName namespaceXsdInteger "abs") +testVarMod06 = testJust "testVarMod06" $ + findRDFOpenVarBindingModifier (ScopedName namespaceXsdInteger "divmod") +testVarMod07 = testJust "testVarMod07" $ + findRDFOpenVarBindingModifier (ScopedName namespaceXsdInteger "ge") + +testVarModSuite :: Test +testVarModSuite = TestList + [ testVarMod01, testVarMod02, testVarMod03, testVarMod04 + , testVarMod05, testVarMod06, testVarMod07 + ] + +------------------------------------------------------------ +-- 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" $ + mapFindMaybe scopeRDF rdfRulesetMap + +testRulesetSuite :: Test +testRulesetSuite = TestList + [ testRuleset01 + ] + +------------------------------------------------------------ +-- Test finding arbitrary axioms and rules +------------------------------------------------------------ + +testFindAxiom01, testFindAxiom02, testFindAxiom03 :: Test + +testFindAxiom01 = testJust "testFindAxiom01" $ + getMaybeContextAxiom (ScopedName scopeRDF "a1") allRulesets +testFindAxiom02 = testJust "testFindAxiom02" $ + getMaybeContextAxiom (ScopedName scopeRDFS "a01") allRulesets +testFindAxiom03 = testJust "testFindAxiom03" $ + getMaybeContextAxiom (ScopedName (namespaceXsdType "integer") "dt") + allRulesets + +testFindAxiomSuite :: Test +testFindAxiomSuite = TestList + [ testFindAxiom01, testFindAxiom02, testFindAxiom03 + ] + +testFindRule01, testFindRule02, testFindRule03, testFindRule04 :: Test + +testFindRule01 = testJust "testFindRule01" $ + getMaybeContextRule (ScopedName scopeRDF "r1") allRulesets +testFindRule02 = testJust "testFindRule02" $ + getMaybeContextRule (ScopedName scopeRDFS "r1") allRulesets +testFindRule03 = testJust "testFindRule03" $ + getMaybeContextRule (ScopedName scopeRDFD "r1") allRulesets +testFindRule04 = testJust "testFindRule04" $ + getMaybeContextRule (ScopedName (namespaceXsdType "integer") "Abs") + allRulesets + +testFindRuleSuite :: Test +testFindRuleSuite = TestList + [ testFindRule01, testFindRule02, testFindRule03, testFindRule04 + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testVarModSuite + , testDatatypeSuite + , testRulesetSuite + , testFindAxiomSuite + , testFindRuleSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +runTestFile :: Test -> IO () +runTestFile t = do + h <- openFile "a.tmp" WriteMode + _ <- runTestText (putTextToHandle h False) t + hClose h + +{- +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/GraphPartitionTest.hs b/tests/GraphPartitionTest.hs new file mode 100644 --- /dev/null +++ b/tests/GraphPartitionTest.hs @@ -0,0 +1,574 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphPartitionTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains test cases for graph partitioning logic. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.GraphPartition + ( PartitionedGraph(..), getArcs + , GraphPartition(..), node + , partitionGraph, comparePartitions + ) + +import Swish.RDF.GraphClass (Arc(..)) + +import Swish.RDF.GraphMem (LabelMem(..)) + +import Swish.Utils.ListHelpers (equiv) + +import Test.HUnit (Test(TestCase, TestList), + assertEqual, assertBool, + runTestTT) + +------------------------------------------------------------ +-- Test case helpers +------------------------------------------------------------ + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab a1 a2 = + TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) + +testNe :: (Eq a, Show a) => String -> a -> a -> Test +testNe lab a1 a2 = + TestCase ( assertBool ("testNe:"++lab) (a1 /= a2) ) + +-- Compare lists and lists of lists and Maybe lists for set equivalence: + +data ListTest a = ListTest [a] + +instance (Eq a) => Eq (ListTest a) where + (ListTest a1) == (ListTest a2) = a1 `equiv` a2 + +instance (Show a) => Show (ListTest a) where + show (ListTest a) = show a + +data MaybeListTest a = MaybeListTest (Maybe [a]) + +instance (Eq a) => Eq (MaybeListTest a) where + MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 + MaybeListTest Nothing == MaybeListTest Nothing = True + _ == _ = False + +instance (Show a) => Show (MaybeListTest a) where + show (MaybeListTest a) = show a + +testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testEqv lab a1 a2 = + TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) + +testNotEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testNotEqv lab a1 a2 = + TestCase ( assertBool ("testEqv:"++lab) (ListTest a1 /= ListTest a2) ) + +------------------------------------------------------------ +-- 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 ] + +p11, p12, p13, p14, p15 :: GraphPartition LabelMem + +p11 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] +p12 = PartSub (LF "s2") [ (LF "p21",PartObj (LF "o21")) + , (LF "p22",PartObj (LF "o22")) + ] +p13 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) + , (LF "p32",p12) + , (LF "p33",PartObj (LF "s3")) + ] +p14 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "s3")) + , (LF "p32",p12) + ] +p15 = PartSub (LF "s3") [ (LF "p31",PartObj (LF "o31")) + , (LF "p32",PartObj (LF "s2")) + , (LF "p33",PartObj (LF "s3")) + ] + +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 = PartSub (LF "s1") [ (LF "p",PartObj (LF "o11")) ] +ps2f = PartSub (LF "s2") [ (LF "p1",PartObj (LF "o21")) + , (LF "p2",PartObj (LF "o22")) + ] +ps2r = PartSub (LF "s2") [ (LF "p2",PartObj (LF "o22")) + , (LF "p1",PartObj (LF "o21")) + ] +pb3f = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + ] +pb3r = PartSub (LV "b3") [ (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] + +pb3af = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",pb4af) + ] +pb3ar = PartSub (LV "b3") [ (LF "p",pb4ar) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] +pb4af = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + ] +pb4ar = PartSub (LV "b4") [ (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + ] + +pb5a1, pb5b1, pb5c1 :: GraphPartition LabelMem + +pb5a1 = PartSub (LV "b5a") [ (LF "p",pb5b1) ] +pb5b1 = PartSub (LV "b5b") [ (LF "p",pb5c1) ] +pb5c1 = PartSub (LV "b5c") [ (LF "p",PartObj (LV "b5a")) ] + +pb3bf, pb3br, pb4bf, pb4br :: GraphPartition LabelMem + +pb3bf = PartSub (LV "b3") [ (LF "p",PartObj (LF "o31")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",pb4bf) + ] +pb3br = PartSub (LV "b3") [ (LF "p",pb4br) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LF "o31")) + ] +pb4bf = PartSub (LV "b4") [ (LF "p",PartObj (LF "s2")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LV "b5b")) + ] +pb4br = PartSub (LV "b4") [ (LF "p",PartObj (LV "b5b")) + , (LF "p",PartObj (LV "b3")) + , (LF "p",PartObj (LF "s2")) + ] + +pb5a2, pb5b2, pb5c2 :: GraphPartition LabelMem + +pb5a2 = PartSub (LV "b5a") [ (LF "p",PartObj (LV "b5b")) ] +pb5b2 = PartSub (LV "b5b") [ (LF "p",pb5c2) ] +pb5c2 = PartSub (LV "b5c") [ (LF "p",pb5a2) ] + +pb5a3, pb5b3, pb5c3 :: GraphPartition LabelMem + +pb5a3 = PartSub (LV "b5a") [ (LF "p",pb5b3) ] +pb5b3 = PartSub (LV "b5b") [ (LF "p",PartObj (LV "b5c")) ] +pb5c3 = PartSub (LV "b5c") [ (LF "p",pb5a3) ] + +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 $ PartSub (LV "b3") [(LF "p",pb4af)])] + (comparePartitions pp3f pp4f) +testPartition58 = testEqv "testPartition58" + [(Nothing,Just pb5a1)] + (comparePartitions pp4f pp5f) +testPartition59 = testEqv "testPartition59" + [(Nothing,Just $ PartSub (LV "b4") [(LF "p",PartObj (LV "b5b"))])] + (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 = PartSub (LF "s1") [ (LF "p11",PartObj (LF "o11")) ] +c12a = PartSub (LF "s2") [ (LF "p21",c13a) + , (LF "p22",PartObj (LF "o22")) + ] +c12b = PartSub (LF "s2") [ (LF "p22",PartObj (LF "o22")) + , (LF "p21",c13b) + ] +c13a = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "o33a")) + ] +c13b = PartSub (LV "b3") [ (LF "p31",PartObj (LF "o31")) + , (LF "p33",PartObj (LF "o33b")) + ] + +testCompare01 :: Test +testCompare01 = testEqv "testCompare01" + [(Just (PartObj (LF "o33a")),Just (PartObj (LF "o33b")))] + (comparePartitions pgc1a pgc1b) + +testCompareSuite :: Test +testCompareSuite = TestList + [ testCompare01 + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testBasicSuite + , testPartitionSuite + , testCompareSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/GraphTest.hs b/tests/GraphTest.hs new file mode 100644 --- /dev/null +++ b/tests/GraphTest.hs @@ -0,0 +1,1805 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : GraphTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines test cases for module Graph. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Test.HUnit + ( Test(TestCase,TestList,TestLabel), + assertEqual, runTestTT ) +import Data.List( elemIndex ) +import Data.Maybe( fromJust ) + +import Swish.Utils.ListHelpers +import Swish.Utils.MiscHelpers +import Swish.RDF.GraphClass (Arc(..), LDGraph(..), + Label(..), + arcFromTriple,arcToTriple) +import Swish.RDF.GraphMem +import Swish.RDF.GraphMatch + ( LabelMap, GenLabelMap(..), LabelEntry, + EquivalenceClass, + ScopedLabel(..), makeScopedLabel, makeScopedArc, + LabelIndex, nullLabelVal, emptyMap, + mapLabelIndex, {-mapLabelList,-} setLabelHash, newLabelMap, + graphLabels, assignLabelMap, newGenerationMap, + graphMatch1, equivalenceClasses + ) +import Swish.Utils.LookupMap + ( LookupEntryClass(..), makeLookupMap + , mapSortByVal + ) + +default ( Int ) + +------------------------------------------------------------ +-- Define some common values +------------------------------------------------------------ + +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 lists of triples +------------------------------------------------------------ + +setArcsT :: (Swish.RDF.GraphClass.LDGraph lg lb) => + [(lb, lb, lb)] -> lg lb -> lg lb +setArcsT a = setArcs $ map arcFromTriple a + +getArcsT :: (Swish.RDF.GraphClass.LDGraph lg lb) => + lg lb -> [(lb, lb, lb)] +getArcsT g = map arcToTriple $ getArcs g + +toStatement :: a -> a -> a -> Arc a +toStatement s p o = Arc s p o + +------------------------------------------------------------ +-- Test class helper +------------------------------------------------------------ + +testeq :: (Show a, Eq a) => String -> a -> a -> Test +testeq lab req got = + TestCase ( assertEqual ("test"++lab) req got ) + +testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test +testeqv lab req got = + TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) + +------------------------------------------------------------ +-- Label map and entry creation helpers +------------------------------------------------------------ + +tstLabelMap :: (Label lb) => Int -> [(lb,LabelIndex)] -> LabelMap lb +tstLabelMap gen lvs = LabelMap gen (makeLookupMap $ makeEntries lvs) + +makeEntries :: (Label lb) => [(lb,LabelIndex)] -> [LabelEntry lb] +makeEntries lvs = map newEntry lvs + +labelMapSortByVal :: (Label lb) => LabelMap lb -> LabelMap lb +labelMapSortByVal (LabelMap gen lm) = LabelMap gen (mapSortByVal lm) + +------------------------------------------------------------ +-- Graph helper function tests +------------------------------------------------------------ + +-- select + +testSelect :: String -> [Char] -> [Char] -> 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] ['a','b','c','a','b','c']) + ['b','b'] +testSelect02 = testSelect "02" + (select isOne [1,1,1,1,1,1] ['a','b','c','a','b','c']) + ['a','b','c','a','b','c'] +testSelect03 = testSelect "03" + (select isOne [0,0,0,0,0,0] ['a','b','c','a','b','c']) + [] +testSelect04 = testSelect "04" + (select isOne [] [] ) + [] + +testSelectSuite :: Test +testSelectSuite = TestList + [ + testSelect01, testSelect02, testSelect03, testSelect04 + ] + +-- mapset + +mf :: Int -> Char +mf n = "_abcde" !! n + +testMapset :: String -> [Int] -> [Char] -> Test +testMapset lab l1s l2s = testeq ("Mapset"++lab ) l2s (mapset mf l1s) + +testMapsetSuite :: Test +testMapsetSuite = TestList + [ testMapset "01" [0,1,2,3,4,5] ['_','a','b','c','d','e'] + , testMapset "02" [1,1,3,3,5,5] ['a','c','e'] + , testMapset "03" [5,4,3,2,1,0] ['e','d','c','b','a','_'] + , testMapset "04" [] [] + , testMapset "05" [1,2,3,4,5,0] ['a','b','c','d','e','_'] + ] + +-- subset + +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] [] + ] + +-- hash + +testHash :: String -> Bool -> Int -> Int -> Test +testHash lab eq h1 h2 = testeq ("Hash"++lab ) eq (h1 == h2) + +testHashEq :: String -> Int -> Int -> Test +testHashEq lab h1 h2 = testeq ("Hash"++lab ) h1 h2 + +testHashSuite :: Test +testHashSuite = TestList + [ testHash "01" True (hash 0 base1) (hash 0 base1) + , testHash "02" True (hash 2 "") (hash 2 "") + , testHash "03" False (hash 3 base1) (hash 3 base2) + , testHash "04" False (hash 4 base1) (hash 5 base1) + , testHash "05" False (hash 2 "") (hash 3 "") + , testHashEq "06" 1424775 (hash 3 base1) + , testHashEq "07" 11801303 (hash 3 base2) + ] + +------------------------------------------------------------ +-- 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) + + , testeq "Lab05" 3436883 (labelHash 1 lab1f) + , testeq "Lab06" 10955600 (labelHash 1 lab1v) + , testeq "Lab07" 3436884 (labelHash 1 lab2f) + , testeq "Lab08" 10955601 (labelHash 1 lab2v) + + , 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" + +gr1 :: GraphMem LabelMem +gr1 = GraphMem { arcs=[]::[Arc LabelMem] } + +ga1 :: [(LabelMem, LabelMem, LabelMem)] +ga1 = + [ + (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 :: Arc LabelMem -> Bool +gs4 (Arc _ _ (LV "lab2")) = True +gs4 (Arc _ _ _ ) = False + +ga4 :: [(LabelMem, LabelMem, LabelMem)] +ga4 = + [ + (lab2v,lab2v,lab2v), + (lab1f,lab1f,lab2v), + (lab1v,lab1v,lab2v), + (lab1f,lab1v,lab2v), + (lab1v,lab2f,lab2v) + ] + +gr2 :: GraphMem LabelMem +gr2 = GraphMem { arcs=[]::[Arc LabelMem] } + +ga2 :: [(LabelMem, LabelMem, LabelMem)] +ga2 = + [ + (lab1f,lab1f,lab1f), + (lab1v,lab1v,lab1v), + (lab2f,lab2f,lab2f), + (lab2v,lab2v,lab2v) + ] + +gr3 :: GraphMem LabelMem +gr3 = GraphMem { arcs=[]::[Arc LabelMem] } + +ga3 :: [(LabelMem, LabelMem, LabelMem)] +ga3 = + [ + (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 :: [LabelMem] +gl4 = [lab1f,lab1v,lab2f,lab2v] + +gr1a, gr2a, gr3a, gr4a, gr4b, gr4c, gr4d, gr4e, + gr4g :: GraphMem LabelMem +gr1a = setArcsT ga1 gr1 +gr2a = setArcsT ga2 gr2 +gr3a = setArcsT ga3 gr3 +gr4a = add gr2a gr3a +gr4b = add gr3a gr2a +gr4c = delete gr2a gr4a +gr4d = delete gr3a gr4a +gr4e = extract gs4 gr4a +gr4g = add gr2a gr4a + +gl4f :: [LabelMem] +gl4f = labels gr4a + +gr4ee :: [Bool] +gr4ee = map gs4 (getArcs gr4a) + +testGraphSuite :: Test +testGraphSuite = TestList + [ testeq "Graph01" ga1 (getArcsT gr1a) + , testeq "Graph01" ga2 (getArcsT gr2a) + , testeq "Graph03" ga3 (getArcsT gr3a) + , testeqv "Graph04" ga1 (getArcsT gr4a) + , testeqv "Graph05" ga1 (getArcsT gr4b) + , testeqv "Graph06" ga3 (getArcsT gr4c) + , testeqv "Graph07" ga2 (getArcsT gr4d) + , testeqv "Graph08" ga4 (getArcsT gr4e) + , testeqv "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) (testEq a b) n1 n2 + | (a,n1) <- nodelist , (b,n2) <- nodelist ] + where + testLab a b = a ++ "-" ++ b + testEq 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 + | testEq a b = EQ + | otherwise = compare (fromJust $ elemIndex a nodeorder) + (fromJust $ elemIndex b nodeorder) + testEq a b = (a == b) || + (a,b) `elem` nodeeqlist || + (b,a) `elem` nodeeqlist + + +------------------------------------------------------------ +-- Statement construction and equality tests +------------------------------------------------------------ + +type Statement = Arc LabelMem + +testStmtEq :: String -> Bool -> Statement -> Statement -> Test +testStmtEq lab eq t1 t2 = + TestCase ( assertEqual ("testStmtEq:"++lab) eq (t1==t2) ) + +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, Arc LabelMem)] +tlist = + [ (lab s p o,trp s p o) | s <- slist, p <- plist, o <- olist ] + where + lab (s,_) (p,_) (o,_) = 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 (testLab a b) (testEq a b) t1 t2 + | (a,t1) <- tlist , (b,t2) <- tlist ] + where + testLab a b = a ++ "-" ++ b + testEq 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"++ + " !s1:(1,1)\n"++ + " !s2:(2,2)\n"++ + " !s3:(3,3)\n"++ + " !:(4,4)\n"++ + " !o1:(1,1)\n"++ + " !o2:(2,2)\n"++ + " !o3:(3,3)" + +testMapLabelHash00 :: Test +testMapLabelHash00 = testeq "mapLabelHash00" showMap (show lmap1) + where + showMap = "LabelMap gen=5, map=\n"++ + " !s1:(1,1)\n"++ + " !s2:(5,22)\n"++ + " !s3:(3,3)\n"++ + " !:(4,4)\n"++ + " !o1:(1,1)\n"++ + " !o2:(2,2)\n"++ + " !o3:(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 :: Arc LabelMem +t01 = toStatement s1 p1 o1 +t02 = toStatement s2 p1 o2 +t03 = toStatement s3 p1 o3 +t04 = toStatement s1 p1 l1 +t05 = toStatement s2 p1 l4 +t06 = toStatement s3 p1 l10 + +t10, t11, t12 :: Arc LabelMem +t10 = toStatement s1 p1 b1 +t11 = toStatement b1 p2 b2 +t12 = toStatement b2 p3 o1 + +t20, t21, t22 :: Arc LabelMem +t20 = toStatement s1 p1 b3 +t21 = toStatement b3 p2 b4 +t22 = toStatement b4 p3 o1 + +as1, as2, as4, as5, as6 :: [Arc LabelMem] +as1 = [t01] +as2 = [t01,t02,t03,t04,t05,t06] +as4 = [t01,t02,t03,t04,t05,t06,t10,t11,t12] +as5 = [t01,t02,t03,t04,t05,t06,t20,t21,t22] +as6 = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] + +-- graphLabels :: (Label lb) => [Arc lb] -> [lb] + +ls4 :: [LabelMem] +ls4 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2] + +testGraphLabels04, testGraphLabels14 :: Test +testGraphLabels04 = testeqv "GraphLabels04" ls4 (graphLabels as4) +testGraphLabels14 = testeq "GraphLabels14" str (show (graphLabels as4)) + where + str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3]" + -- str = "[!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + +ls5 :: [LabelMem] +ls5 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b3,b4] + +testGraphLabels05, testGraphLabels15 :: Test +testGraphLabels05 = testeqv "GraphLabels05" ls5 (graphLabels as5) +testGraphLabels15 = testeq "GraphLabels15" str (show (graphLabels as5)) + where + str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b3,!p2,?b4,!p3]" + -- str = "[!p3,?b4,!p2,?b3,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + +ls6 :: [LabelMem] +ls6 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2,b3,b4] + +testGraphLabels06, testGraphLabels16 :: Test +testGraphLabels06 = testeqv "GraphLabels05" ls6 (graphLabels as6) +testGraphLabels16 = testeq "GraphLabels16" str (show (graphLabels as6)) + where + str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3"++ + ",!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3,?b3,?b4]" + -- str = "[?b4,?b3,!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1"++ + -- ",!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + +-- assignLabels :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb + +lmap5 :: LabelMap LabelMem +lmap5 = tstLabelMap 2 [(s1,(1,142577)),(s2,(1,142578)),(s3,(1,142579)), + (p1,(1,142385)),(p2,(1,142386)),(p3,(1,142387)), + (o1,(1,142321)),(o2,(1,142322)),(o3,(1,142323)), + (l1,(1,142129)),(l4,(1,1709580)),(l10,(1,3766582)), + (b3,(1,262143)),(b4,(1,262143))] + +testAssignLabelMap05 :: Test +testAssignLabelMap05 = testeq "AssignLabels05" lmap5 + (newGenerationMap $ assignLabelMap ls5 emptyMap) + +lmap6 :: LabelMap LabelMem +lmap6 = tstLabelMap 2 [(s1,(1,142577)),(s2,(1,142578)),(s3,(1,142579)), + (p1,(1,142385)),(p2,(1,142386)),(p3,(1,142387)), + (o1,(1,142321)),(o2,(1,142322)),(o3,(1,142323)), + (l1,(1,142129)),(l4,(1,1709580)),(l10,(1,3766582)), + (b1,(2,262143)),(b2,(2,262143)),(b3,(1,262143)),(b4,(1,262143))] + +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 + ] + +------------------------------------------------------------ +-- 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 :: [Arc (ScopedLabel LabelMem)] +as61 = map (makeScopedArc 1) as6 +as62 = map (makeScopedArc 2) as6 + +eq1lmap :: LabelMap (ScopedLabel LabelMem) +eq1lmap = newGenerationMap $ + assignLabelMap (graphLabels as62) $ + assignLabelMap (graphLabels as61) emptyMap + +eq1ltst :: LabelMap (ScopedLabel LabelMem) +eq1ltst = 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,(1,262143)),(b2_1,(1,262143)),(b3_1,(1,262143)),(b4_1,(1,262143)), + (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,(1,262143)),(b2_2,(1,262143)),(b3_2,(1,262143)),(b4_2,(1,262143)) + ] + +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 :: [Arc (ScopedLabel LabelMem)] +as41 = map (makeScopedArc 1) as4 +as42 = map (makeScopedArc 2) as4 + +eq2lmap :: LabelMap (ScopedLabel LabelMem) +eq2lmap = newGenerationMap $ + assignLabelMap (graphLabels as42) $ + assignLabelMap (graphLabels as41) emptyMap + +eq2ltst :: LabelMap (ScopedLabel LabelMem) +eq2ltst = 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,(1,262143)),(b2_1,(1,262143)), + (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,(1,262143)),(b2_2,(1,262143))] + +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 :: [Arc (ScopedLabel LabelMem)] +as11 = map (makeScopedArc 1) as1 +as22 = map (makeScopedArc 2) as2 + +eq3hs1, eq3hs2 :: [Arc (ScopedLabel LabelMem)] +eq3hs1 = [t01_1] +eq3hs2 = [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 + [ (s1_1,(1,142577)) + , (p1_1,(1,142385)) + , (o1_1,(1,142321)) + , (s1_2,(1,142577)), (s2_2,(1,142578)), (s3_2,(1,142579)) + , (p1_2,(1,142385)) + , (o1_2,(1,142321)), (o2_2,(1,142322)), (o3_2,(1,142323)) + , (l1_2,(1,142129)), (l4_2,(1,1709580)), (l10_2,(1,3766582)) + ] + +testEqAssignMap32 :: Test +testEqAssignMap32 = testeq "EqAssignMap32" eq3ltst eq3lmap + +type EquivClass = EquivalenceClass (ScopedLabel LabelMem) +type EquivArgs = ((Int, Int), [ScopedLabel LabelMem]) + +ec31 :: [EquivClass] +ec31 = equivalenceClasses eq3lmap (graphLabels as11) + +ec31test :: [EquivArgs] +ec31test = + [ ((1,142321),[o1_1]) + , ((1,142385),[p1_1]) + , ((1,142577),[s1_1]) + ] + +ec32 :: [EquivClass] +ec32 = equivalenceClasses eq3lmap (graphLabels as22) + +ec32test :: [EquivArgs] +ec32test = + [ ((1,142129),[l1_2]) + , ((1,142321),[o1_2]) + , ((1,142322),[o2_2]) + , ((1,142323),[o3_2]) + , ((1,142385),[p1_2]) + , ((1,142577),[s1_2]) + , ((1,142578),[s2_2]) + , ((1,142579),[s3_2]) + , ((1,1709580),[l4_2]) + , ((1,3766582),[l10_2]) + ] + +testEquivClass33_1, testEquivClass33_2 :: Test +testEquivClass33_1 = testeq "EquivClass33_1" ec31test ec31 +testEquivClass33_2 = testeq "EquivClass33_2" ec32test ec32 + +-- This value is nonsense for this test, +-- but a parameter is needed for graphMatch1 (below) + +ec3pairs :: [(EquivClass, EquivClass)] +ec3pairs = zip (pairSort ec31) (pairSort ec32) + +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]) ) + ] + +{- This is a pointless test in this case +testEquivClass33_3 = testeq "EquivClass33_3" ec3test ec3pairs +-} + +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 + +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 + -- , 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) ) + +g1, g2, g3, g4, g5, g6, g7, g8 :: GraphMem LabelMem +g1 = GraphMem { arcs = [t01] } +g2 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06] } +g3 = GraphMem { arcs = [t06,t05,t04,t03,t02,t01] } +g4 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12] } +g5 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t20,t21,t22] } +g6 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] } +g7 = GraphMem { arcs = [t01,t02] } +g8 = GraphMem { arcs = [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) (testEq ll1 ll2) gg1 gg2 + | (ll1,gg1) <- glist , (ll2,gg2) <- glist ] + where + testLab ll1 ll2 = ll1 ++ "-" ++ ll2 + testEq 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 :: Arc LabelMem +t10102 = toStatement v101 p101 v102 +t10203 = toStatement v102 p102 v103 +t10304 = toStatement v103 p103 v104 +t10405 = toStatement v104 p104 v105 +t10501 = toStatement v105 p105 v101 +t10106 = toStatement v101 p106 v106 +t10207 = toStatement v102 p107 v107 +t10308 = toStatement v103 p108 v108 +t10409 = toStatement v104 p109 v109 +t10510 = toStatement v105 p110 v110 +t10607 = toStatement v106 p111 v107 +t10708 = toStatement v107 p112 v108 +t10809 = toStatement v108 p113 v109 +t10910 = toStatement v109 p114 v110 +t11006 = toStatement 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 :: Arc LabelMem +t20102 = toStatement v201 p201 v202 +t20203 = toStatement v202 p202 v203 +t20304 = toStatement v203 p203 v204 +t20405 = toStatement v204 p204 v205 +t20501 = toStatement v205 p205 v201 +t20601 = toStatement v206 p206 v201 +t20702 = toStatement v207 p207 v202 +t20803 = toStatement v208 p208 v203 +t20904 = toStatement v209 p209 v204 +t21005 = toStatement v210 p210 v205 +t20607 = toStatement v206 p211 v207 +t20708 = toStatement v207 p212 v208 +t20809 = toStatement v208 p213 v209 +t20910 = toStatement v209 p214 v210 +t21006 = toStatement 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 :: Arc LabelMem +t30102 = toStatement v301 p301 v302 +t30203 = toStatement v302 p302 v303 +t30304 = toStatement v303 p303 v304 +t30405 = toStatement v304 p304 v305 +t30501 = toStatement v305 p305 v301 +t30106 = toStatement v301 p306 v306 +t30207 = toStatement v302 p307 v307 +t30308 = toStatement v303 p308 v308 +t30409 = toStatement v304 p309 v309 +t30510 = toStatement v305 p310 v310 +t30608 = toStatement v306 p311 v308 +t30709 = toStatement v307 p312 v309 +t30810 = toStatement v308 p313 v310 +t30906 = toStatement v309 p314 v306 +t31007 = toStatement 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:: Arc LabelMem +t40102 = toStatement v401 p401 v402 +t40203 = toStatement v402 p402 v403 +t40304 = toStatement v403 p403 v404 +t40405 = toStatement v404 p404 v405 +t40501 = toStatement v405 p405 v401 +t40106 = toStatement v401 p406 v406 +t40207 = toStatement v402 p407 v407 +t40308 = toStatement v403 p408 v408 +t40409 = toStatement v404 p409 v409 +t40510 = toStatement v405 p410 v410 +t41009 = toStatement v410 p411 v409 +t40908 = toStatement v409 p412 v408 +t40807 = toStatement v408 p413 v407 +t40706 = toStatement v407 p414 v406 +t40610 = toStatement 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 :: Arc LabelMem +t50102 = toStatement v101 p5 v102 +t50203 = toStatement v102 p5 v103 +t50304 = toStatement v103 p5 v104 +t50405 = toStatement v104 p5 v105 +t50501 = toStatement v105 p5 v101 +t50106 = toStatement v101 p5 v106 +t50207 = toStatement v102 p5 v107 +t50308 = toStatement v103 p5 v108 +t50409 = toStatement v104 p5 v109 +t50510 = toStatement v105 p5 v110 +t50607 = toStatement v106 p5 v107 +t50708 = toStatement v107 p5 v108 +t50809 = toStatement v108 p5 v109 +t50910 = toStatement v109 p5 v110 +t51006 = toStatement 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 :: Arc LabelMem +t60102 = toStatement v201 p5 v202 +t60203 = toStatement v202 p5 v203 +t60304 = toStatement v203 p5 v204 +t60405 = toStatement v204 p5 v205 +t60501 = toStatement v205 p5 v201 +t60106 = toStatement v201 p5 v206 +t60207 = toStatement v202 p5 v207 +t60308 = toStatement v203 p5 v208 +t60409 = toStatement v204 p5 v209 +t60510 = toStatement v205 p5 v210 +t60607 = toStatement v206 p5 v207 +t60708 = toStatement v207 p5 v208 +t60809 = toStatement v208 p5 v209 +t60910 = toStatement v209 p5 v210 +t61006 = toStatement v210 p5 v206 + +-- + +arcsToGraph :: [Arc a] -> GraphMem a +arcsToGraph as = GraphMem { arcs = 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 :: Arc LabelMem +t10901 = toStatement 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 :: Arc LabelMem +t20201 = toStatement 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 :: Arc LabelMem +f10102 = toStatement v101 f01 v102 +f10501 = toStatement v105 f01 v101 +f21006 = toStatement v210 f01 v206 +f20510 = toStatement 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 :: Arc LabelMem +f10203 = toStatement v102 f01 v103 +f10405 = toStatement v104 f01 v105 +f20910 = toStatement v209 f01 v210 +f20601 = toStatement 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 :: Arc LabelMem +g10203 = toStatement v102 f02 v103 +g10102 = toStatement v101 f02 v102 +g10405 = toStatement 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 :: Test +allTests = TestList + [ testSelectSuite + , testMapsetSuite + , testSubsetSuite + , testHashSuite + , testLabSuite + , testGraphSuite + , testLabelEqSuite + , testLabelOrdSuite + , testStmtEqSuite + , testLabelMapSuite + , testGraphMatchSupportSuite + , testGraphMatchStepSuite + , testGraphEqSuitePart + , testGraphEqSuite + , testGraphEqSuiteMore + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +geq = testGraphEqSuite +geq1 = testGraphEqSuiteMore +ttmore = tt testGraphEqSuiteMore -- this test may take a long time +tfmore = tf testGraphEqSuiteMore +ttstep = tt testGraphMatchStepSuite +tfstep = tf testGraphMatchStepSuite + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/LookupMapTest.hs b/tests/LookupMapTest.hs new file mode 100644 --- /dev/null +++ b/tests/LookupMapTest.hs @@ -0,0 +1,491 @@ +{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : LookupMapTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : FlexibleInstances, FlexibleContexts, MultiParamTypeClasses +-- +-- This Module defines test cases for module Parse parsing functions. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.Utils.LookupMap + ( LookupEntryClass(..), LookupMap(..) + , makeLookupMap + , reverseLookupMap + , mapFind, mapContains + , mapReplace, mapReplaceOrAdd, mapReplaceAll, mapReplaceMap + , mapAdd, mapAddIfNew + , mapDelete, mapDeleteAll + , mapApplyToAll, mapTranslate + , mapEq, mapKeys, mapVals + , mapSelect, mapMerge + , mapTranslateKeys, mapTranslateVals + , mapTranslateEntries, mapTranslateEntriesM + ) + +import Swish.Utils.ListHelpers + ( equiv ) + +import Data.List ( sort ) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertEqual, runTestTT ) + +------------------------------------------------------------ +-- Declare lookup entry for testing +------------------------------------------------------------ + +data GenMapEntry a b = E a b + +instance (Eq a, Show a, Eq b, Show b) + => LookupEntryClass (GenMapEntry a b) a b + where + keyVal (E k v) = (k,v) + newEntry (k,v) = (E k v) + +instance (Eq a, Show a, Eq b, Show b) => Show (GenMapEntry a b) where + show = entryShow + +instance (Eq a, Show a, Eq b, Show b) => Eq (GenMapEntry a b) where + (==) = entryEq + +type TestEntry = GenMapEntry Int String +type TestMap = LookupMap (GenMapEntry Int String) +type RevTestMap = LookupMap (GenMapEntry String Int) +type MayTestMap = Maybe RevTestMap +type StrTestMap = LookupMap (GenMapEntry String String) + +------------------------------------------------------------ +-- Test class helper +------------------------------------------------------------ + +testeq :: (Show a, Eq a) => String -> a -> a -> Test +testeq lab req got = + TestCase ( assertEqual ("test"++lab) req got ) + +testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test +testeqv lab req got = + TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) + +------------------------------------------------------------ +-- LookupMap functions +------------------------------------------------------------ + +newMap :: [(Int,String)] -> TestMap +newMap es = makeLookupMap (map newEntry es) + +testLookupMap :: String -> TestMap -> [(Int,String)] -> Test +testLookupMap lab m1 m2 = testeq ("LookupMap"++lab ) (newMap m2) m1 + +testLookupMapFind :: String -> TestMap -> Int -> String -> Test +testLookupMapFind lab lm k res = + testeq ("LookupMapFind"++lab ) res (mapFind "" k lm) + +lm00, lm01, lm02, lm03, lm04, lm05, lm06, lm07, lm08, lm09 :: TestMap +lm00 = newMap [] +lm01 = mapAdd lm00 $ newEntry (1,"aaa") +lm02 = mapAdd lm01 $ newEntry (2,"bbb") +lm03 = mapAdd lm02 $ newEntry (3,"ccc") +lm04 = mapAdd lm03 $ newEntry (2,"bbb") +lm05 = mapReplaceAll lm04 $ newEntry (2,"bbb1") +lm06 = mapReplaceAll lm05 $ newEntry (9,"zzzz") +lm07 = mapReplace lm06 $ newEntry (2,"bbb") +lm08 = mapDelete lm07 3 +lm09 = mapDeleteAll lm08 2 + +la10 :: [String] +la10 = mapApplyToAll lm03 (flip replicate '*') + +lt11, lt12, lt13, lt14 :: String +lt11 = mapTranslate lm03 la10 1 "****" +lt12 = mapTranslate lm03 la10 2 "****" +lt13 = mapTranslate lm03 la10 3 "****" +lt14 = mapTranslate lm03 la10 4 "****" + +lm20, lm21, lm22, lm33, lm34, lm35, lm36 :: TestMap +lm20 = mapReplaceMap lm05 $ newMap [(2,"bbb20"),(3,"ccc20")] +lm21 = mapReplaceMap lm05 $ newMap [] +lm22 = mapReplaceMap lm05 $ newMap [(9,"zzz22"),(1,"aaa22")] +lm33 = mapAddIfNew lm22 $ newEntry (1,"aaa33") +lm34 = mapAddIfNew lm22 $ newEntry (4,"ddd34") +lm35 = mapReplaceOrAdd (newEntry (1,"aaa35")) lm22 +lm36 = mapReplaceOrAdd (newEntry (4,"ddd36")) lm22 + +testLookupMapSuite :: Test +testLookupMapSuite = + TestList + [ testLookupMap "00" lm00 [] + , testLookupMapFind "00" lm00 2 "" + , testLookupMap "01" lm01 [(1,"aaa")] + , testLookupMapFind "01" lm01 2 "" + , testLookupMap "02" lm02 [(2,"bbb"),(1,"aaa")] + , testLookupMapFind "02" lm02 2 "bbb" + , testLookupMap "03" lm03 [(3,"ccc"),(2,"bbb"),(1,"aaa")] + , testLookupMapFind "03" lm03 2 "bbb" + , testLookupMap "04" lm04 [(2,"bbb"),(3,"ccc"),(2,"bbb"),(1,"aaa")] + , testLookupMapFind "04" lm04 2 "bbb" + , testLookupMap "05" lm05 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] + , testLookupMapFind "05" lm05 2 "bbb1" + , testLookupMap "06" lm06 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] + , testLookupMapFind "06" lm06 2 "bbb1" + , testLookupMap "07" lm07 [(2,"bbb"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] + , testLookupMapFind "07" lm07 2 "bbb" + , testLookupMapFind "0x" lm07 9 "" + , testLookupMap "08" lm08 [(2,"bbb"),(2,"bbb1"),(1,"aaa")] + , testLookupMapFind "08" lm08 2 "bbb" + , testLookupMap "09" lm09 [(1,"aaa")] + , testLookupMapFind "09" lm09 2 "" + , testeq "LookupMapApplyToAll10" ["***","**","*"] la10 + , testeq "LookupMapTranslate11" "*" lt11 + , testeq "LookupMapTranslate12" "**" lt12 + , testeq "LookupMapTranslate13" "***" lt13 + , testeq "LookupMapTranslate14" "****" lt14 + , testLookupMap "20" lm20 [(2,"bbb20"),(3,"ccc20"),(2,"bbb20"),(1,"aaa")] + , testLookupMapFind "20" lm20 2 "bbb20" + , testLookupMap "21" lm21 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] + , testLookupMapFind "21" lm21 2 "bbb1" + , testLookupMap "22" lm22 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] + , testLookupMapFind "22" lm22 1 "aaa22" + , testeq "LookupContains31" True (mapContains lm22 2) + , testeq "LookupContains32" False (mapContains lm22 9) + , testLookupMap "33" lm33 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] + , testLookupMapFind "33a" lm33 1 "aaa22" + , testLookupMapFind "33b" lm33 4 "" + , testLookupMap "34" lm34 [(4,"ddd34"),(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] + , testLookupMapFind "34a" lm34 1 "aaa22" + , testLookupMapFind "34b" lm34 4 "ddd34" + , testLookupMap "35" lm35 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa35")] + , testLookupMapFind "35a" lm35 1 "aaa35" + , testLookupMapFind "35b" lm35 4 "" + , testLookupMap "36" lm36 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22"),(4,"ddd36")] + , testLookupMapFind "36a" lm36 1 "aaa22" + , testLookupMapFind "36b" lm36 4 "ddd36" + ] + +------------------------------------------------------------ +-- Reverse lookup map test tests +------------------------------------------------------------ + +revdef :: Int +revdef = -1 + +newRevMap :: [(String,Int)] -> RevTestMap +newRevMap es = makeLookupMap (map newEntry es) + +testRevLookupMap :: String -> RevTestMap -> [(String,Int)] -> Test +testRevLookupMap lab m1 m2 = + testeq ("RevLookupMap"++lab) (newRevMap m2) m1 + +testRevLookupMapFind :: String -> RevTestMap -> String -> Int -> Test +testRevLookupMapFind lab lm k res = + testeq ("RevLookupMapFind"++lab) res (mapFind revdef k lm) + +rlm00 :: RevTestMap +rlm00 = reverseLookupMap lm00 + +rlm01 :: RevTestMap +rlm01 = reverseLookupMap lm01 + +rlm02 :: RevTestMap +rlm02 = reverseLookupMap lm02 + +rlm03 :: RevTestMap +rlm03 = reverseLookupMap lm03 + +rlm04 :: RevTestMap +rlm04 = reverseLookupMap lm04 + +rlm05 :: RevTestMap +rlm05 = reverseLookupMap lm05 + +rlm06 :: RevTestMap +rlm06 = reverseLookupMap lm06 + +rlm07 :: RevTestMap +rlm07 = reverseLookupMap lm07 + +rlm08 :: RevTestMap +rlm08 = reverseLookupMap lm08 + +rlm09 :: RevTestMap +rlm09 = reverseLookupMap lm09 + +testRevLookupMapSuite :: Test +testRevLookupMapSuite = + TestList + [ testRevLookupMap "00" rlm00 [] + , testRevLookupMapFind "00" rlm00 "" revdef + , testRevLookupMap "01" rlm01 [("aaa",1)] + , testRevLookupMapFind "01" rlm01 "bbb" revdef + , testRevLookupMap "02" rlm02 [("bbb",2),("aaa",1)] + , testRevLookupMapFind "02" rlm02 "bbb" 2 + , testRevLookupMap "03" rlm03 [("ccc",3),("bbb",2),("aaa",1)] + , testRevLookupMapFind "03" rlm03 "bbb" 2 + , testRevLookupMap "04" rlm04 [("bbb",2),("ccc",3),("bbb",2),("aaa",1)] + , testRevLookupMapFind "04" rlm04 "bbb" 2 + , testRevLookupMap "05" rlm05 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] + , testRevLookupMapFind "05" rlm05 "bbb1" 2 + , testRevLookupMap "06" rlm06 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] + , testRevLookupMapFind "06" rlm06 "bbb1" 2 + , testRevLookupMap "07" rlm07 [("bbb",2),("ccc",3),("bbb1",2),("aaa",1)] + , testRevLookupMapFind "07" rlm07 "bbb" 2 + , testRevLookupMapFind "07" rlm07 "bbb1" 2 + , testRevLookupMapFind "0x" rlm07 "*" revdef + , testRevLookupMap "08" rlm08 [("bbb",2),("bbb1",2),("aaa",1)] + , testRevLookupMapFind "08" rlm08 "bbb" 2 + , testRevLookupMap "09" rlm09 [("aaa",1)] + , testRevLookupMapFind "09" rlm09 "" revdef + ] + +------------------------------------------------------------ +-- mapKeys +------------------------------------------------------------ + +testMapKeys :: String -> TestMap -> [Int] -> Test +testMapKeys lab m1 mk = + testeq ("testMapKeys:"++lab) mk (sort $ mapKeys m1) + +testMapKeysSuite :: Test +testMapKeysSuite = + TestList + [ testMapKeys "00" lm00 [] + , testMapKeys "01" lm01 [1] + , testMapKeys "02" lm02 [1,2] + , testMapKeys "03" lm03 [1,2,3] + , testMapKeys "04" lm04 [1,2,3] + , testMapKeys "05" lm05 [1,2,3] + , testMapKeys "06" lm06 [1,2,3] + , testMapKeys "07" lm07 [1,2,3] + , testMapKeys "08" lm08 [1,2] + , testMapKeys "09" lm09 [1] + ] + +------------------------------------------------------------ +-- mapVals +------------------------------------------------------------ + +testMapVals :: String -> TestMap -> [String] -> Test +testMapVals lab m1 mv = + testeq ("MapVals:"++lab) mv (sort $ mapVals m1) + +testMapValsSuite :: Test +testMapValsSuite = + TestList + [ testMapVals "00" lm00 [] + , testMapVals "01" lm01 ["aaa"] + , testMapVals "02" lm02 ["aaa","bbb"] + , testMapVals "03" lm03 ["aaa","bbb","ccc"] + , testMapVals "04" lm04 ["aaa","bbb","ccc"] + , testMapVals "05" lm05 ["aaa","bbb1","ccc"] + , testMapVals "06" lm06 ["aaa","bbb1","ccc"] + , testMapVals "07" lm07 ["aaa","bbb","bbb1","ccc"] + , testMapVals "08" lm08 ["aaa","bbb","bbb1"] + , testMapVals "09" lm09 ["aaa"] + ] + +------------------------------------------------------------ +-- mapEq +------------------------------------------------------------ + +maplist :: [(String, TestMap)] +maplist = + [ ("lm00",lm00) + , ("lm01",lm01) + , ("lm02",lm02) + , ("lm03",lm03) + , ("lm04",lm04) + , ("lm05",lm05) + , ("lm06",lm06) + , ("lm07",lm07) + , ("lm08",lm08) + , ("lm09",lm09) + ] + +mapeqlist :: [(String, String)] +mapeqlist = + [ ("lm01","lm09") + , ("lm02","lm08") + , ("lm03","lm04") + , ("lm03","lm07") + , ("lm04","lm07") + , ("lm05","lm06") + ] + +testMapEq :: String -> Bool -> TestMap -> TestMap -> Test +testMapEq lab eq m1 m2 = + testeq ("testMapEq:"++lab) eq (mapEq m1 m2) + +testMapEqSuite :: Test +testMapEqSuite = TestList + [ testMapEq (testLab l1 l2) (testEq l1 l2) m1 m2 + | (l1,m1) <- maplist , (l2,m2) <- maplist ] + where + testLab l1 l2 = l1 ++ "-" ++ l2 + testEq l1 l2 = (l1 == l2) || + (l1,l2) `elem` mapeqlist || + (l2,l1) `elem` mapeqlist + +------------------------------------------------------------ +-- mapSelect and mapMerge +------------------------------------------------------------ + +lm101, lm102, lm103, lm104 :: TestMap +lm101 = mapAdd lm03 $ newEntry (4,"ddd") +lm102 = mapSelect lm101 [1,3] +lm103 = mapSelect lm101 [2,4] +lm104 = mapSelect lm101 [2,3] + +mapSelectSuite :: Test +mapSelectSuite = + TestList + [ testLookupMap "101" lm101 [(4,"ddd"),(3,"ccc"),(2,"bbb"),(1,"aaa")] + , testLookupMap "102" lm102 [(3,"ccc"),(1,"aaa")] + , testLookupMap "103" lm103 [(4,"ddd"),(2,"bbb")] + , testLookupMap "104" lm104 [(3,"ccc"),(2,"bbb")] + ] + +lm105, lm106, lm107, lm108 :: TestMap +lm105 = mapMerge lm102 lm103 +lm106 = mapMerge lm102 lm104 +lm107 = mapMerge lm103 lm104 +lm108 = mapMerge lm101 lm102 + +mapMergeSuite :: Test +mapMergeSuite = + TestList + [ testLookupMap "105" lm105 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] + , testLookupMap "106" lm106 [(1,"aaa"),(2,"bbb"),(3,"ccc")] + , testLookupMap "107" lm107 [(2,"bbb"),(3,"ccc"),(4,"ddd")] + , testLookupMap "108" lm108 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] + ] + +------------------------------------------------------------ +-- Tranlation tests +------------------------------------------------------------ + +-- Rather late in the day, generic versions of the testing functions used earlier +type TestMapG a b = LookupMap (GenMapEntry a b) + +newMapG :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> (TestMapG a b) +newMapG es = makeLookupMap (map newEntry es) + +testLookupMapG :: (Eq a, Show a, Eq b, Show b) => String -> (TestMapG a b) -> [(a,b)] -> Test +testLookupMapG lab m1 m2 = testeq ("LookupMapG"++lab ) (newMapG m2) m1 +testLookupMapM :: + (Eq a, Show a, Eq b, Show b, Monad m, + Eq (m (TestMapG a b)), Show (m (TestMapG a b))) + => String -> m (TestMapG a b) -> m (TestMapG a b) -> Test +testLookupMapM lab m1 m2 = testeq ("LookupMapM"++lab ) m2 m1 + +tm101 :: TestMap +tm101 = newMap [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] + +tf102 :: Int -> String +tf102 = flip replicate '*' + +tm102 :: StrTestMap +tm102 = mapTranslateKeys tf102 tm101 + +tm103 :: RevTestMap +tm103 = mapTranslateVals length tm102 + +tf104 :: (LookupEntryClass a Int [b], + LookupEntryClass c String Int) => + a -> c +tf104 e = newEntry ( (flip replicate '#') k, 5-(length v) ) where (k,v) = keyVal e + +tm104 :: RevTestMap +tm104 = mapTranslateEntries tf104 tm101 + +-- Test monadic translation, using Maybe monad +-- (Note that if Nothing is generated at any step, +-- it propagates to the result) +-- +tf105 :: (LookupEntryClass a Int [b], + LookupEntryClass c String Int) => + a -> Maybe c +tf105 e = Just $ tf104 e + +tm105 :: MayTestMap +tm105 = mapTranslateEntriesM tf105 tm101 + +tf106 :: (LookupEntryClass a Int [b], + LookupEntryClass c String Int) => + a -> Maybe c +tf106 e = if k == 2 then Nothing else tf105 e where (k,_) = keyVal e + +tm106 :: MayTestMap +tm106 = mapTranslateEntriesM tf106 tm101 + +mapTranslateSuite :: Test +mapTranslateSuite = + TestList + [ testLookupMapG "tm101" tm101 [(1,"a"),(2,"bb"),(3,"ccc"),(4,"dddd")] + , testLookupMapG "tm102" tm102 [("*","a"),("**","bb"),("***","ccc"),("****","dddd")] + , testLookupMapG "tm103" tm103 [("*",1),("**",2),("***",3),("****",4)] + , testLookupMapG "tm104" tm104 [("#",4),("##",3),("###",2),("####",1)] + , testLookupMapM "tm105" tm105 (Just tm104) + , testLookupMapM "tm106" tm106 Nothing + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testLookupMapSuite + , testRevLookupMapSuite + , testMapKeysSuite + , testMapValsSuite + , testMapEqSuite + , mapSelectSuite + , mapMergeSuite + , mapTranslateSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/N3FormatterTest.hs b/tests/N3FormatterTest.hs new file mode 100644 --- /dev/null +++ b/tests/N3FormatterTest.hs @@ -0,0 +1,1309 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3FormatterTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module defines test cases for module Parse parsing functions. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.N3Formatter + ( formatGraphAsStringNl + , formatGraphAsString + , formatGraphDiag ) + +import Swish.RDF.N3Parser (parseN3fromString) + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..), NSGraph(..) + , NamespaceMap + , LookupFormula(..) + , emptyRDFGraph, toRDFGraph + -- Export selected RDFLabel values + , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil + , res_owl_sameAs + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + ) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , emptyLookupMap, makeLookupMap ) + +import Swish.RDF.GraphClass (Arc, arc) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertEqual, runTestTT ) + +------------------------------------------------------------ +-- Common test wrappers +------------------------------------------------------------ + +testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test +testLabelEq lab eq n1 n2 = + TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) + +testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test +testGraphEq lab eq gg1 gg2 = + TestCase ( assertEqual ("testGraphEq:"++lab) eq (gg1==gg2) ) + +------------------------------------------------------------ +-- Define some common values +------------------------------------------------------------ + +base1, base2, base3, base4 :: Namespace +base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node#" +base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" +base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" +base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" + +s1, s2, s3 :: RDFLabel +s1 = Res $ ScopedName base1 "s1" +s2 = Res $ ScopedName base2 "s2" +s3 = Res $ ScopedName base3 "s3" + +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 $ ScopedName base1 "p1" +p2 = Res $ ScopedName base2 "p2" +p3 = Res $ ScopedName base3 "p3" +p21 = Res $ ScopedName base2 "p21" +p22 = Res $ ScopedName base2 "p22" +p23 = Res $ ScopedName base2 "p23" +p24 = Res $ ScopedName base2 "p24" +p25 = Res $ ScopedName base2 "p25" +p26 = Res $ ScopedName base2 "p26" + +o1, o2, o3 :: RDFLabel +o1 = Res $ ScopedName base1 "o1" +o2 = Res $ ScopedName base2 "o2" +o3 = Res $ ScopedName base3 "o3" + +l1txt, l2txt, l3txt, l11txt, l12txt, l13txt, l14txt :: String +l1txt = "l1" +l2txt = "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" +l3txt = "l3--\r\"'\\--\x0020\&--\x00A0\&--" +l11txt = "lx11" +l12txt = "lx12" +l13txt = "lx13" +l14txt = "lx14" + +l1, l2, l3, l11, l12, l13, l14 :: RDFLabel +l1 = Lit l1txt Nothing +l2 = Lit l2txt Nothing +l3 = Lit l3txt Nothing +l11 = Lit l11txt Nothing +l12 = Lit l12txt Nothing +l13 = Lit l13txt Nothing +l14 = Lit l14txt Nothing + +f1, f2 :: RDFLabel +f1 = Res $ ScopedName base1 "f1" +f2 = Res $ ScopedName 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 = makeLookupMap + [ base1 + , base2 + , base3 + , base4 + ] + +g1np :: RDFGraph +g1np = toRDFGraph [t01] + +toGraph :: [Arc RDFLabel] -> RDFGraph +toGraph arcs = (toRDFGraph 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 = formo1g1 + , statements = [f01] + } + where + f01 = arc s1 p1 o1 + formo1g1 = LookupMap [Formula o1 g1] +-} + +g1f2, g1f3 :: RDFGraph +g1f2 = NSGraph + { namespaces = nslist + , formulae = formb2g1 + , statements = [f02] + } + where + f02 = arc s1 p1 b2 + formb2g1 = LookupMap [Formula b2 g1] + +g1f3 = NSGraph + { namespaces = nslist + , formulae = formb3g1f2 + , statements = [f02] + } + where + f02 = arc s1 p1 b3 + formb3g1f2 = LookupMap [Formula b3 g1f2] + +---- + +g2, g3, g4, g5, g6, g7 :: RDFGraph +g2 = toGraph [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 res_rdf_type o1 +t802 = arc s2 res_owl_sameAs 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 res_owl_sameAs s1 +tx102 = arc s2 res_owl_sameAs 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 res_owl_sameAs s1 +tx202 = arc s2 res_owl_sameAs 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 res_owl_sameAs b1 +tx402 = arc b1 res_rdf_first o1 +tx403 = arc b1 res_rdf_rest b2 +tx404 = arc b2 res_rdf_first o2 +tx405 = arc b2 res_rdf_rest b3 +tx406 = arc b3 res_rdf_first o3 +tx407 = arc b3 res_rdf_rest b4 +tx408 = arc b4 res_rdf_first l1 +tx409 = arc b4 res_rdf_rest res_rdf_nil + +x4 :: RDFGraph +x4 = toGraph [tx401,tx402,tx403,tx404, + tx405,tx406,tx407,tx408, + tx409] + +x5 :: RDFGraph +x5 = toGraph [ arc b1 res_owl_sameAs s1 + , arc b1 res_rdf_first o1 + , arc b1 res_rdf_rest b2 + , arc b2 res_rdf_first o2 + , arc b2 res_rdf_rest b3 + , arc b3 res_rdf_first o3 + , arc b3 res_rdf_rest b4 + , arc b4 res_rdf_first l1 + , arc b4 res_rdf_rest res_rdf_nil + ] + +{- +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 res_rdf_first o1 + , arc s1 res_rdf_rest b2 + , arc b2 res_rdf_first o2 + , arc b2 res_rdf_rest b3 + , arc b3 res_rdf_first o3 + , arc b3 res_rdf_rest b4 + , arc b4 res_rdf_first l1 + , arc b4 res_rdf_rest res_rdf_nil + ] + +x7 :: RDFGraph +x7 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 g2] + , statements = [arc b1 p2 f2] + } + +x8 :: RDFGraph +x8 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula f1 g2] + , statements = [arc f1 p2 f2] + } + +x9 :: RDFGraph +x9 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula f1 g1] + , statements = [arc f1 p2 f2] + } + +-- Test allocation of bnodes carries over a nested formula + +x12, x12fg :: RDFGraph +x12 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b2 x12fg] + , statements = [ arc s1 p1 b1 + , arc b1 p1 o1 + , arc b2 p2 f2 + , arc s3 p3 b3 + , arc b3 p3 o3 + ] + } + +x12fg = toRDFGraph [ arc s2 p2 b4 + , arc b4 p2 o2 + ] + +-- List of simple anon nodes + +x13 :: RDFGraph +x13 = toGraph [ arc s1 res_rdf_first b1 + , arc s1 res_rdf_rest c1 + , arc c1 res_rdf_first b2 + , arc c1 res_rdf_rest c2 + , arc c2 res_rdf_first b3 + , arc c2 res_rdf_rest res_rdf_nil + , 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 res_rdf_first b_1 + , arc s1 res_rdf_rest c_1 + , arc c_1 res_rdf_first b_2 + , arc c_1 res_rdf_rest c_2 + , arc c_2 res_rdf_first b_3 + , arc c_2 res_rdf_rest res_rdf_nil + , 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 res_rdf_first b1 + , arc s1 res_rdf_rest c1 + , arc c1 res_rdf_first b2 + , arc c1 res_rdf_rest c2 + , arc c2 res_rdf_first b3 + , arc c2 res_rdf_rest res_rdf_nil + , 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 res_rdf_first b1 + , arc s1 res_rdf_rest c1 + , arc c1 res_rdf_first b2 + , arc c1 res_rdf_rest c2 + , arc c2 res_rdf_first b3 + , arc c2 res_rdf_rest res_rdf_nil + , arc b1 p1 o1 + , arc b2 p2 c3 + , arc b3 p1 o3 + + , arc c3 res_rdf_first b4 + , arc c3 res_rdf_rest c4 + , arc c4 res_rdf_first b5 + , arc c4 res_rdf_rest c5 + , arc c5 res_rdf_first b6 + , arc c5 res_rdf_rest res_rdf_nil + , arc b4 p1 o1 + , arc b5 p1 o2 + , arc b6 p1 o3 + ] + +-- More complex list with nested list + +x16 :: RDFGraph +x16 = toGraph [ arc s1 res_rdf_first b1 + , arc s1 res_rdf_rest c1 + , arc c1 res_rdf_first b2 + , arc c1 res_rdf_rest c2 + , arc c2 res_rdf_first b3 + , arc c2 res_rdf_rest res_rdf_nil + , arc b1 p1 o1 + , arc b1 p2 o1 + , arc b2 p2 c3 + , arc b3 p1 o3 + , arc b3 p2 o3 + + , arc c3 res_rdf_first b4 + , arc c3 res_rdf_rest c4 + , arc c4 res_rdf_first b5 + , arc c4 res_rdf_rest c5 + , arc c5 res_rdf_first b6 + , arc c5 res_rdf_rest res_rdf_nil + , 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 res_rdf_type o1 + , arc s1 res_rdf_first b1 + , arc s1 res_rdf_rest c1 + , arc c1 res_rdf_first b2 + , arc c1 res_rdf_rest res_rdf_nil + + , arc b1 p21 o2 + , arc b1 p22 c2 + + , arc b2 p24 o3 + , arc b2 p25 l13 + + , arc c2 res_rdf_first b3 + , arc c2 res_rdf_rest c3 + , arc c3 res_rdf_first l12 + , arc c3 res_rdf_rest res_rdf_nil + + , arc b3 p23 l11 + ] + +-- collection graphs + +graph_c1, graph_c1rev, graph_c2, graph_c2rev, + graph_c3 :: RDFGraph +graph_c1 = toGraph [arc s1 p1 res_rdf_nil] +graph_c1rev = toGraph [arc res_rdf_nil p1 o1] +graph_c2 = toGraph [arc s1 p1 b1, + arc b1 res_rdf_first l1, + arc b1 res_rdf_rest b2, + arc b2 res_rdf_first o2, + arc b2 res_rdf_rest b3, + arc b3 res_rdf_first l2, + arc b3 res_rdf_rest b4, + arc b4 res_rdf_first o3, + arc b4 res_rdf_rest res_rdf_nil] +graph_c2rev = toGraph [arc b1 res_rdf_first l1, + arc b1 res_rdf_rest b2, + arc b2 res_rdf_first o2, + arc b2 res_rdf_rest b3, + arc b3 res_rdf_first l2, + arc b3 res_rdf_rest b4, + arc b4 res_rdf_first o3, + arc b4 res_rdf_rest res_rdf_nil, + arc b1 p1 o1] +graph_c3 = toGraph [arc s1 p1 b1, + arc b1 res_rdf_first l1, + arc b1 res_rdf_rest b2, + arc b2 res_rdf_first o2, + arc b2 res_rdf_rest b3, + arc b3 res_rdf_first l2, + arc b3 res_rdf_rest b4, + arc b4 res_rdf_first o3, + arc b4 res_rdf_rest res_rdf_nil, + arc s1 p2 res_rdf_nil, + arc s2 p2 o2] + +-- bnode graphs + +graph_b1, graph_b1rev, graph_b2, graph_b2rev, graph_b3 :: RDFGraph +graph_b1 = toGraph [arc s1 p1 b1] +graph_b1rev = toGraph [arc b1 p1 o1] +graph_b2 = toGraph [arc s1 p1 b1, + arc b1 p2 l1, + arc b1 o2 o3] +graph_b2rev = toGraph [arc b1 p2 l1, + arc b1 o2 o3, + arc b1 p1 o1] +graph_b3 = toGraph [arc s1 p1 b1, + arc b1 p2 l2, + arc b1 o2 o3, + arc s1 p2 b2, + arc s2 p2 o2] + +------------------------------------------------------------ +-- 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 -> String -> Test +formatTest lab gr out = + TestList + [ TestCase ( assertEqual ("formatTest:"++lab) out res ) + ] + where + res = formatGraphAsStringNl gr + +diagTest :: String -> RDFGraph -> String -> Test +diagTest lab gr out = + TestList + [ TestCase ( assertEqual ("diag:text:"++lab) out (res "") ) + , TestCase ( assertEqual ("diag:map:"++lab) emptyLookupMap nmap ) + , TestCase ( assertEqual ("diag:gen:"++lab) 0 ngen ) + , TestCase ( assertEqual ("diag:trc:"++lab) [] trc ) + ] + where + (res,nmap,ngen,trc) = formatGraphDiag gr + +commonPrefixes :: String +commonPrefixes = + "@prefix base1: <" ++ nsURI base1 ++ "> .\n" ++ + "@prefix base2: <" ++ nsURI base2 ++ "> .\n" ++ + "@prefix base3: <" ++ nsURI base3 ++ "> .\n" ++ + "@prefix base4: <" ++ nsURI base4 ++ "> .\n" + +-- Single statement using form +simpleN3Graph_g1_01 :: String +simpleN3Graph_g1_01 = + " " ++ + " " ++ + " .\n" + +-- Single statement using prefix:name form +simpleN3Graph_g1_02 :: String +simpleN3Graph_g1_02 = + commonPrefixes ++ + "base1:s1 base1:p1 base1:o1 .\n" + +-- Single blank node +simpleN3Graph_g1_03 :: String +simpleN3Graph_g1_03 = + commonPrefixes ++ + "[\n base1:p1 base1:o1\n] .\n" + -- "_:b1 base1:p1 base1:o1 .\n" + +-- Single auto-allocated blank node +simpleN3Graph_g1_04 :: String +simpleN3Graph_g1_04 = + commonPrefixes ++ + "[\n base1:p1 base1:o1\n] .\n" + -- "_:_1 base1:p1 base1:o1 .\n" + +-- Single literal object +simpleN3Graph_g1_05 :: String +simpleN3Graph_g1_05 = + commonPrefixes ++ + "base1:s1 base1:p1 \"l1\" .\n" + +-- Single multiline literal object +simpleN3Graph_g1_06 :: String +simpleN3Graph_g1_06 = + commonPrefixes ++ + "base1:s1 base1:p1 \"l2-'\\\"line1\\\"'\\n\\nl2-'\\\"\\\"line2\\\"\\\"'\" .\n" + +-- this 'round trips' into a triple-quoted string +simpleN3Graph_g1_06_rt :: String +simpleN3Graph_g1_06_rt = + commonPrefixes ++ + "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 :: String +simpleN3Graph_g1_08 = + 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 :: String +simpleN3Graph_g1_09 = + commonPrefixes ++ + "[\n _:b2 []\n] .\n" + -- "_:b1 _:b2 _:b3 .\n" + +-- Simple nested formula case +simpleN3Graph_g1_10 :: String +simpleN3Graph_g1_10 = + commonPrefixes ++ + "base1:s1 base1:p1 { \n" ++ + " base1:s1 base1:p1 { \n" ++ + " base1:s1 base1:p1 base1:o1\n" ++ + " } \n" ++ + " } .\n" + +{- +Simple troublesome case +-} + +simpleN3Graph_x13a :: String +simpleN3Graph_x13a = + 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]" + +{- +Simple collection tests; may replicate some of the +previous tests. +-} + +simpleN3Graph_c1 :: String +simpleN3Graph_c1 = + commonPrefixes ++ + "base1:s1 base1:p1 () .\n" + +simpleN3Graph_c1rev :: String +simpleN3Graph_c1rev = + commonPrefixes ++ + "() base1:p1 base1:o1 .\n" + +collItems :: String +collItems = "( \"l1\" base2:o2 \"\"\"" ++ l2txt ++ "\"\"\" base3:o3 )" + +simpleN3Graph_c2 :: String +simpleN3Graph_c2 = + commonPrefixes ++ + "base1:s1 base1:p1 " ++ collItems ++ " .\n" + +simpleN3Graph_c2rev :: String +simpleN3Graph_c2rev = + commonPrefixes ++ + collItems ++ " base1:p1 base1:o1 .\n" + +simpleN3Graph_c3 :: String +simpleN3Graph_c3 = + 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 :: String +simpleN3Graph_b1 = + commonPrefixes ++ + "base1:s1 base1:p1 [] .\n" + +simpleN3Graph_b1rev :: String +simpleN3Graph_b1rev = + commonPrefixes ++ + "[\n base1:p1 base1:o1\n] .\n" + +simpleN3Graph_b2 :: String +simpleN3Graph_b2 = + commonPrefixes ++ + "base1:s1 base1:p1 [\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" + +simpleN3Graph_b2rev :: String +simpleN3Graph_b2rev = + commonPrefixes ++ + "[\n base1:p1 base1:o1 ;\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" + +simpleN3Graph_b3 :: String +simpleN3Graph_b3 = + commonPrefixes ++ + "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" + +-- diag13 = diagTest "trivialTest13" x13a simpleN3Graph_x13a + +trivialTestSuite :: Test +trivialTestSuite = TestList + [ formatTest "trivialTest01" g1np simpleN3Graph_g1_01 + , 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 "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 "trivialTestb1rev" graph_b1rev simpleN3Graph_b1rev + , formatTest "trivialTestb2rev" graph_b2rev simpleN3Graph_b2rev + + , 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 -> String -> 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 parseN3fromString inp 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 = formatGraphAsString gr + (pe,pg) = case parseN3fromString out of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + +-- 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 -> String -> Test +fullRoundTripTest lab grstr = + TestList + [ TestCase ( assertEqual ("FullRoundTrip:gr:"++lab) gr pg ) + , TestCase ( assertEqual ("FullRoundTrip:er:"++lab) "" pe ) + -- , TestCase ( assertEqual ("FullRoundTrip:"++lab) "" out ) + ] + where + (_,gr) = case parseN3fromString grstr of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + out = formatGraphAsString gr + (pe,pg) = case parseN3fromString out of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + +roundTripTestSuite :: Test +roundTripTestSuite = TestList + [ roundTripTest "01" g1np + , roundTripTest "02" g1 + , roundTripTest "03" g1b1 + , roundTripTest "04" g1a1 + , roundTripTest "05" g1l1 + , roundTripTest "06" g1l2 + -- 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 + ] + +------------------------------------------------------------ +-- 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 = formatGraphAsString gr + (pe,pg) = case parseN3fromString out of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + +-- Simple anon nodes, with semicolons and commas +exoticN3Graph_x1 :: String +exoticN3Graph_x1 = + 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 :: String +exoticN3Graph_x2 = + 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" + +-- 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 :: String +exoticN3Graph_x4 = + commonPrefixes ++ + "base1:s1 = ( base1:o1 base2:o2 base3:o3 \"l1\" ) .\n" + +exoticN3Graph_x5 :: String +exoticN3Graph_x5 = + commonPrefixes ++ + "( 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 :: String +exoticN3Graph_x7 = + 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 :: String +exoticN3Graph_x7a = + 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 :: String +exoticN3Graph_x12 = + 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 :: String +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" + +-- 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 :: Test +allTests = TestList + [ trivialTestSuite + , parseTestSuite + , roundTripTestSuite + , simpleTestSuite + , exoticTestSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/N3ParserTest.hs b/tests/N3ParserTest.hs new file mode 100644 --- /dev/null +++ b/tests/N3ParserTest.hs @@ -0,0 +1,1434 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : N3ParserTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module contains test cases for module "N3Parser". +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.N3Parser + ( parseN3fromString, parseN3 + , parseTextFromString, parseAltFromString + , parseNameFromString, parsePrefixFromString + , parseAbsURIrefFromString, parseLexURIrefFromString + , parseURIref2FromString + ) + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..), NSGraph(..) + -- LookupNamespace(..), Namespace + , emptyNamespaceMap + , LookupFormula(..), emptyFormulaMap + , emptyRDFGraph, toRDFGraph + -- Export selected RDFLabel values + , res_rdf_type, res_rdf_first, res_rdf_rest, res_rdf_nil + , res_owl_sameAs, res_log_implies + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , nullNamespace + , ScopedName(..) + , makeScopedName + , nullScopedName + , makeUriScopedName + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , langName + , rdf_XMLLiteral + ) + +import Swish.Utils.QName (QName, qnameFromURI) +import Swish.Utils.LookupMap (LookupMap(..)) + +import Swish.RDF.GraphClass (Arc, arc) + +import Test.HUnit (Test(TestCase,TestList), assertEqual, runTestTT) + +import Data.List (intercalate) + +------------------------------------------------------------ +-- Generic item parsing test wrapper +------------------------------------------------------------ + +type ParseFromString a = String -> (Either String a) + +parseItemTest :: (Eq a, Show a) => ParseFromString a -> a + -> String -> String -> 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 +------------------------------------------------------------ + +testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test +testLabelEq lab eq n1 n2 = + TestCase ( assertEqual ("testLabelEq:"++lab) eq (n1==n2) ) + +testGraphEq :: String -> Bool -> RDFGraph -> RDFGraph -> Test +testGraphEq lab eq gg1 gg2 = + TestCase ( assertEqual ("testGraphEq:"++lab) eq (gg1==gg2) ) + +parseTest :: String -> String -> 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 parseN3fromString inp of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + +parseTestB :: QName -> String -> String -> RDFGraph -> String -> Test +parseTestB base lab inp gr er = + TestList + [ TestCase ( assertEqual ("parseTestError:"++lab) er pe ) + , TestCase ( assertEqual ("parseTestGraph:"++lab) gr pg ) + ] + where + (pe,pg) = case parseN3 inp (Just base) of + Right g -> ("",g) + Left s -> (s,emptyRDFGraph) + +------------------------------------------------------------ +-- Test simple character parsing +------------------------------------------------------------ + +parseCharTest :: String -> String + -> String -> String -> String -> Test +parseCharTest c = parseItemTest (parseTextFromString c) "" + +parseAltTest :: String -> String + -> String -> String -> String -> String -> Test +parseAltTest cc1 cc2 = parseItemTest (parseAltFromString cc1 cc2) "" + +charInp01, char01 :: String +charInp01 = ":" +char01 = ":" + +charInp02, char02 :: String +charInp02 = "<>" +char02 = "<>" + +charInp03 :: String +charInp03 = "<=" + +charTestSuite :: Test +charTestSuite = TestList + [ parseCharTest char01 "parseCharTest01" charInp01 char01 noError + , parseCharTest char02 "parseCharTest02" charInp02 char02 noError + , parseAltTest char01 char02 "parseCharTest03" charInp01 char01 noError + , parseAltTest char01 char02 "parseCharTest04" charInp02 char02 noError + , parseAltTest char01 char02 "parseCharTest04" charInp03 "" errorText + ] + +------------------------------------------------------------ +-- Test simple name parsing +------------------------------------------------------------ + +parseNameTest :: String -> String -> String -> String -> Test +parseNameTest = parseItemTest parseNameFromString "" + +nameTestSuite :: Test +nameTestSuite = TestList + [ parseNameTest "parseNameTest01" "name" "name" "" + , parseNameTest "parseNameTest02" "rdf" "rdf" "" + ] + +------------------------------------------------------------ +-- Test simple prefix parsing +------------------------------------------------------------ + +parsePrefixTest :: String -> String -> Namespace -> String -> Test +parsePrefixTest = parseItemTest parsePrefixFromString nullNamespace + +prefix01, prefix02 :: Namespace +prefix01 = Namespace "pref" "pref:" +prefix02 = Namespace "rdf" $ nsURI namespaceRDF + +prefixTestSuite :: Test +prefixTestSuite = TestList + [ parsePrefixTest "parsePrefixTest01" "pref" prefix01 "" + , parsePrefixTest "parsePrefixTest02" "rdf" prefix02 "" + ] + +------------------------------------------------------------ +-- Test absolute URIref parsing +------------------------------------------------------------ + +parseAbsUriRefTest :: String -> String -> String -> String -> Test +parseAbsUriRefTest = parseItemTest parseAbsURIrefFromString "" + +parseLexUriRefTest :: String -> String -> String -> String -> Test +parseLexUriRefTest = parseItemTest parseLexURIrefFromString "" + +absUriRefInp01, absUriRefInp01s, absUriRef01 :: String +absUriRefInp01 = "" +absUriRefInp01s = " " +absUriRef01 = "http://www.w3.org/1999/02/22-rdf-syntax-ns#type" + +absUriRefInp02, absUriRefInp02s, absUriRef02 :: String +absUriRefInp02 = "" +absUriRefInp02s = " " +absUriRef02 = "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 -> String -> ScopedName -> String -> Test +parseUriRef2Test = parseItemTest parseURIref2FromString nullScopedName + +uriRef01 :: String +uriRef01 = "rdf:type " + +sname01 :: ScopedName +sname01 = ScopedName namespaceRDF "type" + +uriRef02 :: String +uriRef02 = " " + +sname02 :: ScopedName +sname02 = + makeScopedName "" "http://id.ninebynine.org/wip/2003/test/graph1/node#" "s1" + +uriRef2TestSuite :: Test +uriRef2TestSuite = TestList + [ parseUriRef2Test "parseUriRef2Test01" uriRef01 sname01 "" + , parseUriRef2Test "parseUriRef2Test02" uriRef02 sname02 "" + ] + +------------------------------------------------------------ +-- Define some common values +------------------------------------------------------------ + +baseFile :: String +baseFile = "file:///dev/null" + +dqn :: QName +dqn = qnameFromURI baseFile + +dbase, base1, base2, base3, base4, basea :: Namespace +dbase = Namespace "" (baseFile ++ "#") +base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node/" +base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node#" +base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" +base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" +basea = Namespace "a" "http://example.org/basea#" + +u1 :: RDFLabel +u1 = Res $ ScopedName base1 "" + +ds1, ds2, ds3 :: RDFLabel +ds1 = Res $ ScopedName dbase "s1" +ds2 = Res $ ScopedName dbase "s2" +ds3 = Res $ ScopedName dbase "s3" + +dp1, dp2, dp3 :: RDFLabel +dp1 = Res $ ScopedName dbase "p1" +dp2 = Res $ ScopedName dbase "p2" +dp3 = Res $ ScopedName dbase "p3" + +do1, do2, do3 :: RDFLabel +do1 = Res $ ScopedName dbase "o1" +do2 = Res $ ScopedName dbase "o2" +do3 = Res $ ScopedName dbase "o3" + +s1, s2, s3, sa :: RDFLabel +s1 = Res $ ScopedName base1 "s1" +s2 = Res $ ScopedName base2 "s2" +s3 = Res $ ScopedName base3 "s3" +sa = Res $ ScopedName 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 $ ScopedName base1 "p1" +p2 = Res $ ScopedName base2 "p2" +p3 = Res $ ScopedName base3 "p3" +pa = Res $ ScopedName basea "b" + +o1, o2, o3, oa :: RDFLabel +o1 = Res $ ScopedName base1 "o1" +o2 = Res $ ScopedName base2 "o2" +o3 = Res $ ScopedName base3 "o3" +oa = Res $ ScopedName basea "c" + +l1, l2, l3 :: RDFLabel +l1 = Lit "l1" Nothing +l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" Nothing +l3 = Lit "l3--\r\"'\\--\x0020\&--\x00A0\&--" Nothing + +lfr, lxml, lfrxml :: RDFLabel +lfr = Lit "chat" (Just $ langName "fr") +lxml = Lit "
" (Just rdf_XMLLiteral ) +lfrxml = Lit "chat" (Just rdf_XMLLiteral ) + +bTrue, bFalse :: RDFLabel +bTrue = Lit "true" $ Just $ ScopedName (Namespace "xsd" "http://www.w3.org/2001/XMLSchema#") "boolean" +bFalse = Lit "false" $ Just $ ScopedName (Namespace "xsd" "http://www.w3.org/2001/XMLSchema#") "boolean" + +f1, f2 :: RDFLabel +f1 = Res $ ScopedName base1 "f1" +f2 = Res $ ScopedName 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 :: (String,Namespace) -> Namespace +makeNewPrefixNamespace (pre,ns) = Namespace pre (nsURI ns) + +dg1 :: RDFGraph +dg1 = toRDFGraph [arc ds1 dp1 do1] + +dg2 :: RDFGraph +dg2 = toRDFGraph + [ 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 + mU = Res . makeUriScopedName + xa1 = mU "file:///dev/a1" + xb1 = mU "file:///dev/b1" + xc1 = mU "file:///dev/c1" + xa2 = mU "http://example.org/ns/a2" + xb2 = mU "http://example.org/ns/b2" + xc2 = mU "http://example.org/ns/c2" + xa3 = mU "http://example.org/ns/foo/a3" + xb3 = mU "http://example.org/ns/foo/b3" + xc3 = mU "http://example.org/ns/foo/c3" + + ns4 = Namespace "" "http://example.org/ns/foo/bar#" + ns5 = Namespace "" "http://example.org/ns2#" + mUN a b = Res (ScopedName 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" + +nslist :: LookupMap Namespace +nslist = LookupMap $ map makeNewPrefixNamespace + [ ("base1",base1) + , ("base2",base2) + , ("base3",base3) + , ("base4",base4) + ] + +toGraph :: [Arc RDFLabel] -> RDFGraph +toGraph stmts = NSGraph { namespaces = nslist + , formulae = emptyFormulaMap + , statements = 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] + +g2 :: RDFGraph +g2 = toGraph [t01,t02,t03] + +g3 :: RDFGraph +g3 = toGraph [t01,t04] + +g4 :: RDFGraph +g4 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t01,t05] + } + +g5 :: RDFGraph +g5 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t01,t02,t03,t04,t05] + } + +g6 :: RDFGraph +g6 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t01,t06] + } + +g7 :: RDFGraph +g7 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t01,t07] + } + +t801, t802, t807, t808, t811, t812 :: Arc RDFLabel +t801 = arc s1 res_rdf_type o1 +t802 = arc s2 res_owl_sameAs o2 +t807 = arc o1 p1 s1 +t808 = arc s2 p1 o2 +t811 = arc s1 res_log_implies o1 +t812 = arc o2 res_log_implies s2 + +g8 :: RDFGraph +g8 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t801,t802,t807,t808,t811,t812] + } + +g81 :: RDFGraph +g81 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t801,t802] + } + +g83 :: RDFGraph +g83 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t1111,t1112,t1113] + } + +t1211, t1221, t1222, t1223, t1224 :: Arc RDFLabel +t1211 = arc b1 p1 o1 +t1221 = arc b2 res_rdf_first v1 +t1222 = arc b2 res_rdf_rest b3 +t1223 = arc b3 res_rdf_first v2 +t1224 = arc b3 res_rdf_rest res_rdf_nil + +g12 :: RDFGraph +g12 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [t1711,t1722,t1733] + } + +tx101, tx102, tx111, tx112, tx113, tx114, tx121, tx122, tx123, + tx124, tx125, tx126, tx127, tx128 :: Arc RDFLabel +tx101 = arc b1 res_owl_sameAs s1 +tx102 = arc s2 res_owl_sameAs 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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 res_owl_sameAs s1 +tx202 = arc s2 res_owl_sameAs 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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 res_owl_sameAs b1 +tx402 = arc b1 res_rdf_first o1 +tx403 = arc b1 res_rdf_rest b2 +tx404 = arc b2 res_rdf_first o2 +tx405 = arc b2 res_rdf_rest b3 +tx406 = arc b3 res_rdf_first o3 +tx407 = arc b3 res_rdf_rest b4 +tx408 = arc b4 res_rdf_first l1 +tx409 = arc b4 res_rdf_rest res_rdf_nil + +x4 :: RDFGraph +x4 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [tx401,tx402,tx403,tx404, + tx405,tx406,tx407,tx408, + tx409] + } + +tx501, tx502, tx503, tx504, tx505, tx506, tx507, + tx508, tx509 :: Arc RDFLabel +tx501 = arc b1 res_owl_sameAs s1 +tx502 = arc b1 res_rdf_first o1 +tx503 = arc b1 res_rdf_rest b2 +tx504 = arc b2 res_rdf_first o2 +tx505 = arc b2 res_rdf_rest b3 +tx506 = arc b3 res_rdf_first o3 +tx507 = arc b3 res_rdf_rest b4 +tx508 = arc b4 res_rdf_first l1 +tx509 = arc b4 res_rdf_rest res_rdf_nil + +x5 :: RDFGraph +x5 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [tx501,tx502,tx503,tx504, + tx505,tx506,tx507,tx508, + tx509] + } + +tx601, tx602, tx603, tx604, tx605, tx606, tx607, + tx608 :: Arc RDFLabel +tx601 = arc s1 res_rdf_first o1 +tx602 = arc s1 res_rdf_rest b2 +tx603 = arc b2 res_rdf_first o2 +tx604 = arc b2 res_rdf_rest b3 +tx605 = arc b3 res_rdf_first o3 +tx606 = arc b3 res_rdf_rest b4 +tx607 = arc b4 res_rdf_first l1 +tx608 = arc b4 res_rdf_rest res_rdf_nil + +x6 :: RDFGraph +x6 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [tx601,tx602,tx603,tx604, + tx605,tx606,tx607,tx608] + } + +tx701 :: Arc RDFLabel +tx701 = arc b1 p2 f2 + +x7 :: RDFGraph +x7 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 g2] + , statements = [tx701] + } + +tx801 :: Arc RDFLabel +tx801 = arc f1 p2 f2 + +x8 :: RDFGraph +x8 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula f1 g2] + , statements = [tx801] + } + +x9 :: RDFGraph +x9 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula f1 g1] + , statements = [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 = NSGraph + { namespaces = emptyNamespaceMap + , formulae = emptyFormulaMap + , statements = [tx1211,tx1212] + } + +x12 :: RDFGraph +x12 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b2 x12fg] + , statements = [tx1201,tx1202,tx1203,tx1204,tx1205] + } + +-- List of simple anon nodes + +tx1301, tx1302, tx1303, tx1304, tx1305, tx1306, tx1307, + tx1308, tx1309 :: Arc RDFLabel +tx1301 = arc s1 res_rdf_first b1 +tx1302 = arc s1 res_rdf_rest c1 +tx1303 = arc c1 res_rdf_first b2 +tx1304 = arc c1 res_rdf_rest c2 +tx1305 = arc c2 res_rdf_first b3 +tx1306 = arc c2 res_rdf_rest res_rdf_nil +tx1307 = arc b1 p1 o1 +tx1308 = arc b2 p1 o2 +tx1309 = arc b3 p1 o3 + +x13 :: RDFGraph +x13 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 res_rdf_first b1 +tx1402 = arc s1 res_rdf_rest c1 +tx1403 = arc c1 res_rdf_first b2 +tx1404 = arc c1 res_rdf_rest c2 +tx1405 = arc c2 res_rdf_first b3 +tx1406 = arc c2 res_rdf_rest res_rdf_nil +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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 res_rdf_first b1 +tx1502 = arc s1 res_rdf_rest c1 +tx1503 = arc c1 res_rdf_first b2 +tx1504 = arc c1 res_rdf_rest c2 +tx1505 = arc c2 res_rdf_first b3 +tx1506 = arc c2 res_rdf_rest res_rdf_nil +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 res_rdf_first b4 +tx1522 = arc c3 res_rdf_rest c4 +tx1523 = arc c4 res_rdf_first b5 +tx1524 = arc c4 res_rdf_rest c5 +tx1525 = arc c5 res_rdf_first b6 +tx1526 = arc c5 res_rdf_rest res_rdf_nil +tx1527 = arc b4 p1 o1 +tx1528 = arc b5 p1 o2 +tx1529 = arc b6 p1 o3 + +x15 :: RDFGraph +x15 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 res_rdf_first b1 +tx1602 = arc s1 res_rdf_rest c1 +tx1603 = arc c1 res_rdf_first b2 +tx1604 = arc c1 res_rdf_rest c2 +tx1605 = arc c2 res_rdf_first b3 +tx1606 = arc c2 res_rdf_rest res_rdf_nil +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 res_rdf_first b4 +tx1622 = arc c3 res_rdf_rest c4 +tx1623 = arc c4 res_rdf_first b5 +tx1624 = arc c4 res_rdf_rest c5 +tx1625 = arc c5 res_rdf_first b6 +tx1626 = arc c5 res_rdf_rest res_rdf_nil +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 = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = [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 + [ arc b a c ] + where + -- the document base is set to file:///dev/null to begin with + ns = Namespace "" (baseFile ++ "#") + mUN = Res . ScopedName ns + a = mUN "a" + b = mUN "b" + c = mUN "c" + +------------------------------------------------------------ +-- Simple parser tests +------------------------------------------------------------ + +-- check default base +simpleN3Graph_dg_01 :: String +simpleN3Graph_dg_01 = + ":s1 :p1 :o1 ." + +-- from the turtle documentation +simpleN3Graph_dg_02 :: String +simpleN3Graph_dg_02 = + "# 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" + +commonPrefixes :: String +commonPrefixes = + "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ + "@prefix base2 : <" ++ nsURI base2 ++ "> . \n" ++ + "@prefix base3 : <" ++ nsURI base3 ++ "> . \n" + +-- Single statement using form +simpleN3Graph_g1_01 :: String +simpleN3Graph_g1_01 = + " " ++ + " " ++ + " . " + +-- Single statement using prefix:name form +simpleN3Graph_g1_02 :: String +simpleN3Graph_g1_02 = + "@prefix base1 : <" ++ nsURI base1 ++ "> ." ++ + " 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 :: String +simpleN3Graph_g1_02a = + "@prefix a: <" ++ nsURI basea ++ "> ." ++ + "a:a a:b a:c ." + +-- Single statement using :name form +simpleN3Graph_g1_03 :: String +simpleN3Graph_g1_03 = + "@prefix : <" ++ nsURI base1 ++ "> .\n" ++ + " :s1 :p1 :o1 . " + +-- Turtle supports ':' but (apparently) not N3, but try +-- and support it. +-- +simpleN3Graph_g1_03_1 :: String +simpleN3Graph_g1_03_1 = + "@prefix : <" ++ nsURI base1 ++ "> .\n" ++ + " : : :." + +simpleN3Graph_g1_03_2 :: String +simpleN3Graph_g1_03_2 = + "@prefix b: <" ++ nsURI base1 ++ "> .\n" ++ + "b: b: b:. " + +-- Single statement using relative URI form +simpleN3Graph_g1_04 :: String +simpleN3Graph_g1_04 = + "@base <" ++ nsURI base1 ++ "> .\n" ++ + " . " + +-- Single statement using blank nodes +simpleN3Graph_g1_05 :: String +simpleN3Graph_g1_05 = + "@base <" ++ nsURI base1 ++ "> .\n" ++ + " _:b1 _:b2 _:b3 . " + +-- Single statement with junk following +simpleN3Graph_g1_06 :: String +simpleN3Graph_g1_06 = + "@prefix base1 : <" ++ nsURI base1 ++ "> ." ++ + " base1:s1 base1:p1 base1:o1 . " ++ + " **** " + +-- Multiple statements +simpleN3Graph_g2 :: String +simpleN3Graph_g2 = + 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 :: String +simpleN3Graph_g3 = + commonPrefixes ++ + " base1:s1 base1:p1 base1:o1 . \n" ++ + " base1:s1 base1:p1 \"l1\" . \n" + +-- Graph with nodeid +simpleN3Graph_g4 :: String +simpleN3Graph_g4 = + commonPrefixes ++ + " base1:s1 base1:p1 base1:o1 . \n" ++ + " base2:s2 base1:p1 _:b1 . \n" + +-- Graph with literal and nodeid +simpleN3Graph_g5 :: String +simpleN3Graph_g5 = + 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 :: String +simpleN3Graph_g6 = + commonPrefixes ++ + " base1:s1 base1:p1 base1:o1 . \n" ++ + " base3:s3 base1:p1 \"\"\"l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'\"\"\" . \n" + +-- String escapes +simpleN3Graph_g7 :: String +simpleN3Graph_g7 = + commonPrefixes ++ + " base1:s1 base1:p1 base1:o1 . \n" ++ + " base3:s3 base2:p2 " ++ + " \"l3--\\r\\\"\\'\\\\--\\u0020--\\U000000A0--\" " ++ + " . \n" + +-- Different verb forms +simpleN3Graph_g8 :: String +simpleN3Graph_g8 = + 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 :: String +simpleN3Graph_g8b = + 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 :: String +simpleN3Graph_g81 = + commonPrefixes ++ + " base1:s1 a base1:o1 . \n" ++ + " base2:s2 = base2:o2 . \n" + +simpleN3Graph_g83 :: String +simpleN3Graph_g83 = + 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 :: String +simpleN3Graph_g83b = + 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 :: String +simpleN3Graph_g9 = + 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 :: String +simpleN3Graph_g9b = + 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 :: String +simpleN3Graph_g10 = + 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 :: String +simpleN3Graph_g11 = + "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ + " base1:s1 base1:p1 ?var1 . \n" ++ + " ?var2 base1:p1 base1:o1 . \n" ++ + " ?var3 base1:p1 ?var4 . \n" + +-- Bare anonymous nodes +simpleN3Graph_g12 :: String +simpleN3Graph_g12 = + "@prefix base1 : <" ++ nsURI base1 ++ "> . \n" ++ + " [ base1:p1 base1:o1 ] . \n" ++ + " ( ?var1 ?var2 ) . \n" + +-- Literals with dataype and language +simpleN3Graph_g17 :: String +simpleN3Graph_g17 = + commonPrefixes ++ + " base1:s1 base1:p1 \"chat\"@fr . \n " ++ + " base2:s2 base2:p2 \"
\"^^rdf:XMLLiteral . \n " ++ + " base3:s3 base3:p3 \"chat\"^^rdf:XMLLiteral . \n " + +emsg16 :: String +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" + ] + + +simpleTestSuite :: Test +simpleTestSuite = TestList + [ parseTestB dqn "simpleTestd01" simpleN3Graph_dg_01 dg1 noError + , parseTestB dqn "simpleTestd02" simpleN3Graph_dg_02 dg2 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 "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 "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 :: String +litN3Graph_g1 = + commonPrefixes ++ + " base1:s1 base1:p1 \"true\"^^.\n" ++ + " base2:s2 base2:p2 \"false\"^^.\n" ++ + " base3:s3 base3:p3 \"true\"^^.\n" + +litN3Graph_g2 :: String +litN3Graph_g2 = + commonPrefixes ++ + " base1:s1 base1:p1 @true.\n" ++ + " base2:s2 base2:p2 @false.\n" ++ + " base3:s3 base3:p3 true.\n" + +lit_g1 :: RDFGraph +lit_g1 = toGraph [ arc s1 p1 bTrue + , arc s2 p2 bFalse + , arc s3 p3 bTrue + ] + +litTestSuite :: Test +litTestSuite = TestList + [ parseTest "litTest01" litN3Graph_g1 lit_g1 noError + , parseTest "litTest02" litN3Graph_g2 lit_g1 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 :: String +exoticN3Graph_x1 = + 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 :: String +exoticN3Graph_x1b = + 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 :: String +exoticN3Graph_x2 = + 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 :: String +exoticN3Graph_x4 = + commonPrefixes ++ + " base1:s1 = (base1:o1 base2:o2 base3:o3 \"l1\") .\n" + +exoticN3Graph_x5 :: String +exoticN3Graph_x5 = + commonPrefixes ++ + " (base1:o1 base2:o2 base3:o3 \"l1\") = base1:s1 .\n" + +-- Formula nodes, with and without :- + +exoticN3Graph_x7 :: String +exoticN3Graph_x7 = + 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 :: String +exoticN3Graph_x12 = + 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 :: String +keywordN3Graph_01 = + "@keywords .\n" ++ + "b a c . " + +-- a modification of simpleN3Graph_g8 +keywordN3Graph_02 :: String +keywordN3Graph_02 = + commonPrefixes ++ + "@keywords a , is, of ,has.\n" ++ + " 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" + +-- a modification of simpleN3Graph_g83 +keywordN3Graph_03 :: String +keywordN3Graph_03 = + 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 -> String -> String -> Test +failTest lbl gr pe = parseTest lbl gr emptyRDFGraph pe + +failN3Graph_g1 :: String +failN3Graph_g1 = + commonPrefixes ++ + " base1:s1 base2:p2 unknown3:o3 . " + +fail1 :: String +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." + ] + +failTestSuite :: Test +failTestSuite = TestList + [ failTest "failTest01" failN3Graph_g1 fail1 + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ charTestSuite + , nameTestSuite + , prefixTestSuite + , absUriRefTestSuite + , uriRef2TestSuite + , simpleTestSuite + , litTestSuite + , exoticTestSuite + , keywordTestSuite + , failTestSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/NTTest.hs b/tests/NTTest.hs new file mode 100644 --- /dev/null +++ b/tests/NTTest.hs @@ -0,0 +1,268 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : NTTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This Module contains test cases for the NTriples modules: +-- "NTParser" and "NTFormatter". +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.NTParser (parseNT) +import Swish.RDF.NTFormatter (formatGraphAsString) + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , emptyRDFGraph + , toRDFGraph + ) + +import Swish.Utils.Namespace (makeUriScopedName) + +import Swish.RDF.Vocabulary (langName, rdf_XMLLiteral) + +import Swish.RDF.GraphClass (arc) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertEqual, runTestTT ) + +------------------------------------------------------------ +-- Parser tests +------------------------------------------------------------ + +-- check that parsing the input creates the expected graph + +checkGraph :: String -> String -> 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 = "" + +-- check that the +-- parseNT input == parseNT (formatGraph (parse NT input)) +-- +roundTrip :: String -> String -> Test +roundTrip lbl inp = + let (pErr1, pGr1) = case parseNT inp of + Right g -> (noError, g) + Left s -> (s, emptyRDFGraph) + + inp2 = formatGraphAsString pGr1 + + (pErr2, pGr2) = case parseNT inp2 of + Right g -> (noError, g) + Left s -> (s, emptyRDFGraph) + + in TestList + [ TestCase (assertEqual ("roundTrip-parsing1:"++lbl) noError pErr1) + , TestCase (assertEqual ("roundTrip-parsing2:"++lbl) noError pErr2) + , TestCase (assertEqual ("roundTrip-graph:"++lbl) 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 +-- retrived on 2011-03-23 11:25:46 +-- +------------------------------------------------------------ + +w3cTest :: String +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 $ 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 :: RDFLabel +l0 = Lit "" Nothing +l1 = Lit "l1" Nothing +l2 = Lit "l2-'\"line1\"'\n\nl2-'\"\"line2\"\"'" Nothing +l3 = Lit "l3--\r\"'\\--\x20&--\x17A&--" Nothing + +lfr, lgben, lxml1, lxml2 :: RDFLabel +lfr = Lit "chat" (Just $ langName "fr") +lgben = Lit "football" (Just $ langName "en-gb") +lxml1 = Lit "
" (Just rdf_XMLLiteral) +lxml2 = Lit "chat" (Just rdf_XMLLiteral) + +b1 , b2 :: RDFLabel +b1 = Blank "x1" +b2 = Blank "genid23" + +------------------------------------------------------------ +-- Construct graphs for testing +------------------------------------------------------------ + +g0 :: RDFGraph +g0 = toRDFGraph [] + +mkGr1 :: RDFLabel -> RDFLabel -> RDFLabel -> RDFGraph +mkGr1 s p o = toRDFGraph [arc s p o] + +g1, g2, g3, g4, g5, g6, g7, g8, g9, g10, g11 :: 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 + +gm1 :: RDFGraph +gm1 = toRDFGraph [arc b2 p2 b1, arc b2 p1 o1] + +------------------------------------------------------------ +-- Input documents +------------------------------------------------------------ + +empty1, empty2, empty3, empty4, empty5 :: String + +{- +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 :: String + +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 . " + +graphm1, graphm1r :: String + +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 "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 "graphm1" graphm1 gm1 + , checkGraph "graphm1r" graphm1r gm1 + ] + +allTests :: Test +allTests = + TestList + [ rTests + , eTests + , gTests + ] + +main :: IO () +main = runTestTT allTests >> return () + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/QNameTest.hs b/tests/QNameTest.hs new file mode 100644 --- /dev/null +++ b/tests/QNameTest.hs @@ -0,0 +1,334 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : QNameTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines test cases for QName data +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.Utils.QName + ( QName(..) + , newQName, qnameFromPair, qnameFromURI + , getNamespace, getLocalName, getQNameURI + , splitURI + ) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertEqual + , runTestTT + ) + + + + +------------------------------------------------------------ +-- Define some common values +------------------------------------------------------------ + +base1, base2, base3, base4, base5 :: 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" +base5 = "http://id.ninebynine.org/wip/2003/test/graph5/" + +qb1s1, qb2s2, qb3s3, qb3, qb3bm, qb4m :: QName +qb1s1 = QName base1 "s1" +qb2s2 = QName base2 "s2" +qb3s3 = QName base3 "s3" +qb3 = QName base3 "" +qb3bm = QName base3 "basemore" +qb4m = QName base4 "more" + +qb5, qb5s5 :: QName +qb5 = QName base5 "" +qb5s5 = QName base5 "s5" + +qb1st1, qb2st2, qb3st3 :: QName +qb1st1 = QName base1 "st1" +qb2st2 = QName base2 "st2" +qb3st3 = QName base3 "st3" + +------------------------------------------------------------ +-- QName equality tests +------------------------------------------------------------ + +testQNameEq :: String -> Bool -> QName -> QName -> Test +testQNameEq lab eq n1 n2 = + TestCase ( assertEqual ("testQNameEq:"++lab) 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 ++ "-" ++ 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" + +qp1, qp2 :: QName +qp1 = qnameFromPair (base1,"s1") +qp2 = qnameFromPair (base1,"s2") + +qu1, qu2, qu3, qu4, qu5 :: QName +qu1 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" +qu2 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" +qu3 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph3/node" +qu4 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph5/" +qu5 = qnameFromURI "http://id.ninebynine.org/wip/2003/test/graph5/s5" + +testMakeQNameSuite :: Test +testMakeQNameSuite = + TestList + [ testQNameEq "testnq01" True nq1 qb1s1 + , testQNameEq "testnq02" False nq2 qb1s1 + , testQNameEq "testqp01" True qp1 qb1s1 + , testQNameEq "testqp02" False qp2 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 + ] + +------------------------------------------------------------ +-- Extract components +------------------------------------------------------------ + +testStringEq :: String -> String -> String -> Test +testStringEq lab s1 s2 = + TestCase ( assertEqual ("testStringEq:"++lab) s1 s2 ) + +testPartQNameSuite :: Test +testPartQNameSuite = + TestList + [ testStringEq "testGetNamespace01" + "http://id.ninebynine.org/wip/2003/test/graph1/node#" + (getNamespace qb1s1) + , testStringEq "testGetNamespace02" + "http://id.ninebynine.org/wip/2003/test/graph2/node/" + (getNamespace qb2s2) + , testStringEq "testGetNamespace03" + "http://id.ninebynine.org/wip/2003/test/graph3/node" + (getNamespace qb3s3) + , testStringEq "testGetNamespace04" + "http://id.ninebynine.org/wip/2003/test/graph3/node" + (getNamespace qb3) + , testStringEq "testGetLocalName01" + "s1" (getLocalName qb1s1) + , testStringEq "testGetLocalName02" + "s2" (getLocalName qb2s2) + , testStringEq "testGetLocalName03" + "s3" (getLocalName qb3s3) + , testStringEq "testGetLocalName04" + "" (getLocalName qb3) + , testStringEq "testGetQNameURI01" + "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" + (getQNameURI qb1s1) + , testStringEq "testGetQNameURI02" + "http://id.ninebynine.org/wip/2003/test/graph2/node/s2" + (getQNameURI qb2s2) + , testStringEq "testGetQNameURI03" + "http://id.ninebynine.org/wip/2003/test/graph3/nodes3" + (getQNameURI qb3s3) + , testStringEq "testGetQNameURI04" + "http://id.ninebynine.org/wip/2003/test/graph3/node" + (getQNameURI qb3) + ] + +------------------------------------------------------------ +-- Maybe Qname comparison +------------------------------------------------------------ + +testMaybeQNameEq :: String -> Bool -> (Maybe QName) -> (Maybe QName) -> Test +testMaybeQNameEq lab eq n1 n2 = + TestCase ( assertEqual ("testMaybeQNameEq:"++lab) eq (n1==n2) ) + +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 lab le n1 n2 = + TestCase ( assertEqual ("testQNameLe:"++lab) 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) + ] + +------------------------------------------------------------ +-- 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 ) ) + +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/", "" ) + , 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" ) + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testQNameEqSuite + , testMakeQNameSuite + , testPartQNameSuite + , testMaybeQNameEqSuite + , testQNameLeSuite + , testShowQNameSuite + , testSplitURISuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFDatatypeXsdIntegerTest.hs b/tests/RDFDatatypeXsdIntegerTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFDatatypeXsdIntegerTest.hs @@ -0,0 +1,1855 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFDatatypeXsdIntegerTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains test cases for variable binding values and +-- variable binding modifier values. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.RDFDatatypeXsdInteger + ( rdfDatatypeXsdInteger + , rdfDatatypeValXsdInteger + , typeNameXsdInteger, namespaceXsdInteger + , axiomsXsdInteger, rulesXsdInteger + , prefixXsdInteger + ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding ) + +import Swish.RDF.RDFRuleset + ( RDFRule + , makeRDFGraphFromN3String + ) + +import Swish.RDF.RDFDatatype + ( RDFDatatypeMod + , applyRDFDatatypeMod + ) + +import Swish.RDF.RDFGraph + ( RDFLabel(..), RDFGraph + ) + +import Swish.RDF.ClassRestrictionRule (falseGraphStr) + +import Swish.RDF.Datatype + ( typeName, typeRules, typeMkRules + , getTypeAxiom, getTypeRule + , DatatypeVal(..) + , getDTMod + , DatatypeMap(..) + , DatatypeMod(..) + , nullDatatypeMod + ) + +import Swish.RDF.Ruleset + ( Ruleset(..) + , getRulesetRule + ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..) + , nullFormula, nullRule + ) + +import Swish.RDF.VarBinding (makeVarBinding) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + , makeScopedName + ) + +import Swish.RDF.Vocabulary (namespaceDefault) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , mapFindMaybe + ) + +import Swish.Utils.ListHelpers + ( equiv ) + +import Test.HUnit + ( Test(TestCase,TestList) + , Assertion + , assertBool, assertEqual, assertFailure + , runTestTT + ) + +import Control.Monad (unless) + +import Data.Maybe (isJust, fromMaybe) + + +------------------------------------------------------------ +-- 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 bv = + TestCase ( assertBool ("test:"++lab) bv ) + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab a1 a2 = + TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) + +testElem :: (Eq a, Show a) => String -> a -> [a] -> Test +testElem lab a1 as = + TestCase ( assertMember ("testElem:"++lab) a1 as ) + +testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test +testLe lab eq a1 a2 = + TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) + +-- Test for Just x or Nothing + +testJust :: String -> Maybe a -> Test +testJust lab av = + TestCase ( assertBool ("testJust:"++lab) (isJust av) ) + +testNothing :: String -> Maybe a -> Test +testNothing lab av = + TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) + +-- Compare lists and lists of lists and Maybe lists for set equivalence: + +data ListTest a = ListTest [a] + +instance (Eq a) => Eq (ListTest a) where + (ListTest a1) == (ListTest a2) = a1 `equiv` a2 + +instance (Show a) => Show (ListTest a) where + show (ListTest a) = show a + +data MaybeListTest a = MaybeListTest (Maybe [a]) + +instance (Eq a) => Eq (MaybeListTest a) where + MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 + MaybeListTest Nothing == MaybeListTest Nothing = True + _ == _ = False + +instance (Show a) => Show (MaybeListTest a) where + show (MaybeListTest a) = show a + +testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testEqv lab a1 a2 = + TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) + +testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test +testEqvEqv lab a1 a2 = + TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest $ map ListTest a1 + ma2 = ListTest $ map ListTest a2 + +testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test +testHasEqv lab a1 a2 = + TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest a1 + ma2 = map ListTest a2 + +testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test +testMaybeEqv lab a1 a2 = + TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) + where + ma1 = (MaybeListTest a1) + ma2 = (MaybeListTest a2) + +------------------------------------------------------------ +-- Misc values +------------------------------------------------------------ + +xsd_int_name :: String -> ScopedName +xsd_int_name nam = ScopedName namespaceXsdInteger nam + +axiomXsdIntegerDT :: ScopedName +axiomXsdIntegerDT = xsd_int_name "dt" + +ruleXsdIntegerAbs, ruleXsdIntegerNeg, ruleXsdIntegerSum, + ruleXsdIntegerDiff, ruleXsdIntegerProd, ruleXsdIntegerDivMod, + ruleXsdIntegerPower, ruleXsdIntegerEq, ruleXsdIntegerNe, + ruleXsdIntegerLt, ruleXsdIntegerLe, ruleXsdIntegerGt, + ruleXsdIntegerGe :: ScopedName +ruleXsdIntegerAbs = xsd_int_name "Abs" +ruleXsdIntegerNeg = xsd_int_name "Neg" +ruleXsdIntegerSum = xsd_int_name "Sum" +ruleXsdIntegerDiff = xsd_int_name "Diff" +ruleXsdIntegerProd = xsd_int_name "Prod" +ruleXsdIntegerDivMod = xsd_int_name "DivMod" +ruleXsdIntegerPower = xsd_int_name "Power" +ruleXsdIntegerEq = xsd_int_name "Eq" +ruleXsdIntegerNe = xsd_int_name "Ne" +ruleXsdIntegerLt = xsd_int_name "Lt" +ruleXsdIntegerLe = xsd_int_name "Le" +ruleXsdIntegerGt = xsd_int_name "Gt" +ruleXsdIntegerGe = xsd_int_name "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 (typeRules rdfDatatypeXsdInteger) + , testEqv "testDatatype03" axiomsXsdInteger $ + rsAxioms (typeRules rdfDatatypeXsdInteger) + , testEqv "testDatatype04" rulesXsdInteger $ + rsRules (typeRules rdfDatatypeXsdInteger) + , 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 = xsd_int_name "abs" +dmodXsdIntegerNeg = xsd_int_name "neg" +dmodXsdIntegerSum = xsd_int_name "sum" +dmodXsdIntegerDiff = xsd_int_name "diff" +dmodXsdIntegerProd = xsd_int_name "prod" +dmodXsdIntegerDivMod = xsd_int_name "divmod" +dmodXsdIntegerPower = xsd_int_name "power" +dmodXsdIntegerEq = xsd_int_name "eq" +dmodXsdIntegerNe = xsd_int_name "ne" +dmodXsdIntegerLt = xsd_int_name "lt" +dmodXsdIntegerLe = xsd_int_name "le" +dmodXsdIntegerGt = xsd_int_name "gt" +dmodXsdIntegerGe = xsd_int_name "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 l Nothing) -- (Variable,Untyped literal) + +rdfVI :: (String, String) -> (RDFLabel, RDFLabel) +rdfVI (v,l) = (Var v,Lit l (Just 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 "" "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 +------------------------------------------------------------ + +mkGraph :: String -> RDFGraph +mkGraph grstr = makeRDFGraphFromN3String (prefixXsdInteger++base++grstr) + where + base = "@prefix : <"++nsURI namespaceDefault++"> . \n" + +testRuleFwd :: String -> Maybe (Rule RDFGraph) -> String -> [String] -> 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) -> String -> [[String]] -> Test +testRuleBwd lab (Just rule) antstr prestrss = + let + antgr = mkGraph antstr + pregrss = map (map mkGraph) prestrss + in + testEqvEqv 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 + +-- abs + +abs01inp :: String +abs01inp = + "_:a a xsd_integer:Abs ; " + +++ " rdf:_2 \"1\"^^xsd:integer . " + +abs01fwd :: [String] +abs01fwd = + [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] + +abs01bwd :: [[String]] +abs01bwd = [] + +abs02inp :: String +abs02inp = + "_:a a xsd_integer:Abs ; " + +++ " rdf:_2 \"-1\"^^xsd:integer . " + +abs02fwd :: [String] +abs02fwd = + [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] + +abs02bwd :: [[String]] +abs02bwd = + [] + +abs03inp :: String +abs03inp = + "_:a a xsd_integer:Abs ; " + +++ " rdf:_1 \"1\"^^xsd:integer . " + +abs03fwd :: [String] +abs03fwd = [] + +abs03bwd :: [[String]] +abs03bwd = + [ [ "_:a a xsd_integer:Abs . " + , "_:a rdf:_2 \"1\"^^xsd:integer . " + ] + , [ "_:a a xsd_integer:Abs . " + , "_:a rdf:_2 \"-1\"^^xsd:integer . " + ] + ] + +abs04inp :: String +abs04inp = + "_:a a xsd_integer:Abs ; " + +++ " rdf:_1 \"-1\"^^xsd:integer . " + +abs04fwd :: [String] +abs04fwd = + [ falseGraphStr + ] + +abs04bwd :: [[String]] +abs04bwd = + [ [ falseGraphStr + ] + ] + +-- neg + +neg01inp :: String +neg01inp = + "_:a a xsd_integer:Neg ; " + +++ " rdf:_2 \"1\"^^xsd:integer . " + +neg01fwd :: [String] +neg01fwd = + [ "_:a rdf:_1 \"-1\"^^xsd:integer . " ] + +neg01bwd :: [[String]] +neg01bwd = + [ [ "_:a a xsd_integer:Neg . " + , "_:a rdf:_1 \"-1\"^^xsd:integer . " + ] + ] + +neg02inp :: String +neg02inp = + "_:a a xsd_integer:Neg ; " + +++ " rdf:_2 \"-2\"^^xsd:integer . " + +neg02fwd :: [String] +neg02fwd = + [ "_:a rdf:_1 \"2\"^^xsd:integer . " ] + +neg02bwd :: [[String]] +neg02bwd = + [ [ "_:a a xsd_integer:Neg . " + , "_:a rdf:_1 \"2\"^^xsd:integer . " + ] + ] + +-- sum + +sum01inp :: String +sum01inp = + "_:a a xsd_integer:Sum ; " + +++ " rdf:_2 \"31\"^^xsd:integer ; " + +++ " rdf:_3 \"20\"^^xsd:integer . " + +sum01fwd :: [String] +sum01fwd = + [ "_:a rdf:_1 \"51\"^^xsd:integer . " ] + +sum01bwd :: [[String]] +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 :: String +sum02inp = + "_:a a xsd_integer:Sum ; " + +++ " rdf:_1 \"52\"^^xsd:integer ; " + +++ " rdf:_3 \"21\"^^xsd:integer . " + +sum02fwd :: [String] +sum02fwd = + [ "_:a rdf:_2 \"31\"^^xsd:integer . " ] + +sum02bwd :: [[String]] +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 :: String +sum03inp = + "_:a a xsd_integer:Sum ; " + +++ " rdf:_1 \"53\"^^xsd:integer ; " + +++ " rdf:_2 \"32\"^^xsd:integer . " + +sum03fwd :: [String] +sum03fwd = + [ "_:a rdf:_3 \"21\"^^xsd:integer . " ] + +sum03bwd :: [[String]] +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 :: String +diff01inp = + "_:a a xsd_integer:Diff ; " + +++ " rdf:_2 \"222\"^^xsd:integer ; " + +++ " rdf:_3 \"333\"^^xsd:integer . " + +diff01fwd :: [String] +diff01fwd = + [ "_:a rdf:_1 \"-111\"^^xsd:integer . " ] + +diff01bwd :: [[String]] +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 . " + ] + ] + +diff02inp :: String +diff02inp = + "_:a a xsd_integer:Diff ; " + +++ " rdf:_1 \"-111\"^^xsd:integer ; " + +++ " rdf:_3 \"333\"^^xsd:integer . " + +diff02fwd :: [String] +diff02fwd = + [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] + +diff02bwd :: [[String]] +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 . " + ] + ] + +diff03inp :: String +diff03inp = + "_:a a xsd_integer:Diff ; " + +++ " rdf:_1 \"-111\"^^xsd:integer ; " + +++ " rdf:_2 \"222\"^^xsd:integer . " + +diff03fwd :: [String] +diff03fwd = + [ "_:a rdf:_3 \"333\"^^xsd:integer . " ] + +diff03bwd :: [[String]] +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 :: String +prod01inp = + "_:a a xsd_integer:Prod ; " + +++ " rdf:_2 \"222\"^^xsd:integer ; " + +++ " rdf:_3 \"3\"^^xsd:integer . " + +prod01fwd :: [String] +prod01fwd = + [ "_:a rdf:_1 \"666\"^^xsd:integer . " ] + +prod01bwd :: [[String]] +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 . " + ] + ] + +prod02inp :: String +prod02inp = + "_:a a xsd_integer:Prod ; " + +++ " rdf:_1 \"666\"^^xsd:integer ; " + +++ " rdf:_3 \"3\"^^xsd:integer . " + +prod02fwd :: [String] +prod02fwd = + [ "_:a rdf:_2 \"222\"^^xsd:integer . " ] + +prod02bwd :: [[String]] +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 . " + ] + ] + +prod03inp :: String +prod03inp = + "_:a a xsd_integer:Prod ; " + +++ " rdf:_1 \"666\"^^xsd:integer ; " + +++ " rdf:_2 \"222\"^^xsd:integer . " + +prod03fwd :: [String] +prod03fwd = + [ "_:a rdf:_3 \"3\"^^xsd:integer . " ] + +prod03bwd :: [[String]] +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 :: String +divmod01inp = + "_:a a xsd_integer:DivMod ; " + +++ " rdf:_3 \"33\"^^xsd:integer ; " + +++ " rdf:_4 \"5\"^^xsd:integer . " + +divmod01fwd :: [String] +divmod01fwd = + [ "_:a rdf:_1 \"6\"^^xsd:integer . " + +++ "_:a rdf:_2 \"3\"^^xsd:integer . " + ] + +divmod01bwd :: [[String]] +divmod01bwd = + [ {- "_:a a xsd_integer:DivMod . " + , "_:a rdf:_1 \"6\"^^xsd:integer . " + , "_:a rdf:_2 \"3\"^^xsd:integer . " + , "_:a rdf:_4 \"5\"^^xsd:integer . " + -} + ] + +divmod02inp :: String +divmod02inp = + "_:a a xsd_integer:DivMod ; " + +++ " rdf:_1 \"6\"^^xsd:integer ; " + +++ " rdf:_2 \"3\"^^xsd:integer ; " + +++ " rdf:_4 \"5\"^^xsd:integer . " + +divmod02fwd :: [String] +divmod02fwd = + [ ] + +divmod02bwd :: [[String]] +divmod02bwd = + [ {- "_:a a xsd_integer:DivMod . " + , "_:a rdf:_3 \"33\"^^xsd:integer . " + , "_:a rdf:_4 \"5\"^^xsd:integer . " + -} + ] + +divmod03inp :: String +divmod03inp = + "_:a a xsd_integer:DivMod ; " + +++ " rdf:_3 \"-33\"^^xsd:integer ; " + +++ " rdf:_4 \"5\"^^xsd:integer . " + +divmod03fwd :: [String] +divmod03fwd = + [ "_:a rdf:_1 \"-7\"^^xsd:integer . " + +++ "_:a rdf:_2 \"2\"^^xsd:integer . " + ] + +divmod03bwd :: [[String]] +divmod03bwd = + [ ] + +-- power + +power01inp :: String +power01inp = + "_:a a xsd_integer:Power ; " + +++ " rdf:_2 \"2\"^^xsd:integer ; " + +++ " rdf:_3 \"5\"^^xsd:integer . " + +power01fwd :: [String] +power01fwd = + [ "_:a rdf:_1 \"32\"^^xsd:integer . " ] + +power01bwd :: [[String]] +power01bwd = + [ ] + +power02inp :: String +power02inp = + "_:a a xsd_integer:Power ; " + +++ " rdf:_2 \"111\"^^xsd:integer ; " + +++ " rdf:_3 \"0\"^^xsd:integer . " + +power02fwd :: [String] +power02fwd = + [ "_:a rdf:_1 \"1\"^^xsd:integer . " ] + +power02bwd :: [[String]] +power02bwd = + [ ] + +power03inp :: String +power03inp = + "_:a a xsd_integer:Power ; " + +++ " rdf:_2 \"22\"^^xsd:integer ; " + +++ " rdf:_3 \"-33\"^^xsd:integer . " + +power03fwd :: [String] +power03fwd = + [ falseGraphStr ] + +power03bwd :: [[String]] +power03bwd = + [ [ falseGraphStr ] + ] + +-- eq + +eq01inp :: String +eq01inp = + "_:a a xsd_integer:Eq ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +eq01fwd :: [String] +eq01fwd = [ ] + +eq01bwd :: [[String]] +eq01bwd = [ ] + +eq02inp :: String +eq02inp = + "_:a a xsd_integer:Eq ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +eq02fwd :: [String] +eq02fwd = [ falseGraphStr ] + +eq02bwd :: [[String]] +eq02bwd = [ [falseGraphStr] ] + +eq03inp :: String +eq03inp = + "_:a a xsd_integer:Eq ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +eq03fwd :: [String] +eq03fwd = [ falseGraphStr ] + +eq03bwd :: [[String]] +eq03bwd = [ [falseGraphStr] ] + +-- ne + +ne01inp :: String +ne01inp = + "_:a a xsd_integer:Ne ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +ne01fwd :: [String] +ne01fwd = [ falseGraphStr ] + +ne01bwd :: [[String]] +ne01bwd = [ [falseGraphStr] ] + +ne02inp :: String +ne02inp = + "_:a a xsd_integer:Ne ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +ne02fwd :: [String] +ne02fwd = [ ] + +ne02bwd :: [[String]] +ne02bwd = [ ] + +ne03inp :: String +ne03inp = + "_:a a xsd_integer:Ne ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +ne03fwd :: [String] +ne03fwd = [ ] + +ne03bwd :: [[String]] +ne03bwd = [ ] + +-- lt + +lt01inp :: String +lt01inp = + "_:a a xsd_integer:Lt ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +lt01fwd :: [String] +lt01fwd = [ falseGraphStr ] + +lt01bwd :: [[String]] +lt01bwd = [ [falseGraphStr] ] + +lt02inp :: String +lt02inp = + "_:a a xsd_integer:Lt ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +lt02fwd :: [String] +lt02fwd = [ ] + +lt02bwd :: [[String]] +lt02bwd = [ ] + +lt03inp :: String +lt03inp = + "_:a a xsd_integer:Lt ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +lt03fwd :: [String] +lt03fwd = [ falseGraphStr ] + +lt03bwd :: [[String]] +lt03bwd = [ [falseGraphStr] ] + +-- le + +le01inp :: String +le01inp = + "_:a a xsd_integer:Le ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +le01fwd :: [String] +le01fwd = [ ] + +le01bwd :: [[String]] +le01bwd = [ ] + +le02inp :: String +le02inp = + "_:a a xsd_integer:Le ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +le02fwd :: [String] +le02fwd = [ ] + +le02bwd :: [[String]] +le02bwd = [ ] + +le03inp :: String +le03inp = + "_:a a xsd_integer:Le ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +le03fwd :: [String] +le03fwd = [ falseGraphStr ] + +le03bwd :: [[String]] +le03bwd = [ [falseGraphStr] ] + +-- gt + +gt01inp :: String +gt01inp = + "_:a a xsd_integer:Gt ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +gt01fwd :: [String] +gt01fwd = [ falseGraphStr ] + +gt01bwd :: [[String]] +gt01bwd = [ [falseGraphStr] ] + +gt02inp :: String +gt02inp = + "_:a a xsd_integer:Gt ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +gt02fwd :: [String] +gt02fwd = [ falseGraphStr ] + +gt02bwd :: [[String]] +gt02bwd = [ [falseGraphStr] ] + +gt03inp :: String +gt03inp = + "_:a a xsd_integer:Gt ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +gt03fwd :: [String] +gt03fwd = [ ] + +gt03bwd :: [[String]] +gt03bwd = [ ] + +-- ge + +ge01inp :: String +ge01inp = + "_:a a xsd_integer:Ge ; " + +++ " rdf:_1 \"11\"^^xsd:integer ; " + +++ " rdf:_2 \"11\"^^xsd:integer . " + +ge01fwd :: [String] +ge01fwd = [ ] + +ge01bwd :: [[String]] +ge01bwd = [ ] + +ge02inp :: String +ge02inp = + "_:a a xsd_integer:Ge ; " + +++ " rdf:_1 \"21\"^^xsd:integer ; " + +++ " rdf:_2 \"22\"^^xsd:integer . " + +ge02fwd :: [String] +ge02fwd = [ falseGraphStr ] + +ge02bwd :: [[String]] +ge02bwd = [ [falseGraphStr] ] + +ge03inp :: String +ge03inp = + "_:a a xsd_integer:Ge ; " + +++ " rdf:_1 \"31\"^^xsd:integer ; " + +++ " rdf:_2 \"-32\"^^xsd:integer . " + +ge03fwd :: [String] +ge03fwd = [ ] + +ge03bwd :: [[String]] +ge03bwd = [ ] + +-- Test cases from design notes + +infixr 5 +++ +(+++) :: String -> ShowS +(+++) str = ((str++"\n")++) + +-- Make a vector of rules using the graph string below + +pvRules :: [RDFRule] +-- pvRules = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr +pvRules = typeMkRules rdfDatatypeXsdInteger gr + where + gr = (mkGraph pvRulesStr) + +pvRulesStr :: String +pvRulesStr = + ":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 = mapFindMaybe + (ScopedName namespaceDefault "PassengerVehicle") + (LookupMap pvRules) +pvRule1 = mapFindMaybe + (ScopedName namespaceDefault "PassengerVehicle1") + (LookupMap pvRules) + +pv01inp :: String +pv01inp = + "_:a a :PassengerVehicle ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :standingCapacity \"20\"^^xsd:integer . " + +pv01fwd :: [String] +pv01fwd = + [ "_:a :totalCapacity \"50\"^^xsd:integer . " ] + +pv01bwd :: [[String]] +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 :: String +pv02inp = + "_:a a :PassengerVehicle ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :totalCapacity \"51\"^^xsd:integer . " + +++ "_:b a :PassengerVehicle ; " + +++ " :standingCapacity \"20\"^^xsd:integer ; " + +++ " :totalCapacity \"52\"^^xsd:integer . " + +pv02fwd :: [String] +pv02fwd = + [ "_:a :standingCapacity \"21\"^^xsd:integer . " + , "_:b :seatedCapacity \"32\"^^xsd:integer . " + ] + +pv02bwd :: [[String]] +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 :: String +pv03inp = + "_:a a :PassengerVehicle ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :standingCapacity \"23\"^^xsd:integer ; " + +++ " :totalCapacity \"53\"^^xsd:integer . " + +pv03fwd :: [String] +pv03fwd = [] + +pv04inp :: String +pv04inp = + "_:a a :PassengerVehicle ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :standingCapacity \"20\"^^xsd:integer ; " + +++ " :totalCapacity \"54\"^^xsd:integer . " + +pv04fwd :: [String] +pv04fwd = + [ "_:a :standingCapacity \"24\"^^xsd:integer . " + +++ "_:a :seatedCapacity \"34\"^^xsd:integer . " + +++ "_:a :totalCapacity \"50\"^^xsd:integer . " + ] + +pv05inp :: String +pv05inp = + "_:a a :PassengerVehicle1 ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :standingCapacity \"25\"^^xsd:integer ; " + +++ " :totalCapacity \"55\"^^xsd:integer . " + +pv05fwd :: [String] +pv05fwd = [] + +pv06inp :: String +pv06inp = + "_:a a :PassengerVehicle1 ; " + +++ " :seatedCapacity \"30\"^^xsd:integer ; " + +++ " :standingCapacity \"20\"^^xsd:integer ; " + +++ " :totalCapacity \"56\"^^xsd:integer . " + +pv06fwd :: [String] +pv06fwd = + [ falseGraphStr + ] + +pv06bwd :: [[String]] +pv06bwd = + [ [ falseGraphStr + ] + ] + +pv07inp :: String +pv07inp = + "_:a a :PassengerVehicle ; " + +++ " :totalCapacity \"57\"^^xsd:integer . " + +pv07fwd :: [String] +pv07fwd = [] + +-- how come this isn't [[String]] ? +pv07bwd :: [String] +pv07bwd = [] + +-- Full suite for datatype rule tests + +testDatatypeRuleSuite :: Test +testDatatypeRuleSuite = TestList + [ testRuleFwd "testRuleFwdAbs01" ruleabs abs01inp abs01fwd + , testRuleFwd "testRuleFwdAbs02" ruleabs abs02inp abs02fwd + , testRuleFwd "testRuleFwdAbs03" ruleabs abs03inp abs03fwd + , testRuleFwd "testRuleFwdAbs04" ruleabs abs04inp abs04fwd + , testRuleFwd "testRuleFwdNeg01" ruleneg neg01inp neg01fwd + , testRuleFwd "testRuleFwdNeg02" ruleneg neg02inp neg02fwd + , testRuleFwd "testRuleFwdSum01" rulesum sum01inp sum01fwd + , testRuleFwd "testRuleFwdSum02" rulesum sum02inp sum02fwd + , testRuleFwd "testRuleFwdSum03" rulesum sum03inp sum03fwd + , testRuleFwd "testRuleFwdDiff01" rulediff diff01inp diff01fwd + , testRuleFwd "testRuleFwdDiff02" rulediff diff02inp diff02fwd + , testRuleFwd "testRuleFwdDiff03" rulediff diff03inp diff03fwd + , testRuleFwd "testRuleFwdProd01" ruleprod prod01inp prod01fwd + , testRuleFwd "testRuleFwdProd02" ruleprod prod02inp prod02fwd + , testRuleFwd "testRuleFwdProd03" ruleprod prod03inp prod03fwd + , testRuleFwd "testRuleFwdDivMod01" ruledivmod divmod01inp divmod01fwd + , testRuleFwd "testRuleFwdDivMod02" ruledivmod divmod02inp divmod02fwd + , testRuleFwd "testRuleFwdDivMod03" ruledivmod divmod03inp divmod03fwd + , testRuleFwd "testRuleFwdPower01" rulepower power01inp power01fwd + , testRuleFwd "testRuleFwdPower02" rulepower power02inp power02fwd + , testRuleFwd "testRuleFwdPower03" rulepower power03inp power03fwd + , testRuleFwd "testRuleFwdEq01" ruleeq eq01inp eq01fwd + , testRuleFwd "testRuleFwdEq02" ruleeq eq02inp eq02fwd + , testRuleFwd "testRuleFwdEq03" ruleeq eq03inp eq03fwd + , testRuleFwd "testRuleFwdNe01" rulene ne01inp ne01fwd + , testRuleFwd "testRuleFwdNe02" rulene ne02inp ne02fwd + , testRuleFwd "testRuleFwdNe03" rulene ne03inp ne03fwd + , testRuleFwd "testRuleFwdLt01" rulelt lt01inp lt01fwd + , testRuleFwd "testRuleFwdLt02" rulelt lt02inp lt02fwd + , testRuleFwd "testRuleFwdLt03" rulelt lt03inp lt03fwd + , testRuleFwd "testRuleFwdLe01" rulele le01inp le01fwd + , testRuleFwd "testRuleFwdLe02" rulele le02inp le02fwd + , testRuleFwd "testRuleFwdLe03" rulele le03inp le03fwd + , testRuleFwd "testRuleFwdGt01" rulegt gt01inp gt01fwd + , testRuleFwd "testRuleFwdGt02" rulegt gt02inp gt02fwd + , testRuleFwd "testRuleFwdGt03" rulegt gt03inp gt03fwd + , testRuleFwd "testRuleFwdGe01" rulege ge01inp ge01fwd + , testRuleFwd "testRuleFwdGe02" rulege ge02inp ge02fwd + , testRuleFwd "testRuleFwdGe03" rulege ge03inp ge03fwd + + -- backard chaining tests + , testRuleBwd "testRuleBwdAbs01" ruleabs abs01inp abs01bwd + , testRuleBwd "testRuleBwdAbs02" ruleabs abs02inp abs02bwd + , testRuleBwd "testRuleBwdAbs03" ruleabs abs03inp abs03bwd + , testRuleBwd "testRuleBwdAbs04" ruleabs abs04inp abs04bwd + , testRuleBwd "testRuleBwdNeg01" ruleneg neg01inp neg01bwd + , testRuleBwd "testRuleBwdNeg02" ruleneg neg02inp neg02bwd + , 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 divmod01bwd + , testRuleBwd "testRuleBwdDivMod02" ruledivmod divmod02inp divmod02bwd + , testRuleBwd "testRuleBwdDivMod03" ruledivmod divmod03inp divmod03bwd + , testRuleBwd "testRuleBwdPower01" rulepower power01inp power01bwd + , testRuleBwd "testRuleBwdPower02" rulepower power02inp power02bwd + , testRuleBwd "testRuleBwdPower03" rulepower power03inp power03bwd + , testRuleBwd "testRuleBwdEq01" ruleeq eq01inp eq01bwd + , testRuleBwd "testRuleBwdEq02" ruleeq eq02inp eq02bwd + , testRuleBwd "testRuleBwdEq03" ruleeq eq03inp eq03bwd + , testRuleBwd "testRuleBwdNe01" rulene ne01inp ne01bwd + , testRuleBwd "testRuleBwdNe02" rulene ne02inp ne02bwd + , testRuleBwd "testRuleBwdNe03" rulene ne03inp ne03bwd + , testRuleBwd "testRuleBwdLt01" rulelt lt01inp lt01bwd + , testRuleBwd "testRuleBwdLt02" rulelt lt02inp lt02bwd + , testRuleBwd "testRuleBwdLt03" rulelt lt03inp lt03bwd + , testRuleBwd "testRuleBwdLe01" rulele le01inp le01bwd + , testRuleBwd "testRuleBwdLe02" rulele le02inp le02bwd + , testRuleBwd "testRuleBwdLe03" rulele le03inp le03bwd + , testRuleBwd "testRuleBwdGt01" rulegt gt01inp gt01bwd + , testRuleBwd "testRuleBwdGt02" rulegt gt02inp gt02bwd + , testRuleBwd "testRuleBwdGt03" rulegt gt03inp gt03bwd + , testRuleBwd "testRuleBwdGe01" rulege ge01inp ge01bwd + , testRuleBwd "testRuleBwdGe02" rulege ge02inp ge02bwd + , testRuleBwd "testRuleBwdGe03" rulege ge03inp ge03bwd + + -- 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 :: Test +allTests = TestList + [ testDatatypeSuite + , testDatatypeValSuite + , testVarModifySuite + , testDatatypeRuleSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +trules = runTestTT testDatatypeRuleSuite + +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFGraphTest.hs b/tests/RDFGraphTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFGraphTest.hs @@ -0,0 +1,1227 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFGraphTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains test cases for module RDFGraph. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.Utils.LookupMap + ( LookupMap(..) + , mapFindMaybe ) + +import Swish.Utils.ListHelpers + ( equiv ) + +import Swish.RDF.GraphClass + ( Label(..), Arc, arc ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + , nullScopedName + , makeUriScopedName + ) + +import Swish.RDF.RDFGraph + ( RDFTriple, RDFGraph, RDFLabel(..), NSGraph(..) + , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral + , isDatatyped, isMemberProp + , isUri, isBlank, isQueryVar, makeBlank + , getScopedName + , LookupFormula(..), FormulaMap, emptyFormulaMap + , getArcs, addArc, merge + , remapLabels, remapLabelList + , setFormulae, getFormulae, setFormula, getFormula + , newNode, newNodes ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , langName + , rdf_XMLLiteral + ) + +import qualified Data.Traversable as T + +import Data.List + ( elemIndex ) + +import Data.Maybe + ( fromJust ) + +import Test.HUnit + ( Test(TestCase,TestList,TestLabel) + , assertBool, assertEqual, assertString + , runTestTT ) + +------------------------------------------------------------ +-- Common definitions +------------------------------------------------------------ + +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) ) + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq = testCompare "testEq" + +------------------------------------------------------------ +-- Test language tag comparisons +------------------------------------------------------------ + +type Lang = Maybe ScopedName + +lt0, lt1, lt2, lt3, lt4, lt5, lt6, + lt7, lt8 :: Lang +lt0 = Nothing +lt1 = Just (langName "en") +lt2 = Just (langName "EN") +lt3 = Just (langName "fr") +lt4 = Just (langName "FR") +lt5 = Just (langName "en-us") +lt6 = Just (langName "en-US") +lt7 = Just (langName "EN-us") +lt8 = Just (langName "EN-US") + +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:" + +testLangEqSuite :: Test +testLangEqSuite = TestList + [ testLangEq (tLab ll1 ll2) (tEq ll1 ll2) t1 t2 + | (ll1,t1) <- langlist , (ll2,t2) <- langlist ] + where + tLab ll1 ll2 = ll1 ++ "-" ++ ll2 + tEq ll1 ll2 = (ll1 == ll2) || + (ll1,ll2) `elem` langeqlist || + (ll2,ll1) `elem` langeqlist + +------------------------------------------------------------ +-- Define some common values +------------------------------------------------------------ + +base1, base2, base3, base4 :: Namespace +base1 = Namespace "base1" "http://id.ninebynine.org/wip/2003/test/graph1/node#" +base2 = Namespace "base2" "http://id.ninebynine.org/wip/2003/test/graph2/node/" +base3 = Namespace "base3" "http://id.ninebynine.org/wip/2003/test/graph3/node" +base4 = Namespace "base4" "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" + +qb1s1, qb2s2, qb3s3, qb3, qb3bm, qb4m :: ScopedName +qb1s1 = ScopedName base1 "s1" +qb2s2 = ScopedName base2 "s2" +qb3s3 = ScopedName base3 "s3" +qb3 = ScopedName base3 "" +qb3bm = ScopedName base3 "basemore" +qb4m = ScopedName base4 "more" + +s1, s2, s3, s4, s5, s6, s7, s8 :: RDFLabel +s1 = Res qb1s1 +s2 = Res qb2s2 +s3 = Res qb3s3 +s4 = Res qb3 +s5 = Blank "s5" +s6 = Res qb3bm +s7 = Res qb4m +s8 = Blank "s8" + +st1, st2, st3 :: RDFLabel +st1 = Res $ ScopedName base1 "st1" +st2 = Res $ ScopedName base2 "st2" +st3 = Res $ ScopedName 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 $ ScopedName base1 "p1" +p2 = Res $ ScopedName base2 "p2" +p3 = Res $ ScopedName base3 "p3" +p4 = Res $ ScopedName base3 "p4" + +o1, o2, o3, o4, o5, o6 :: RDFLabel +o1 = Res $ ScopedName base1 "o1" +o2 = Res $ ScopedName base2 "o2" +o3 = Res $ ScopedName base3 "o3" +o4 = Res qb3 +o5 = Blank "o5" +o6 = Blank "s5" + +qb1t1, qb1t2 :: ScopedName +qb1t1 = ScopedName base1 "type1" +qb1t2 = ScopedName base1 "type2" + +l1, l2, l3, l4, l5, l6, l7, l8, + l9, l10, l11, l12 :: RDFLabel +l1 = Lit "l1" Nothing +l2 = Lit "l2" (Just (langName "en")) +l3 = Lit "l2" (Just (langName "fr")) +l4 = Lit "l4" (Just qb1t1) +l5 = Lit "l4" (Just qb1t1) +l6 = Lit "l4" (Just qb1t1) +l7 = Lit "l4" (Just qb1t2) +l8 = Lit "l4" (Just qb1t2) +l9 = Lit "l4" (Just qb1t2) +l10 = Lit "l10" (Just rdf_XMLLiteral) +l11 = Lit "l10" (Just rdf_XMLLiteral) +l12 = Lit "l10" (Just rdf_XMLLiteral) + +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 $ ScopedName namespaceRDF "_1" +cm2 = Res $ ScopedName namespaceRDF "_234567" +nm1 = Res $ ScopedName namespaceRDF "987" +nm2 = Res $ ScopedName namespaceRDF "_987a65" + +------------------------------------------------------------ +-- RDFLabel construction and equality tests +------------------------------------------------------------ + +testLabelEq :: String -> Bool -> RDFLabel -> RDFLabel -> Test +testLabelEq = testCompareEq "testLabelEq:" + +nodelist :: [(String, RDFLabel)] +nodelist = + [ ("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), ("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 (tLab ll1 ll2) (tEq ll1 ll2) n1 n2 + | (ll1,n1) <- nodelist , (ll2,n2) <- nodelist ] + where + tLab ll1 ll2 = ll1 ++ "-" ++ ll2 + tEq ll1 ll2 = (ll1 == ll2) || + (ll1,ll2) `elem` nodeeqlist || + (ll2,ll1) `elem` nodeeqlist + +------------------------------------------------------------ +-- 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 rdf_XMLLiteral + +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 +------------------------------------------------------------ + +testNodeEq :: String -> RDFLabel -> RDFLabel -> Test +testNodeEq = testCompare "testNodeEq:" + +tnn01, tnn02, tnn03, tnn04, tnn05, tnn06, + tnn07, tnn08, tnn09 :: RDFLabel +tnn01 = (newNode v1 [b1,b3,v1,v2]) +tnn02 = (newNode b1 [b1,b3,v1,v2]) +tnn03 = (newNodes b1 [b1,b3,v1,v2])!!0 +tnn04 = (newNodes b1 [b1,b3,v1,v2])!!1 +tnn05 = (newNodes b1 [b1,b3,v1,v2])!!2 +tnn06 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!0 +tnn07 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!1 +tnn08 = (newNodes s1 [b1,b3,v1,v2,tnns3])!!2 +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 = + -- literals + [ "l1" + , "l11", "l12", "l10" + , "l2", "l3" + , "l5", "l6", "l4", "l8", "l9", "l7" + -- variables + , "v1", "v2" + -- URIs + , "o1", "p1", "s1" + , "o2", "p2", "s2" + , "s4", "o4", "s6", "s7" + , "o3", "p3", "p4", "s3" + -- blank nodes + , "b1", "b2", "b3", "b4" + , "o5", "s5", "s8" + ] + +testNodeOrdSuite :: Test +testNodeOrdSuite = TestList + [ testLabelOrd (tLab ll1 ll2) (tOrd ll1 ll2) n1 n2 + | (ll1,n1) <- nodelist , (ll2,n2) <- nodelist ] + where + tLab ll1 ll2 = ll1 ++ "-" ++ ll2 + tOrd ll1 ll2 + | tEq ll1 ll2 = EQ + | otherwise = compare (fromJust $ elemIndex ll1 nodeorder) + (fromJust $ 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, Arc RDFLabel)] +tlist = + [ (lab s p o,trp s p o) | s <- slist, p <- plist, o <- olist ] + where + lab (s,_) (p,_) (o,_) = 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 (tLab ll1 ll2) (tEq ll1 ll2) t1 t2 + | (ll1,t1) <- tlist , (ll2,t2) <- tlist ] + where + tLab ll1 ll2 = ll1 ++ "-" ++ ll2 + 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 :: 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 l4 +t06 = arc s3 p1 l10 + +t10, t11, t12 :: Arc RDFLabel +t10 = arc s1 p1 b1 +t11 = arc b1 p2 b2 +t12 = arc b2 p3 o1 + +t20, t21, t22 :: Arc RDFLabel +t20 = arc s1 p1 b3 +t21 = arc b3 p2 b4 +t22 = arc b4 p3 o1 + +tt01, tt02, tt03, tt04, tt05, tt06 :: Arc RDFLabel +tt01 = arc st1 p1 o1 +tt02 = arc st2 p1 o2 +tt03 = arc st3 p1 o3 +tt04 = arc st1 p1 l1 +tt05 = arc st2 p1 l4 +tt06 = arc st3 p1 l10 + +makeNewPrefixNamespace :: (String,Namespace) -> Namespace +makeNewPrefixNamespace (pre,ns) = Namespace pre (nsURI ns) + +nslist :: LookupMap Namespace +nslist = LookupMap $ map makeNewPrefixNamespace + [ ("base1",base1) + , ("base2",base2) + , ("base3",base3) + , ("base4",base4) + ] + +nslistalt :: LookupMap Namespace +nslistalt = LookupMap $ map makeNewPrefixNamespace + [ ("altbase1",base1) + , ("altbase2",base2) + , ("altbase3",base3) + ] + +toGraph :: [Arc RDFLabel] -> RDFGraph +toGraph stmts = NSGraph + { namespaces = nslist + , formulae = emptyFormulaMap + , statements = 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 = [t01] + } + +-- Construct version of g1 using just URIs + +uris1, urip1, urio1 :: ScopedName +uris1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#s1" +urip1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#p1" +urio1 = makeUriScopedName "http://id.ninebynine.org/wip/2003/test/graph1/node#o1" + +tu01 :: Arc RDFLabel +tu01 = arc (Res uris1) (Res urip1) (Res urio1) + +g1uri, g2, gt2, g3, gt3, g4, g5, g6, g7, g8, g9, g10 :: RDFGraph +g1uri = toGraph [tu01] +g2 = toGraph [t01,t02,t03,t04,t05,t06] +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] + +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 (tLab ll1 ll2) (tEq ll1 ll2) gg1 gg2 + | (ll1,gg1) <- glist , (ll2,gg2) <- glist ] + where + tLab ll1 ll2 = ll1 ++ "-" ++ ll2 + 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 + ] + +------------------------------------------------------------ +-- Test updating formulae +------------------------------------------------------------ + +testFormulaLookup :: + String -> FormulaMap RDFLabel -> RDFLabel -> Maybe RDFGraph -> Test +testFormulaLookup lab fs fl gr = + testCompare "testFormulaLookup:" lab gr jfg + where + jfg = mapFindMaybe 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 + +fm2, fm3, fm4, fm5, fm6, fm7 :: LookupMap (LookupFormula RDFLabel RDFGraph) +fm2 = LookupMap [Formula s2 g2] +fm3 = LookupMap [Formula s1 g1,Formula s2 g2,Formula s3 g3] +fm4 = LookupMap [Formula s1 g1,Formula s2 g3,Formula s3 g3] +fm5 = LookupMap [Formula s1 g1,Formula s2 g4,Formula s3 g6] +fm6 = LookupMap [Formula s1 g1,Formula s2 g5,Formula s3 g6] +fm7 = LookupMap [Formula s1 g1,Formula s2 g7,Formula s3 g6] + +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 (NSGraph RDFLabel) +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) + , 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 = fmap translate g1f1 +gt1f2a = setFormulae ftm2 gt1 +gt1f2b = fmap translate g1f2 +gt1f3a = setFormulae ftm3 gt1 +gt1f3b = fmap translate g1f3 +gt2f1a = gt2 +gt2f1b = fmap translate g2f1 +gt2f2a = setFormulae ftm2 gt2 +gt2f2b = fmap translate g2f2 +gt2f3a = setFormulae ftm3 gt2 +gt2f3b = fmap 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 = LookupMap [Formula st2 gt2] +ftm3 = LookupMap [Formula st1 gt1,Formula st2 gt2,Formula st3 gt3] + +-- Monadic translate tests, using Maybe Monad + +gt1f1aM, gt1f1bM, gt1f2aM, gt1f2bM, gt1f5M :: Maybe RDFGraph +gt1f1aM = Just gt1 +gt1f1bM = T.mapM translateM g1f1 +gt1f2aM = Just gt1f2a +gt1f2bM = T.mapM translateM g1f2 +gt1f5M = T.mapM translateM g1f5 + +ft1M, ft2M :: FormulaMap RDFLabel +ft1M = getFormulae $ fromJust gt1f1bM +ft2M = getFormulae $ fromJust 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 + , 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 ( assertEquiv ("testMerge:"++lab) gr (merge a1 a2) ) + where + grequiv gg1 gg2 = (getArcs gg1) `equiv` (getArcs gg2) + assertEquiv lbl gg1 gg2 = assertString $ + if grequiv gg1 gg2 then "" + else lbl++"\nExpected: "++(show gg1)++"\nObtained: "++(show gg2) + +testEquiv :: (Eq a) => String -> [a] -> [a] -> Test +testEquiv lab l1s l2s = TestCase $ assertBool lab (l1s `equiv` l2s) + +tm01, tm02, tm03, tm04, tm05, tm06, tm07, tm08, tm09, + tm10, tm11, tm12, tm13, tm14 :: Arc RDFLabel +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 :: Arc RDFLabel +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 :: Arc RDFLabel +tm41 = arc s1 p1 b2 +tm42 = arc b2 p1 o2 +tm43 = arc b2 p1 o3 +tm44 = arc b4 p2 b5 + +tm41a, tm44a :: Arc RDFLabel +tm41a = arc s1 p1 b4 +tm44a = arc b5 p2 b6 + +tm67, tm68, tm69, tm70, tm71, tm72, + tm73, tm74 :: Arc RDFLabel +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 + +gm1, gm11, gm2, gm2f, gm22, gm3, gm3f, gm33, + gm4, gm44 :: RDFGraph +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, gm6, gm66 :: RDFGraph +gm5 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 gm2] + , statements = [tm01,tm02,tm03] + } + +gm55 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 gm2,Formula b2 gm2f] + , statements = [tm01,tm02,tm03,tm41,tm42,tm43] + } + +gm6 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula ba1 gm2,Formula bn3 gm3] + , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14] + } + +gm66 = NSGraph + { namespaces = nslist + , formulae = LookupMap + [Formula ba1 gm2,Formula bn3 gm3 + ,Formula ba3 gm2f,Formula bn5 gm3f + ] + , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14 + ,tm67,tm68,tm69,tm70,tm71,tm72,tm73,tm74 + ] + } + +tm81, tm82, tm811, tm821, tm812, tm822 :: Arc RDFLabel +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 = LookupMap [Formula b1 gm81,Formula v2 gm81] + , statements = [tm81,tm82] + } + +gm85 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 gm82,Formula v4 gm82] + , statements = [tm811,tm821] + } +gm85a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm84 + +gm86 = NSGraph + { namespaces = nslist + , formulae = LookupMap [Formula b1 gm82,Formula vb4 gm82] + , statements = [tm812,tm822] + } +gm86a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm84 + +testMergeSuite :: Test +testMergeSuite = TestList + [ 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 + , testGraphEq "Remap07" True gm82 gm82a + , testEquiv "testRemapList07" gm82b2 gm82b1 + , testGraphEq "Remap08" True gm83 gm83a + , testGraphEq "Remap09" True gm85 gm85a + , testGraphEq "Remap10" True gm86 gm86a + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testLangEqSuite + , testNodeEqSuite + , testNodeClassSuite + , testNodeLocalSuite + , testNewNodeSuite + , testNodeOrdSuite + , testLabelOtherSuite + , testStmtEqSuite + , testGraphEqSuite + , testGraphEqSelSuite + , testGraphFormulaSuite + , testGraphTranslateSuite + , testMergeSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +geq = testGraphEqSuite +nord = testNodeOrdSuite +gtr = testGraphTranslateSuite + +gmm g1 g2 = grMatchMap g1 g2 +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFProofContextTest.hs b/tests/RDFProofContextTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFProofContextTest.hs @@ -0,0 +1,720 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFProofContextTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains RDF proof-checking test cases based on the RDF +-- semantics specifications, as capured in module RDFProofContext. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.BuiltInMap + ( rdfRulesetMap, allRulesets ) + +import Swish.RDF.RDFProofContext + ( rulesetRDF + , rulesetRDFS + , rulesetRDFD ) + +import Swish.RDF.RDFProof + ( RDFProof, RDFProofStep + , makeRDFProof, makeRDFProofStep ) + +import Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFRuleset + , nullRDFFormula + , makeRDFFormula ) + +import Swish.RDF.RDFGraph + ( RDFGraph ) + +import Swish.RDF.RDFGraphShowM() + +import Swish.RDF.Proof + ( Step(..) + , checkProof, checkStep + , explainProof) + +import Swish.RDF.Ruleset + ( getContextAxiom, getContextRule ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..) + , nullFormula, nullRule ) + +import Swish.Utils.Namespace + ( Namespace(..), ScopedName(..) ) + +import Swish.Utils.LookupMap + ( mapFindMaybe ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceRDFS + , namespaceRDFD + , namespaceXSD + , namespaceXsdType + , scopeRDF + , scopeRDFS + , scopeRDFD + ) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertBool, assertEqual + , runTestTT ) + +import Data.Maybe + ( isJust, isNothing, fromJust, fromMaybe ) + +-- misc helpers + +test :: String -> Bool -> Test +test lab tst = TestCase $ assertBool lab tst + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab e a = TestCase $ assertEqual lab e a + +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) + +testGr :: String -> RDFGraph -> [RDFGraph] -> Test +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 -> String -> String -> RDFFormula +makeFormula scope local gr = + makeRDFFormula scope local (prefix++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 = ScopedName ns loc + where + (pre,_:loc) = break (==':') nam + ns = case pre of + "rs_rdf" -> scopeRDF + "rs_rdfs" -> scopeRDFS + "rs_rdfd" -> scopeRDFD + "xsd_integer" -> (namespaceXsdType "integer") + "xsd_string" -> (namespaceXsdType "string") + _ -> error ("makeSName: Unrecognized prefix in rule name: "++nam) + +-- Common definitions + +prefix :: String +prefix = + "@prefix rdf: <" ++ nsURI namespaceRDF ++ "> . \n" ++ + "@prefix rdfs: <" ++ nsURI namespaceRDFS ++ "> . \n" ++ + "@prefix rdfd: <" ++ nsURI namespaceRDFD ++ "> . \n" ++ + "@prefix xsd: <" ++ nsURI namespaceXSD ++ "> . \n" ++ + "@prefix ex: . \n" ++ + " \n" + +scopeex :: Namespace +scopeex = Namespace "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 $ mapFindMaybe (namespaceXsdType "integer") rdfRulesetMap +rulesetXsdStr = fromJust $ mapFindMaybe (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 ." ++ + "ex:p2 rdf:type rdf:Property ." +bwd01 = formExpr $ makeFormula scopeex "bwd01a" $ + "_:s1 ex:p1 _:o1 . " ++ + "_: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 ; " ++ + " ex:p2a \"lit2\"^^rdf:XMLLiteral ; " ++ + " ex:p2b \"lit2\"^^rdf:XMLLiteral ." +con03lg = formExpr $ makeFormula scopeex "con03" $ + "ex:s ex:p1 _:l1 ; ex:p2a _:l2; ex:p2b _:l2 ." ++ + "_:l1 rdf:_allocatedTo \"lit1\"^^rdf:XMLLiteral ." ++ + "_:l2 rdf:_allocatedTo \"lit2\"^^rdf:XMLLiteral ." +con03r2 = formExpr $ makeFormula scopeex "con03" $ + "_:l1 rdf:type rdf:XMLLiteral ." ++ + "_: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 ; " ++ + " rdf:_2 ex:o2 . " +con04 = formExpr $ makeFormula scopeex "con04" $ + "rdf:_123 rdf:type rdf:Property ." ++ + "rdf:_2 rdf:type rdf:Property ." +bwd04 = formExpr $ makeFormula scopeex "bwd04a" $ + "_:s1 rdf:_123 _:o1 . " ++ + "_: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 ; " ++ + " ex:p2 _:o2 . " ++ + "ex:p1 rdfs:range ex:pr1 . " ++ + "ex:p2 rdfs:range ex:pr2 . " +con05 = formExpr $ makeFormula scopeex "con05" $ + "ex:o1 rdf:type ex:pr1 ." ++ + "_:o2 rdf:type ex:pr2 ." +bwd05 = formExpr $ makeFormula scopeex "bwd05a" $ + "_:s1 _:p1 ex:o1 . " ++ + "_:s2 _:p2 _:o2 . " ++ + "_:p1 rdfs:range ex:pr1 . " ++ + "_: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\" . " ++ + "ex:p1 rdfs:range ex:pr1 . " +con06 = formExpr $ makeFormula scopeex "con06" $ + "_:o1 rdf:type ex:pr1 ." +bwd06 = formExpr $ makeFormula scopeex "bwd06a" $ + "_:s1 _:p1 _:o1 . " ++ + "_:p1 rdfs:range ex:pr1 . " +chk06 = formExpr $ makeFormula scopeex "bwd06a" $ + "_:s1 _:p1 \"lit1\" . " ++ + "_: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 . " ++ + "_: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 . " ++ + "_: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 ." ++ + "_:p rdf:type rdf:Property ." ++ + "_: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\" ." ++ + "ex:s2 ex:p2 \"lll\" ." ++ + "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 ." ++ + "ex:s2 ex:p2 _:l ." ++ + "_:l rdf:_allocatedTo \"lll\" ." ++ + "ex:s3 ex:p3 _:m ." ++ + "_: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 ." ++ + "_: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 ." ++ + "ex:s2 ex:p2 _:l ." ++ + "_: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:cp1") [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 + (ScopedName (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 ." ++ + "_: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 ." ++ + "_:l rdf:_allocatedTo \"10\"^^xsd:integer ." ++ + "_: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 + (ScopedName (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\" . " ++ + "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 . " ++ + "ex:s ex:p \"def\" . " ++ + "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 :: Test +allTests = TestList + [ testRules + , testRdf + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +p10 = runTestTT $ TestList + [ rdfAxiom10 + , rdfRule10 + , testProof "rdfProof10" True rdfProof10 + ] +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFProofTest.hs b/tests/RDFProofTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFProofTest.hs @@ -0,0 +1,1233 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFProofTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module tests the RDFproof module, which instantiates the proof +-- rule class over RDF graphs. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.RDFProof + ( makeRdfInstanceEntailmentRule + , makeRdfSubgraphEntailmentRule + , makeRdfSimpleEntailmentRule + ) + +import Swish.RDF.RDFQuery + ( rdfQueryFind, rdfQuerySubs ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding, RDFVarBindingModify ) + +import Swish.RDF.RDFRuleset + ( RDFRule + , makeRDFGraphFromN3String + , makeN3ClosureAllocatorRule + , makeN3ClosureRule + , makeN3ClosureSimpleRule + , makeNodeAllocTo + ) + +import Swish.RDF.RDFGraph + ( Label(..), RDFLabel(..), RDFGraph + , add, allLabels, allNodes ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + , VarBindingModify(..) + , makeVarFilterModify + , varBindingId -- , varFilterDisjunction, varFilterConjunction + , varFilterNE + ) + +import Swish.RDF.Rule (Rule(..)) + +import Swish.Utils.Namespace + ( Namespace(..), ScopedName(..) ) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertBool, assertEqual + , runTestTT ) + +import Data.Maybe (isJust, fromJust) + +-- misc helpers + +test :: String -> Bool -> Test +test lab tst = TestCase $ assertBool lab tst + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab e a = TestCase $ assertEqual lab e a + +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) + +testIn :: (Eq a, Show a) => String -> a -> [a] -> Test +testIn lab eg a = TestCase $ assertBool lab (eg `elem` a) + +-- test1: simple query with URI, literal and blank nodes. + +scope1 :: Namespace +scope1 = Namespace "scope1" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope1" + +prefix1 :: String +prefix1 = + "@prefix ex: . \n" ++ + " \n" + +graph1 :: RDFGraph +graph1 = makeRDFGraphFromN3String graph1str + +graph1str :: String +graph1str = prefix1 ++ + "ex:s1 ex:p ex:o1 . \n" ++ + "ex:s2 ex:p \"lit1\" . \n" ++ + "[ ex:p ex:o3 ] . \n" + +query11 :: RDFGraph +query11 = makeRDFGraphFromN3String query11str + +query11str :: String +query11str = prefix1 ++ + "?s ex:p ?o . \n" + +result11 :: RDFGraph +result11 = makeRDFGraphFromN3String result11str + +result11str :: String +result11str = prefix1 ++ + "?s ex:r ?o . \n" + +result11a :: RDFGraph +result11a = makeRDFGraphFromN3String result11astr + +result11astr :: String +result11astr = prefix1 ++ + "ex:s1 ex:r ex:o1 . \n" ++ + "ex:s2 ex:r \"lit1\" . \n" ++ + "[ ex:r ex:o3 ] . \n" + +result11b :: RDFGraph +result11b = makeRDFGraphFromN3String result11bstr + +result11bstr :: String +result11bstr = prefix1 ++ + "ex:s1 ex:r ex:o1 . \n" + +result11c :: RDFGraph +result11c = makeRDFGraphFromN3String result11cstr + +result11cstr :: String +result11cstr = prefix1 ++ + "ex:s2 ex:r \"lit1\" . \n" + +backsub11a :: RDFGraph +backsub11a = makeRDFGraphFromN3String backsub11astr + +backsub11astr :: String +backsub11astr = prefix1 ++ + "ex:s1 ex:p ex:o1 . \n" ++ + "ex:s2 ex:p \"lit1\" . \n" + +backsub11b :: RDFGraph +backsub11b = makeRDFGraphFromN3String backsub11bstr + +backsub11bstr :: String +backsub11bstr = prefix1 ++ + "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 (add 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 = Namespace "scope2" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope2" + +prefix2 :: String +prefix2 = + "@prefix pers: . \n" ++ + "@prefix rel: . \n" ++ + " \n" + +graph2 :: RDFGraph +graph2 = makeRDFGraphFromN3String graph2str + +graph2str :: String +graph2str = prefix2 ++ + "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 = makeRDFGraphFromN3String query21str + +query21str :: String +query21str = prefix2 ++ + "?a rel:wife ?b . \n" + +result21 :: RDFGraph +result21 = makeRDFGraphFromN3String result21str + +result21str :: String +result21str = prefix2 ++ + "?b rel:husband ?a . \n" + +result21a :: RDFGraph +result21a = makeRDFGraphFromN3String result21astr + +result21astr :: String +result21astr = prefix2 ++ + "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 = makeRDFGraphFromN3String result21bstr + +result21bstr :: String +result21bstr = prefix2 ++ + "pers:Do1 rel:husband pers:St1 . \n" ++ + "pers:Ma2 rel:husband pers:Pa2 . \n" + +bwd21a :: RDFGraph +bwd21a = makeRDFGraphFromN3String bwd21astr + +bwd21astr :: String +bwd21astr = prefix2 ++ + "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 = makeRDFGraphFromN3String query22str + +query22str :: String +query22str = prefix2 ++ + "?a rel:son ?b . \n" ++ + "?b rel:son ?c . \n" + +result22 :: RDFGraph +result22 = makeRDFGraphFromN3String result22str + +result22str :: String +result22str = prefix2 ++ + "?a rel:grandparent ?c . \n" + +result22a :: RDFGraph +result22a = makeRDFGraphFromN3String result22astr + +result22astr :: String +result22astr = prefix2 ++ + "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 = makeRDFGraphFromN3String result22bstr + +result22bstr :: String +result22bstr = prefix2 ++ + "pers:Pa2 rel:grandparent pers:Ro4 . \n" ++ + "pers:Pa2 rel:grandparent pers:Ol4 . \n" + +bwd22a :: RDFGraph +bwd22a = makeRDFGraphFromN3String bwd22astr + +bwd22astr :: String +bwd22astr = prefix2 ++ + "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 = makeRDFGraphFromN3String query23str + +query23str :: String +query23str = prefix2 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result23 :: RDFGraph +result23 = makeRDFGraphFromN3String result23str + +result23str :: String +result23str = prefix2 ++ + "?b rel:brother ?c . \n" + +result23a :: RDFGraph +result23a = makeRDFGraphFromN3String result23astr + +result23astr :: String +result23astr = prefix2 ++ + "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 = makeRDFGraphFromN3String result23bstr + +result23bstr :: String +result23bstr = prefix2 ++ + "pers:Gr3 rel:brother pers:Gr3 . \n" ++ + "pers:Gr3 rel:brother pers:La3 . \n" + +bwd23a :: RDFGraph +bwd23a = makeRDFGraphFromN3String bwd23astr + +bwd23astr :: String +bwd23astr = prefix2 ++ + "_: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 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) + +graph24 :: RDFGraph +graph24 = makeRDFGraphFromN3String graph24str + +graph24str :: String +graph24str = prefix2 ++ + "pers:Ma2 rel:son pers:Gr3 . \n" ++ + "pers:Ma2 rel:stepson pers:St3 . \n" + +query24 :: RDFGraph +query24 = makeRDFGraphFromN3String query24str + +query24str :: String +query24str = prefix2 ++ + "?c rel:son ?a . \n" ++ + "?c rel:stepson ?b . \n" + +result24 :: RDFGraph +result24 = makeRDFGraphFromN3String result24str + +result24str :: String +result24str = prefix2 ++ + "?a rel:stepbrother ?b . \n" ++ + "?b rel:stepbrother ?a . \n" + +result24a :: RDFGraph +result24a = makeRDFGraphFromN3String result24astr + +result24astr :: String +result24astr = prefix2 ++ + "pers:Gr3 rel:stepbrother pers:St3 . \n" ++ + "pers:St3 rel:stepbrother pers:Gr3 . \n" + +bwd24a1 :: RDFGraph +bwd24a1 = makeRDFGraphFromN3String bwd24a1str + +bwd24a1str :: String +bwd24a1str = prefix2 ++ + "_: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 = makeRDFGraphFromN3String bwd24a2str + +bwd24a2str :: String +bwd24a2str = prefix2 ++ + "_:c1 rel:son pers:Gr3 . \n" ++ + "_:c1 rel:stepson pers:St3 . \n" + +bwd24a3 :: RDFGraph +bwd24a3 = makeRDFGraphFromN3String bwd24a3str + +bwd24a3str :: String +bwd24a3str = prefix2 ++ + "_:c2 rel:stepson pers:Gr3 . \n" ++ + "_:c2 rel:son pers:St3 . \n" + +bwd24a4 :: RDFGraph +bwd24a4 = makeRDFGraphFromN3String bwd24a4str + +bwd24a4str :: String +bwd24a4str = prefix2 ++ + "_: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 = makeRDFGraphFromN3String query25str + +query25str :: String +query25str = prefix2 ++ + "?a rel:son ?b . \n" ++ + "?a rel:daughter ?c . \n" + +result25 :: RDFGraph +result25 = makeRDFGraphFromN3String result25str + +result25str :: String +result25str = prefix2 ++ + "?b rel:sister ?c . \n" ++ + "?c rel:brother ?b . \n" + +result25a :: RDFGraph +result25a = makeRDFGraphFromN3String result25astr + +result25astr :: String +result25astr = prefix2 ++ + "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 = makeRDFGraphFromN3String result25bstr +result25bstr = prefix2 ++ + "pers:Ro4 rel:sister pers:Rh4 . \n" ++ + "pers:Rh4 rel:brother pers:Ro4 . \n" +-} + +result25c :: RDFGraph +result25c = makeRDFGraphFromN3String result25cstr + +result25cstr :: String +result25cstr = prefix2 ++ + "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 = makeRDFGraphFromN3String result25dstr + +result25dstr :: String +result25dstr = prefix2 ++ + "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 = makeRDFGraphFromN3String conc25str + +conc25str :: String +conc25str = prefix2 ++ + "pers:Wi3 rel:sister pers:Ma3 . \n" ++ + "pers:Rh4 rel:brother pers:Ro4 . \n" + +bwd25a :: RDFGraph +bwd25a = makeRDFGraphFromN3String bwd25astr + +bwd25astr :: String +bwd25astr = prefix2 ++ + "_: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 (bwd24!!0) + , 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 = Namespace "scope3" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope3" + +query31 :: RDFGraph +query31 = makeRDFGraphFromN3String query31str + +query31str :: String +query31str = prefix2 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +modify31 :: RDFVarBindingModify +modify31 = makeVarFilterModify $ varFilterNE (Var "b") (Var "c") + +result31 :: RDFGraph +result31 = makeRDFGraphFromN3String result31str + +result31str :: String +result31str = prefix2 ++ + "?b rel:brother ?c . \n" + +result31a :: RDFGraph +result31a = makeRDFGraphFromN3String result31astr + +result31astr :: String +result31astr = prefix2 ++ + "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 = makeRDFGraphFromN3String result31bstr + +result31bstr :: String +result31bstr = prefix2 ++ + "pers:Gr3 rel:brother pers:Gr3 . \n" + +result31c :: RDFGraph +result31c = makeRDFGraphFromN3String result31cstr + +result31cstr :: String +result31cstr = prefix2 ++ + "pers:Gr3 rel:brother pers:La3 . \n" + +bwd31c :: RDFGraph +bwd31c = makeRDFGraphFromN3String bwd31cstr + +bwd31cstr :: String +bwd31cstr = prefix2 ++ + "_: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 = Namespace "scope4" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope4" + +graph4 :: RDFGraph +graph4 = makeRDFGraphFromN3String graph4str + +graph4str :: String +graph4str = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" + +vocab4 :: [RDFLabel] +vocab4 = allNodes (not . labelIsVar) graph4 + +name4 :: ScopedName +name4 = ScopedName scope4 "instance4" + +rule4 :: RDFRule +rule4 = makeRdfInstanceEntailmentRule name4 vocab4 + +fwd42a :: RDFGraph +fwd42a = makeRDFGraphFromN3String fwd42astr + +fwd42astr :: String +fwd42astr = prefix2 ++ + "pers:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" + +fwd42b :: RDFGraph +fwd42b = makeRDFGraphFromN3String fwd42bstr + +fwd42bstr :: String +fwd42bstr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter _:Rh4 . \n" + +fwd42c :: RDFGraph +fwd42c = makeRDFGraphFromN3String fwd42cstr + +fwd42cstr :: String +fwd42cstr = prefix2 ++ + "pers:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:daughter _:Rh4 . \n" + +fwd42d :: RDFGraph +fwd42d = makeRDFGraphFromN3String fwd42dstr + +fwd42dstr :: String +fwd42dstr = prefix2 ++ + "_:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" + +fwd42e :: RDFGraph +fwd42e = makeRDFGraphFromN3String fwd42estr + +fwd42estr :: String +fwd42estr = prefix2 ++ + "_:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" + +fwd42f :: RDFGraph +fwd42f = makeRDFGraphFromN3String fwd42fstr + +fwd42fstr :: String +fwd42fstr = prefix2 ++ + "_:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter _:Rh4 . \n" + +fwd42g :: RDFGraph +fwd42g = makeRDFGraphFromN3String fwd42gstr + +fwd42gstr :: String +fwd42gstr = prefix2 ++ + "_:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:daughter _:Rh4 . \n" + +-- Non-entailments + +fwd42w :: RDFGraph +fwd42w = makeRDFGraphFromN3String fwd42wstr + +fwd42wstr :: String +fwd42wstr = prefix2 ++ + "pers:Gr3 rel:daughter pers:Ro4 . \n" + +fwd42x :: RDFGraph +fwd42x = makeRDFGraphFromN3String fwd42xstr + +fwd42xstr :: String +fwd42xstr = prefix2 ++ + "pers:Gr3 rel:daughter pers:Ro4 . \n" + +fwd42y :: RDFGraph +fwd42y = makeRDFGraphFromN3String fwd42ystr + +fwd42ystr :: String +fwd42ystr = prefix2 ++ + "_:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter pers:Ro4 . \n" + +fwd42z :: RDFGraph +fwd42z = makeRDFGraphFromN3String fwd42zstr + +fwd42zstr :: String +fwd42zstr = prefix2 ++ + "_:Gr3 rel:son _:Ro4 ; \n" ++ + " rel:son _:Rh4 . \n" + +bwd43 :: RDFGraph +bwd43 = makeRDFGraphFromN3String bwd43str + +bwd43str :: String +bwd43str = prefix2 ++ + "_:a1 rel:son pers:Ro4 . \n" ++ + "_:a2 rel:daughter pers:Rh4 . \n" + +bwd43a :: RDFGraph +bwd43a = makeRDFGraphFromN3String bwd43astr + +bwd43astr :: String +bwd43astr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" ++ + "pers:Gr3 rel:daughter pers:Rh4 . \n" + +bwd43b :: RDFGraph +bwd43b = makeRDFGraphFromN3String bwd43bstr + +bwd43bstr :: String +bwd43bstr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" ++ + "pers:Ro4 rel:daughter pers:Rh4 . \n" + +bwd43c :: RDFGraph +bwd43c = makeRDFGraphFromN3String bwd43cstr + +bwd43cstr :: String +bwd43cstr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" ++ + "pers:Rh4 rel:daughter pers:Rh4 . \n" + +bwd43d :: RDFGraph +bwd43d = makeRDFGraphFromN3String bwd43dstr + +bwd43dstr :: String +bwd43dstr = prefix2 ++ + "pers:Ro4 rel:son pers:Ro4 . \n" ++ + "pers:Gr3 rel:daughter pers:Rh4 . \n" + +bwd43e :: RDFGraph +bwd43e = makeRDFGraphFromN3String bwd43estr + +bwd43estr :: String +bwd43estr = prefix2 ++ + "pers:Ro4 rel:son pers:Ro4 . \n" ++ + "pers:Ro4 rel:daughter pers:Rh4 . \n" + +bwd43f :: RDFGraph +bwd43f = makeRDFGraphFromN3String bwd43fstr + +bwd43fstr :: String +bwd43fstr = prefix2 ++ + "pers:Ro4 rel:son pers:Ro4 . \n" ++ + "pers:Rh4 rel:daughter pers:Rh4 . \n" + +bwd43g :: RDFGraph +bwd43g = makeRDFGraphFromN3String bwd43gstr + +bwd43gstr :: String +bwd43gstr = prefix2 ++ + "pers:Rh4 rel:son pers:Ro4 . \n" ++ + "pers:Gr3 rel:daughter pers:Rh4 . \n" + +bwd43h :: RDFGraph +bwd43h = makeRDFGraphFromN3String bwd43hstr + +bwd43hstr :: String +bwd43hstr = prefix2 ++ + "pers:Rh4 rel:son pers:Ro4 . \n" ++ + "pers:Ro4 rel:daughter pers:Rh4 . \n" + +bwd43i :: RDFGraph +bwd43i = makeRDFGraphFromN3String bwd43istr + +bwd43istr :: String +bwd43istr = prefix2 ++ + "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 (length 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 = Namespace "scope5" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope5" + +graph5 :: RDFGraph +graph5 = makeRDFGraphFromN3String graph5str + +graph5str :: String +graph5str = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" ++ + "pers:Si3 rel:son pers:Ol4 . \n" + +name5 :: ScopedName +name5 = ScopedName scope5 "subgraph5" + +rule5 :: RDFRule +rule5 = makeRdfSubgraphEntailmentRule name5 + +-- Forward chaining excludes null agraph and copy of antecedent + +fwd52a :: RDFGraph +fwd52a = makeRDFGraphFromN3String fwd52astr + +fwd52astr :: String +fwd52astr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" + +fwd52b :: RDFGraph +fwd52b = makeRDFGraphFromN3String fwd52bstr + +fwd52bstr :: String +fwd52bstr = prefix2 ++ + "pers:Gr3 rel:daughter pers:Rh4 . \n" + +fwd52c :: RDFGraph +fwd52c = makeRDFGraphFromN3String fwd52cstr + +fwd52cstr :: String +fwd52cstr = prefix2 ++ + "pers:Si3 rel:son pers:Ol4 . \n" + +fwd52d :: RDFGraph +fwd52d = makeRDFGraphFromN3String fwd52dstr + +fwd52dstr :: String +fwd52dstr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" ++ + "pers:Gr3 rel:daughter pers:Rh4 . \n" + +fwd52e :: RDFGraph +fwd52e = makeRDFGraphFromN3String fwd52estr + +fwd52estr :: String +fwd52estr = prefix2 ++ + "pers:Gr3 rel:son pers:Ro4 . \n" ++ + "pers:Si3 rel:son pers:Ol4 . \n" + +fwd52f :: RDFGraph +fwd52f = makeRDFGraphFromN3String fwd52fstr + +fwd52fstr :: String +fwd52fstr = prefix2 ++ + "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 = Namespace "scope6" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope6" + +graph6 :: RDFGraph +graph6 = makeRDFGraphFromN3String graph6str + +graph6str :: String +graph6str = prefix2 ++ + "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 = ScopedName scope5 "subgraph6" + +rule6 :: RDFRule +rule6 = makeRdfSimpleEntailmentRule name6 + +simple6a :: RDFGraph +simple6a = makeRDFGraphFromN3String simple6astr + +simple6astr :: String +simple6astr = prefix2 ++ + "_:Gr3 rel:son pers:Ro4 ; \n" ++ + " rel:daughter pers:Rh4 . \n" + +simple6b :: RDFGraph +simple6b = makeRDFGraphFromN3String simple6bstr + +simple6bstr :: String +simple6bstr = prefix2 ++ + "_:Si3 rel:son pers:Ol4 ; \n" ++ + " rel:son pers:Lo4 . \n" + +simple6c :: RDFGraph +simple6c = makeRDFGraphFromN3String simple6cstr + +simple6cstr :: String +simple6cstr = prefix2 ++ + "_:Si3 rel:son _:Ol4 ; \n" ++ + " rel:son _:Lo4 . \n" + +simple6d :: RDFGraph +simple6d = makeRDFGraphFromN3String simple6dstr + +simple6dstr :: String +simple6dstr = prefix2 ++ + "_:Si3 rel:son _:Ol4 ; \n" ++ + " rel:daughter _:Lo4 . \n" + +simple6e :: RDFGraph +simple6e = makeRDFGraphFromN3String simple6estr + +simple6estr :: String +simple6estr = prefix2 ++ + "_: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 = Namespace "scope7" + "http://id.ninebynine.org/wip/2003/rdfprooftest/scope7" + +graph7 :: RDFGraph +graph7 = makeRDFGraphFromN3String graph7str + +graph7str :: String +graph7str = prefix2 ++ + "pers:Ro4 rel:uncle pers:La3 ; \n" ++ + " rel:uncle pers:Si3 . \n" ++ + "pers:Rh4 rel:uncle pers:La3 ; \n" ++ + " rel:uncle pers:Si3 . \n" + +query71 :: RDFGraph +query71 = makeRDFGraphFromN3String query71str + +query71str :: String +query71str = prefix2 ++ + "?a rel:uncle ?c . \n" + +result71 :: RDFGraph +result71 = makeRDFGraphFromN3String result71str + +result71str :: String +result71str = prefix2 ++ + "?a rel:father ?b . \n" ++ + "?b rel:brother ?c . \n" + +result71a :: RDFGraph +result71a = makeRDFGraphFromN3String result71astr + +result71astr :: String +result71astr = prefix2 ++ + "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 (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 :: Test +allTests = TestList + [ test1 + , test2 + , test3 + , test4 + , test5 + , test6 + , test7 + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFQueryTest.hs b/tests/RDFQueryTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFQueryTest.hs @@ -0,0 +1,1679 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFQueryTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module defines 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 Swish.RDF.RDFQuery + ( rdfQueryFind, rdfQueryFilter + , rdfQueryBack, rdfQueryBackFilter, rdfQueryBackModify + , rdfQueryInstance + , rdfQuerySubs, rdfQueryBackSubs + , rdfQuerySubsAll + , rdfQuerySubsBlank, rdfQueryBackSubsBlank + -- debug + ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding + , RDFVarBindingFilter + , rdfVarBindingUriRef, rdfVarBindingBlank + , rdfVarBindingLiteral + , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral + , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped + , rdfVarBindingMemberProp + ) + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , merge + ) + +import Swish.RDF.VarBinding + ( VarBinding(..) + , makeVarBinding + , joinVarBindings + , VarBindingModify(..) + , makeVarFilterModify + , varBindingId + , varFilterNE + ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + , makeScopedName + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , langName + , swishName + , rdf_type, rdf_XMLLiteral + ) + +import Swish.RDF.N3Parser (parseN3fromString) + +import Swish.Utils.ListHelpers (equiv) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertBool, assertEqual + , runTestTT ) + +------------------------------------------------------------ +-- misc helpers +------------------------------------------------------------ + +newtype Set a = Set [a] deriving Show + +instance (Eq a) => Eq (Set a) where + Set v1 == Set v2 = v1 `equiv` v2 + +test :: String -> Bool -> Test +test lab tst = TestCase $ assertBool lab tst + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab e a = TestCase $ assertEqual lab e a + +testLs :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testLs lab e a = TestCase $ assertEqual lab (Set e) (Set a) + +testGr :: String -> String -> [RDFGraph] -> Test +testGr lab e a = TestCase $ assertBool lab (eg `elem` a) + where eg = graphFromString e + +graphFromString :: String -> RDFGraph +graphFromString str = case parseN3fromString str of + Right gr -> gr + Left msg -> error msg + +-- Compare lists for set equivalence: + +data ListTest a = ListTest [a] + +instance (Eq a) => Eq (ListTest a) where + (ListTest a1) == (ListTest a2) = a1 `equiv` a2 + +instance (Show a) => Show (ListTest a) where + show (ListTest a) = show a + +testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testEqv lab a1 a2 = + TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) + +------------------------------------------------------------ +-- test1: simple query qith URI, literal and blank nodes. +------------------------------------------------------------ + +prefix1 :: String +prefix1 = + "@prefix ex: . \n" ++ + " \n" + +graph1 :: RDFGraph +graph1 = graphFromString $ prefix1 ++ + "ex:s1 ex:p ex:o1 . \n" ++ + "ex:s2 ex:p \"lit1\" . \n" ++ + "[ ex:p ex:o3 ] . \n" + +query11 :: RDFGraph +query11 = graphFromString $ prefix1 ++ + "?s ex:p ?o . \n" + +result11 :: RDFGraph +result11 = graphFromString $ prefix1 ++ + "?s ex:r ?o . \n" + +result11a, result11b, result11c :: String + +result11a = prefix1 ++ "ex:s1 ex:r ex:o1 . \n" +result11b = prefix1 ++ "ex:s2 ex:r \"lit1\" . \n" +result11c = prefix1 ++ "[ ex:r ex:o3 ] . \n" + +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 :: String +prefix2 = + "@prefix pers: . \n" ++ + "@prefix rel: . \n" ++ + " \n" + +graph2 :: RDFGraph +graph2 = graphFromString $ prefix2 ++ + "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 = graphFromString $ prefix2 ++ + "?a rel:wife ?b . \n" + +result21 :: RDFGraph +result21 = graphFromString $ prefix2 ++ + "?b rel:husband ?a . \n" + +result21a, result21b, result21c, result21d, + result21e, result21f :: String + +result21a = prefix2 ++ "pers:Do1 rel:husband pers:St1 . \n" +result21b = prefix2 ++ "pers:Ma2 rel:husband pers:Pa2 . \n" +result21c = prefix2 ++ "pers:Ri2 rel:husband pers:Br2 . \n" +result21d = prefix2 ++ "pers:Ma3 rel:husband pers:Gr3 . \n" +result21e = prefix2 ++ "pers:Jo3 rel:husband pers:Si3 . \n" +result21f = prefix2 ++ "pers:Su3 rel:husband pers:Al3 . \n" + +var21 :: [RDFVarBinding] +var21 = rdfQueryFind query21 graph2 + +res21 :: [RDFGraph] +res21 = rdfQuerySubs var21 result21 + +query22 :: RDFGraph +query22 = graphFromString $ prefix2 ++ + "?a rel:son ?b . \n" ++ + "?b rel:son ?c . \n" + +result22 :: RDFGraph +result22 = graphFromString $ prefix2 ++ + "?a rel:grandparent ?c . \n" + +result22a :: String +result22a = prefix2 ++ + "pers:Pa2 rel:grandparent pers:Ro4 . \n" + +result22b :: String +result22b = prefix2 ++ + "pers:Pa2 rel:grandparent pers:Ol4 . \n" + +result22c :: String +result22c = prefix2 ++ + "pers:Pa2 rel:grandparent pers:Lo4 . \n" + +result22d :: String +result22d = prefix2 ++ + "pers:Pa2 rel:grandparent pers:Ha4 . \n" + +result22e :: String +result22e = prefix2 ++ + "pers:Pa2 rel:grandparent pers:El4 . \n" + +var22 :: [RDFVarBinding] +var22 = rdfQueryFind query22 graph2 + +res22 :: [RDFGraph] +res22 = rdfQuerySubs var22 result22 + +query23 :: RDFGraph +query23 = graphFromString $ prefix2 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result23 :: RDFGraph +result23 = graphFromString $ prefix2 ++ + "?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 :: String + +result23a = prefix2 ++ + "pers:Gr3 rel:brother pers:Gr3 . \n" + +result23b = prefix2 ++ + "pers:Gr3 rel:brother pers:La3 . \n" + +result23c = prefix2 ++ + "pers:Gr3 rel:brother pers:Si3 . \n" + +result23d = prefix2 ++ + "pers:Gr3 rel:brother pers:Al3 . \n" + +result23e = prefix2 ++ + "pers:La3 rel:brother pers:Gr3 . \n" + +result23f = prefix2 ++ + "pers:La3 rel:brother pers:La3 . \n" + +result23g = prefix2 ++ + "pers:La3 rel:brother pers:Si3 . \n" + +result23h = prefix2 ++ + "pers:La3 rel:brother pers:Al3 . \n" + +result23i = prefix2 ++ + "pers:Si3 rel:brother pers:Gr3 . \n" + +result23j = prefix2 ++ + "pers:Si3 rel:brother pers:La3 . \n" + +result23k = prefix2 ++ + "pers:Si3 rel:brother pers:Si3 . \n" + +result23l = prefix2 ++ + "pers:Si3 rel:brother pers:Al3 . \n" + +result23m = prefix2 ++ + "pers:Al3 rel:brother pers:Gr3 . \n" + +result23n = prefix2 ++ + "pers:Al3 rel:brother pers:La3 . \n" + +result23o = prefix2 ++ + "pers:Al3 rel:brother pers:Si3 . \n" + +result23p = prefix2 ++ + "pers:Al3 rel:brother pers:Al3 . \n" + +result23q = prefix2 ++ + "pers:Wi3 rel:brother pers:Wi3 . \n" + +result23r = prefix2 ++ + "pers:Ro4 rel:brother pers:Ro4 . \n" + +result23s = prefix2 ++ + "pers:Ol4 rel:brother pers:Lo4 . \n" + +result23t = prefix2 ++ + "pers:Ol4 rel:brother pers:Ol4 . \n" + +result23u = prefix2 ++ + "pers:Lo4 rel:brother pers:Lo4 . \n" + +result23v = prefix2 ++ + "pers:Lo4 rel:brother pers:Ol4 . \n" + +result23w = prefix2 ++ + "pers:Ha4 rel:brother pers:El4 . \n" + +result23x = prefix2 ++ + "pers:Ha4 rel:brother pers:Ha4 . \n" + +result23y = prefix2 ++ + "pers:El4 rel:brother pers:El4 . \n" + +result23z = prefix2 ++ + "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 = graphFromString $ prefix2 ++ + "?a rel:daughter ?b . \n" ++ + "?a rel:daughter ?c . \n" + +result24 :: RDFGraph +result24 = graphFromString $ prefix2 ++ + "?b rel:sister ?c . \n" + +result24a, result24b, result24c, result24d, + result24e, result24f :: String + +result24a = prefix2 ++ + "pers:Ma2 rel:sister pers:Ma2 . \n" + +result24b = prefix2 ++ + "pers:Ma2 rel:sister pers:An2 . \n" + +result24c = prefix2 ++ + "pers:An2 rel:sister pers:Ma2 . \n" + +result24d = prefix2 ++ + "pers:An2 rel:sister pers:An2 . \n" + +result24e = prefix2 ++ + "pers:Ma3 rel:sister pers:Ma3 . \n" + +result24f = prefix2 ++ + "pers:Rh4 rel:sister pers:Rh4 . \n" + +var24 :: [RDFVarBinding] +var24 = rdfQueryFind query24 graph2 + +res24 :: [RDFGraph] +res24 = rdfQuerySubs var24 result24 + +query25 :: RDFGraph +query25 = graphFromString $ prefix2 ++ + "?a rel:son ?b . \n" ++ + "?a rel:daughter ?c . \n" + +result25 :: RDFGraph +result25 = graphFromString $ prefix2 ++ + "?b rel:sister ?c . \n" ++ + "?c rel:brother ?b . \n" + +result25a, result25b :: String +result25a = prefix2 ++ + "pers:Wi3 rel:sister pers:Ma3 . \n" ++ + "pers:Ma3 rel:brother pers:Wi3 . \n" + +result25b = 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 = graphFromString $ prefix2 ++ + "pers:Pa2 rel:grandparent pers:Ro4 . \n" ++ + "pers:Pa2 rel:grandparent pers:Ol4 . \n" + +query31 :: RDFGraph +query31 = graphFromString $ prefix2 ++ + "?a rel:grandparent ?c . \n" + +result31 :: RDFGraph +result31 = graphFromString $ prefix2 ++ + "?a rel:son ?b . \n" ++ + "?b rel:son ?c . \n" + +result31a, result31b :: String +result31a = prefix2 ++ + "pers:Pa2 rel:son ?b . \n" ++ + "?b rel:son pers:Ro4 . \n" + +result31b = 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 = graphFromString $ prefix2 ++ + "?a rel:grandparent ?c . \n" + +result32 :: RDFGraph +result32 = graphFromString $ prefix2 ++ + "?a rel:wife _:b . \n" ++ + "?d rel:any _:b0 . \n" ++ + "?a rel:son ?b . \n" ++ + "?b rel:son ?c . \n" + +result32a, result32b :: String +result32a = 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 = 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 :: String +prefix4 = + "@prefix pers: . \n" ++ + "@prefix rel: . \n" ++ + " \n" + +graph41 :: RDFGraph +graph41 = graphFromString $ prefix4 ++ + "pers:St1 rel:wife pers:Do1 . \n" + +query41 :: RDFGraph +query41 = graphFromString $ prefix4 ++ + "?a rel:wife ?b . \n" + +result41 :: RDFGraph +result41 = graphFromString $ prefix4 ++ + "?b rel:husband ?a . \n" + +result41a :: String +result41a = prefix4 ++ + "pers:Do1 rel:husband pers:St1 . \n" + +var41 :: [[RDFVarBinding]] +var41 = rdfQueryBack query41 graph41 + +res41 :: [[(RDFGraph, [RDFLabel])]] +res41 = rdfQueryBackSubs var41 result41 + +graph42 :: RDFGraph +graph42 = graphFromString $ prefix4 ++ + "pers:Pa2 rel:grandparent pers:Ro4 . \n" + +query42 :: RDFGraph +query42 = graphFromString $ prefix4 ++ + "?a rel:grandparent ?c . \n" + +result42 :: RDFGraph +result42 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?b rel:son ?c . \n" + +result42a :: String +result42a = 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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:brother pers:La3 . \n" + +query43 :: RDFGraph +query43 = graphFromString $ prefix4 ++ + "?b rel:brother ?c . \n" + +result43 :: RDFGraph +result43 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result43a :: String +result43a = 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 = graphFromString $ prefix4 ++ + "pers:Pa2 rel:grandson pers:Ro4 . \n" + +query44 :: RDFGraph +query44 = graphFromString $ prefix4 ++ + "?a rel:grandson ?b . \n" ++ + "?c rel:grandson ?d . \n" + +result44 :: RDFGraph +result44 = graphFromString $ prefix4 ++ + "?a rel:son ?m . \n" ++ + "?m rel:son ?b . \n" ++ + "?c rel:daughter ?n . \n" ++ + "?n rel:son ?d . \n" + +result44a, result44b :: String +result44a = prefix4 ++ + "pers:Pa2 rel:son ?m . \n" ++ + "?m rel:son pers:Ro4 . \n" ++ + "?c rel:daughter ?n . \n" ++ + "?n rel:son ?d . \n" + +result44b = prefix4 ++ + "?a rel:son ?m . \n" ++ + "?m rel:son ?b . \n" ++ + "pers:Pa2 rel:daughter ?n . \n" ++ + "?n rel:son pers:Ro4 . \n" + +unbound44a, unbound44b :: [RDFLabel] +unbound44a = [(Var "m"),(Var "c"),(Var "n"),(Var "d")] +unbound44b = [(Var "a"),(Var "m"),(Var "b"),(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] = 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 = graphFromString $ prefix4 ++ + "pers:Rh4 rel:brother pers:Ro4 . \n" ++ + "pers:Ma3 rel:brother pers:Wi3 . \n" + +query45 :: RDFGraph +query45 = graphFromString $ prefix4 ++ + "?b rel:brother ?c . \n" + +result45 :: RDFGraph +result45 = graphFromString $ prefix4 ++ + "?a rel:daughter ?b . \n" ++ + "?a rel:son ?c . \n" + +result45a1, result45a2 :: String +result45a1 = prefix4 ++ + "?a rel:daughter pers:Rh4 . \n" ++ + "?a rel:son pers:Ro4 . \n" + +result45a2 = 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] = res45 + +res45_11, res45_12 :: (RDFGraph, [RDFLabel]) +[res45_11,res45_12] = 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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:stepbrother pers:St3 . \n" + +query46 :: RDFGraph +query46 = graphFromString $ prefix4 ++ + "?b rel:stepbrother ?c . \n" ++ + "?c rel:stepbrother ?b . \n" + +result46 :: RDFGraph +result46 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:stepson ?c . \n" + +result46a, result46b :: String +result46a = prefix4 ++ + "?a rel:son pers:St3 . \n" ++ + "?a rel:stepson pers:Gr3 . \n" +result46b = prefix4 ++ + "?a rel:son pers:Gr3 . \n" ++ + "?a rel:stepson pers:St3 . \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] = res46 + +res46_11, res46_21 :: (RDFGraph, [RDFLabel]) +[res46_11] = res46_1 +[res46_21] = 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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:stepbrother pers:St3 . \n" ++ + "pers:St3 rel:stepbrother pers:Gr3 . \n" + +query47 :: RDFGraph +query47 = graphFromString $ prefix4 ++ + "?b rel:stepbrother ?c . \n" ++ + "?c rel:stepbrother ?b . \n" + +result47 :: RDFGraph +result47 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:stepson ?c . \n" + +result47a1, result47a2, + result47b1, result47b2, + result47c1, result47c2, + result47d1, result47d2 :: String + +result47a1 = prefix4 ++ + "?a rel:son pers:St3 . \n" ++ + "?a rel:stepson pers:Gr3 . \n" + +result47a2 = prefix4 ++ + "?a rel:son pers:Gr3 . \n" ++ + "?a rel:stepson pers:St3 . \n" + +result47b1 = prefix4 ++ + "?a rel:stepson pers:St3 . \n" ++ + "?a rel:son pers:Gr3 . \n" + +result47b2 = prefix4 ++ + "?a rel:stepson pers:St3 . \n" ++ + "?a rel:son pers:Gr3 . \n" + +result47c1 = prefix4 ++ + "?a rel:son pers:St3 . \n" ++ + "?a rel:stepson pers:Gr3 . \n" + +result47c2 = prefix4 ++ + "?a rel:son pers:St3 . \n" ++ + "?a rel:stepson pers:Gr3 . \n" + +result47d1 = prefix4 ++ + "?a rel:stepson pers:St3 . \n" ++ + "?a rel:son pers:Gr3 . \n" + +result47d2 = prefix4 ++ + "?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] = res47 + +res47_11, res47_12, + res47_21, res47_22, + res47_31, res47_32, + res47_41, res47_42 :: (RDFGraph, [RDFLabel]) +[res47_11,res47_12] = res47_1 +[res47_21,res47_22] = res47_2 +[res47_31,res47_32] = res47_3 +[res47_41,res47_42] = 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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:brother pers:La3 . \n" + +query48 :: RDFGraph +query48 = graphFromString $ prefix4 ++ + "?b rel:brother ?c . \n" ++ + "?c rel:brother ?b . \n" + +result48 :: RDFGraph +result48 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result48a, result48b :: String +result48a = prefix4 ++ + "?a rel:son pers:La3 . \n" ++ + "?a rel:son pers:Gr3 . \n" +result48b = prefix4 ++ + "?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] = res48 + +res48_11, res48_21 :: (RDFGraph, [RDFLabel]) +[res48_11] = res48_1 +[res48_21] = 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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:foo pers:La3 . \n" + +query49 :: RDFGraph +query49 = graphFromString $ prefix4 ++ + "?a rel:bar ?a . \n" + +result49 :: RDFGraph +result49 = graphFromString $ prefix4 ++ + "?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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:brother pers:Gr3 . \n" + +query50 :: RDFGraph +query50 = graphFromString $ prefix4 ++ + "?b rel:brother ?c . \n" ++ + "?c rel:brother ?b . \n" + +result50 :: RDFGraph +result50 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result50a, result50b :: String +result50a = prefix4 ++ + "?a rel:son pers:Gr3 . \n" ++ + "?a rel:son pers:Gr3 . \n" + +result50b = prefix4 ++ + "?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] = res50 + +res50_11, res50_21 :: (RDFGraph, [RDFLabel]) +[res50_11] = res50_1 +[res50_21] = 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 (fst $ unzip $ head res41) + , testLs "testUnbound41a" [] (snd $ head $ head res41) + , test "testQuery42" (not $ null var42) + , testEq "testQuery42a" 1 (length var42) + , testEq "testResult42" 1 (length res42) + , testGr "testResult42a" result42a (fst $ unzip $ head res42) + , testLs "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 (fst $ unzip $ head res43) + , testLs "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 (fst $ unzip res44_2) + , testLs "testUnbound44a" unbound44a (snd $ head res44_2) + , testGr "testResult44b" result44b (fst $ unzip res44_1) + , testLs "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] + , testLs "testUnbound45a1" unbound45a1 (snd res45_11) + , testGr "testResult45a2" result45a2 [fst res45_12] + , testLs "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] + , testLs "testUnbound46a" unbound46a (snd res46_11) + , testGr "testResult46b" result46b [fst res46_21] + , testLs "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] + , testLs "testUnbound47a1" unbound47a1 (snd res47_11) + , testGr "testResult47a2" result47a2 [fst res47_12] + , testLs "testUnbound47a2" unbound47a2 (snd res47_12) + , testGr "testResult47b1" result47b1 [fst res47_21] + , testLs "testUnbound47b1" unbound47b1 (snd res47_21) + , testGr "testResult47b2" result47b2 [fst res47_22] + , testLs "testUnbound47b2" unbound47b2 (snd res47_22) + , testGr "testResult47c1" result47c1 [fst res47_31] + , testLs "testUnbound47c1" unbound47c1 (snd res47_31) + , testGr "testResult47c2" result47c2 [fst res47_32] + , testLs "testUnbound47c2" unbound47c2 (snd res47_32) + , testGr "testResult47d1" result47d1 [fst res47_41] + , testLs "testUnbound47d1" unbound47d1 (snd res47_41) + , testGr "testResult47d2" result47d2 [fst res47_42] + , testLs "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] + , testLs "testUnbound48a" unbound48a (snd res48_11) + , testGr "testResult48b" result48b [fst res48_21] + , testLs "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] + , testLs "testUnbound50a" unbound50a (snd res50_11) + , testGr "testResult50b" result50b [fst res50_21] + , testLs "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 = graphFromString $ prefix4 ++ + "pers:Gr3 rel:brother pers:La3 . \n" ++ + "pers:Gr3 rel:brother pers:Si3 . \n" + +query61 :: RDFGraph +query61 = graphFromString $ prefix4 ++ + "?b rel:brother ?c . \n" + +result61 :: RDFGraph +result61 = graphFromString $ prefix4 ++ + "?a rel:son ?b . \n" ++ + "?a rel:son ?c . \n" + +result61a, result63a :: String +result61a = prefix4 ++ + "_: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 = prefix4 ++ + "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]] = 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] = res63 + +-- 4. Repeat instance query against 'graph2' +-- Query bindings should be null. + +var64 :: [RDFVarBinding] +var64 = rdfQueryInstance res63a graph2 + +var64a :: RDFVarBinding +[var64a] = 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" (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 +-} + +baseex :: String +baseex = "http://example.org/" + +baserdf :: String +baserdf = nsURI namespaceRDF + +q_dattyp :: ScopedName +q_dattyp = makeScopedName "" 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 "" baseex "s" +u_o = Res $ makeScopedName "" baseex "o" +u_p = Res $ makeScopedName "" baseex "p" +u_p1 = Res $ makeScopedName "" baseex "p1" +u_p2a = Res $ makeScopedName "" baseex "p2a" +u_p2b = Res $ makeScopedName "" baseex "p2b" +u_m1 = Res $ makeScopedName "" baserdf "_1" +u_m2 = Res $ makeScopedName "" baserdf "_2" +u_rt = Res rdf_type +u_xt = Res rdf_XMLLiteral +u_dt = Res q_dattyp + +l_1, l_2, l_3, l_4, l_5 :: RDFLabel +l_1 = Lit "l1" Nothing +l_2 = Lit "l2" (Just $ langName "fr") +l_3 = Lit "l3" (Just q_dattyp) +l_4 = Lit "l4" (Just q_dattyp) -- was: (Lang "fr") +l_5 = Lit "l5" (Just rdf_XMLLiteral) + +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 = graphFromString 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_rdf_type 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 :: Test +allTests = TestList + [ test1 + , test2 + , test3 + , test4 + , test6 + , test7 +-- , test8 + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT + +shres32 = TestCase $ assertString (show res32) +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/RDFRulesetTest.hs b/tests/RDFRulesetTest.hs new file mode 100644 --- /dev/null +++ b/tests/RDFRulesetTest.hs @@ -0,0 +1,409 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : RDFRulesetTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains 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 Swish.RDF.RDFRuleset + ( RDFFormula, RDFRule, RDFClosure, RDFRuleset + , GraphClosure(..) + , makeRDFGraphFromN3String + , makeRDFFormula + , makeN3ClosureSimpleRule + , makeNodeAllocTo + -- for debugging + , graphClosureFwdApply, graphClosureBwdApply + ) + +import Swish.RDF.RDFQuery + ( rdfQueryBack, rdfQueryBackModify ) + +import Swish.RDF.RDFVarBinding + ( RDFVarBinding + , RDFVarBindingModify + , RDFVarBindingFilter + , rdfVarBindingXMLLiteral + ) + +import Swish.RDF.RDFGraph + ( Label (..), RDFLabel(..), RDFGraph + , Arc(..) + , getArcs + , allLabels + , toRDFGraph + ) + +import Swish.RDF.VarBinding + ( makeVarBinding + , vbmCompose + , makeVarFilterModify + ) + +import Swish.RDF.Ruleset + ( makeRuleset, getRulesetNamespace, getRulesetAxioms, getRulesetRules + , getRulesetAxiom, getRulesetRule ) + +import Swish.RDF.Rule + ( Formula(..), Rule(..) + , fwdCheckInference ) + +import Swish.Utils.Namespace + ( Namespace(..) + , ScopedName(..) + , makeScopedName + ) + +import Swish.RDF.Vocabulary + ( namespaceRDF + , namespaceOWL + , scopeRDF + ) + +import Test.HUnit + ( Test(TestCase,TestList) + , assertBool, assertEqual + , runTestTT + ) + +import Data.List (nub, sort) +import Data.Maybe (isJust, fromJust) + +------------------------------------------------------------ +-- Test case helpers +------------------------------------------------------------ + +test :: String -> Bool -> Test +test lab bv = + TestCase ( assertBool ("test:"++lab) bv ) + +testVal :: (Eq a, Show a) => String -> a -> a -> Test +testVal lab a1 a2 = + TestCase ( assertEqual ("testVal:"++lab) a1 a2 ) + +testEq :: (Eq a, Show a) => String -> Bool -> a -> a -> Test +testEq lab eq a1 a2 = + TestCase ( assertEqual ("testEq:"++lab) eq (a1==a2) ) + +testEqual :: (Eq a, Show a) => String -> a -> a -> Test +testEqual lab a1 a2 = + TestCase ( assertEqual ("testEq:"++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) ) + +testStringEq :: String -> String -> String -> Test +testStringEq lab s1 s2 = + TestCase ( assertEqual ("testStringEq:"++lab) s1 s2 ) + +testSameNamespace :: String -> Namespace -> Namespace -> Test +testSameNamespace lab n1 n2 = + TestCase ( assertBool ("testSameNamespace:"++lab) ((p1==p2)&&(u1==u2)) ) + where + p1 = nsPrefix n1 + p2 = nsPrefix n2 + u1 = nsURI n1 + u2 = nsURI n2 + +testScopedNameEq :: String -> Bool -> ScopedName -> ScopedName -> Test +testScopedNameEq lab eq n1 n2 = + TestCase ( assertEqual ("testScopedNameEq:"++lab) eq (n1==n2) ) + +{- +testQNameEq :: String -> Bool -> QName -> QName -> Test +testQNameEq lab eq n1 n2 = + TestCase ( assertEqual ("testQNameEq:"++lab) eq (n1==n2) ) +-} + +testSameAxioms :: String -> [RDFFormula] -> [RDFFormula] -> Test +testSameAxioms lab as1 as2 = + TestCase ( assertBool ("testSameAxioms:"++lab) sameas ) + where + sameas = (sort as1) == (sort as2) + +testSameRules :: String -> [RDFRule] -> [RDFRule] -> Test +testSameRules lab rs1 rs2 = + TestCase ( assertBool ("testSameRules:"++lab) samers ) + where + samers = (sort rs1) == (sort rs2) + +------------------------------------------------------------ +-- Common values +------------------------------------------------------------ + +pref_rdf, pref_owl :: String +pref_rdf = nsURI namespaceRDF +pref_owl = nsURI namespaceOWL + +------------------------------------------------------------ +-- 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 = Namespace "r1" "http://id.ninebynine.org/wip/2003/rulesettest/r1" + +-- Common prefix declarations for graph expressions +pref :: String +pref = + "@prefix rdf: . \n" ++ + "@prefix rdfs: . \n" ++ + "@prefix ex: . \n" ++ + " \n" + +a11, a12 :: RDFFormula +a11 = makeRDFFormula rn1 "a11" (pref++"ex:R1 rdf:type ex:C1 .") +a12 = makeRDFFormula rn1 "a12" (pref++"ex:R2 rdf:type ex:C2 .") + +r11, r12 :: RDFRule +r11 = makeN3ClosureSimpleRule rn1 "r11" + ( pref++"?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) + ( pref++"?r1 ex:P1 ?r2 ." ) + +r12 = makeN3ClosureSimpleRule rn1 "r12" + ( pref++"?r1 rdf:type ex:C1 . ?r2 rdf:type ex:C2 ." ) + ( pref++"?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 (ScopedName rn1 "a11") r1 + , testEqual "testGeta11" (Just a12) $ + getRulesetAxiom (ScopedName rn1 "a12") r1 + , testEqual "testGetr11" (Just r11) $ + getRulesetRule (ScopedName rn1 "r11") r1 + , testEqual "testGetr12" (Just r12) $ + getRulesetRule (ScopedName rn1 "r12") r1 + , testEqual "testGetnone" Nothing $ + getRulesetRule (ScopedName rn1 "none") r1 + ] + +------------------------------------------------------------ +-- Component tests for RDF proof context +------------------------------------------------------------ + +prefix :: String +prefix = + "@prefix rdf: . \n" ++ + "@prefix rdfs: . \n" ++ + "@prefix ex: . \n" ++ + " \n" + +scopeex :: Namespace +scopeex = Namespace "ex" "http://id.ninebynine.org/wip/2003/RDFProofCheck#" + +makeFormula :: Namespace -> String -> String -> RDFFormula +makeFormula scope local gr = + makeRDFFormula scope local (prefix++gr) + +allocateTo :: String -> String -> [RDFLabel] -> RDFVarBindingModify +allocateTo bv av = makeNodeAllocTo (Var bv) (Var av) + +isXMLLit :: String -> RDFVarBindingFilter +isXMLLit = rdfVarBindingXMLLiteral . Var + +queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] +queryBack qas = rdfQueryBack (toRDFGraph qas) + +-- Backward chaining rdf:r2 + +rdfr2ant, rdfr2con :: RDFGraph +rdfr2ant = makeRDFGraphFromN3String "?x ?a ?l . " +rdfr2con = makeRDFGraphFromN3String "?x ?a ?b . ?b rdf:type rdf:XMLLiteral ." + +rdfr2modv :: RDFVarBindingModify +rdfr2modv = allocateTo "b" "l" $ allLabels labelIsVar rdfr2ant + +rdfr2modc :: Maybe RDFVarBindingModify +rdfr2modc = vbmCompose (makeVarFilterModify $ isXMLLit "l") rdfr2modv + +rdfr2grc :: RDFClosure +rdfr2grc = GraphClosure + { nameGraphRule = ScopedName 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 ." ++ + "_:l1 rdf:type rdf:XMLLiteral ." ++ + "_:l2 rdf:type rdf:XMLLiteral ." + +v_a, v_b, v_x :: RDFLabel +v_a = Var "a" +v_b = Var "b" +v_x = Var "x" + +u_s, u_p1, u_p2a, u_p2b, u_rt, u_rx :: RDFLabel +u_s = Res $ makeScopedName "" "http://example.org/" "s" +u_p1 = Res $ makeScopedName "" "http://example.org/" "p1" +u_p2a = Res $ makeScopedName "" "http://example.org/" "p2a" +u_p2b = Res $ makeScopedName "" "http://example.org/" "p2b" +u_rt = Res $ makeScopedName "" pref_rdf "type" +u_rx = Res $ makeScopedName "" pref_rdf "XMLLiteral" + +b_l1, b_l2 :: RDFLabel +b_l1 = Blank "l1" +b_l2 = Blank "l2" + +rdfr2v1, rdfr2b1, rdfr2v2, rdfr2v3 :: [[RDFVarBinding]] +rdfr2v1 = queryBack (ruleCon rdfr2grc) con03 + +rdfr2b1 = [ [ 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) ] + ] + , [ 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_rx) ] + , makeVarBinding [ (v_b,b_l2) ] + ] + , [ 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_rx) ] + ] + , [ 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_rx) ] + , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] + ] + ] + +rdfr2v2 = rdfQueryBackModify (ruleModify rdfr2grc) rdfr2v1 +rdfr2v3 = map nub rdfr2v2 + +testRDFSuite :: Test +testRDFSuite = + TestList + [ test "testRDF01" $ isJust rdfr2modc + , testVal "testRDF02" rdfr2b1 rdfr2v1 + , testVal "testRDF03" [] rdfr2v2 + , testVal "testRDF04" [] rdfr2v3 + , testEq "testRDF09" True [] $ bwdApply rdfr2rul con03 + ] + +------------------------------------------------------------ +-- All tests +------------------------------------------------------------ + +allTests :: Test +allTests = TestList + [ testFormulaSuite + , testRuleSuite + , testRulesetSuite + , testRDFSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/tests/VarBindingTest.hs b/tests/VarBindingTest.hs new file mode 100644 --- /dev/null +++ b/tests/VarBindingTest.hs @@ -0,0 +1,899 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : VarBindingTest +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- This module contains test cases for variable binding values and +-- variable binding modifier values. +-- +-------------------------------------------------------------------------------- + +module Main where + +import Swish.RDF.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 Swish.Utils.ListHelpers + ( equiv ) + +import Test.HUnit + ( Test(TestCase,TestList) + , Assertion + , assertBool, assertEqual, assertFailure + , runTestTT + ) + +import Control.Monad (unless) +import Data.List (union, intersect) +import Data.Maybe (isJust, fromJust) + +------------------------------------------------------------ +-- 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 bv = + TestCase ( assertBool ("test:"++lab) bv ) + +testEq :: (Eq a, Show a) => String -> a -> a -> Test +testEq lab a1 a2 = + TestCase ( assertEqual ("testEq:"++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) ) + +-- Test for Just x or Nothing + +testJust :: String -> Maybe a -> Test +testJust lab av = + TestCase ( assertBool ("testJust:"++lab) (isJust av) ) + +testNothing :: String -> Maybe a -> Test +testNothing lab av = + TestCase ( assertBool ("testJust:"++lab) (not $ isJust av) ) + +-- Compare lists and lists of lists and Maybe lists for set equivalence: + +data ListTest a = ListTest [a] + +instance (Eq a) => Eq (ListTest a) where + (ListTest a1) == (ListTest a2) = a1 `equiv` a2 + +instance (Show a) => Show (ListTest a) where + show (ListTest a) = show a + +data MaybeListTest a = MaybeListTest (Maybe [a]) + +instance (Eq a) => Eq (MaybeListTest a) where + MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 + MaybeListTest Nothing == MaybeListTest Nothing = True + _ == _ = False + +instance (Show a) => Show (MaybeListTest a) where + show (MaybeListTest a) = show a + +testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test +testEqv lab a1 a2 = + TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) + +testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test +testEqvEqv lab a1 a2 = + TestCase ( assertEqual ("testEqvEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest $ map ListTest a1 + ma2 = ListTest $ map ListTest a2 + +testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test +testHasEqv lab a1 a2 = + TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) + where + ma1 = ListTest a1 + ma2 = map ListTest a2 + +testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test +testMaybeEqv lab a1 a2 = + TestCase ( assertEqual ("testMaybeEqv:"++lab) ma1 ma2 ) + where + ma1 = (MaybeListTest a1) + ma2 = (MaybeListTest a2) + +------------------------------------------------------------ +-- 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 = "[(3,\"c\"),(2,\"b\"),(1,\"a\")]" + +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 + +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" [1,2,3] $ boundVars vb1 + , testEq "testVarBinding11" [3,2,1] $ boundVars vb2 + , testEq "testVarBinding12" [] $ 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" $ not (vbNull vb12) + , test "testVarBinding41" $ not (vbNull vb13) + , test "testVarBinding42" $ not (vbNull vb14) + , test "testVarBinding43" $ not (vbNull vb16) + , test "testVarBinding44" $ not (vbNull 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 = VarBindingModify + { vbmName = swishName "vbm1" + , vbmApply = map (\vb -> joinVarBindings vb vb9m) + , vbmVocab = boundVars vb9m + , vbmUsage = [boundVars vb9m] + } + +vb1m1, vb2m1 :: VarBinding String Int +[vb1m1] = vbmApply vbm1 [vb1m] +[vb2m1] = 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 vbinds = concatMap abSumc vbinds + 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 $ vb12m2!!0 + , 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 $ (vb16m3!!0) + , 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"]] + } + +vbm34, vbm43 :: VarBindingModify String Int +Just vbm34 = vbmCompose vbm3 vbm4 +Just vbm43 = 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] = vbmApply (fromJust jvbm1id) [vb1m] +[vb2m1id] = vbmApply (fromJust jvbm1id) [vb2m] + +[vb1mid1] = vbmApply (fromJust jvbmid1) [vb1m] +[vb2mid1] = 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 + , testEqvEqv "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 + , testEqvEqv "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" $ not (isJust vbm56) + , test "testVarCompose42" $ not (isJust vbm65) + , test "testVarCompose43" $ not (isJust vbm78) + , test "testVarCompose44" $ (isJust vbm87) + , testEqvEqv "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 (compad!!0) + , 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 :: Test +allTests = TestList + [ testVarBindingSuite + , testVarModifySuite + , testVarComposeSuite + , testFindCompSuite + , testFilterSuite + ] + +main :: IO () +main = runTestTT allTests >> return () + +{- +runTestFile t = do + h <- openFile "a.tmp" WriteMode + runTestText (putTextToHandle h False) t + hClose h +tf = runTestFile +tt = runTestTT +-} + +-------------------------------------------------------------------------------- +-- +-- 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 +-- +--------------------------------------------------------------------------------