swish 0.6.1.2 → 0.6.2.1

raw patch · 116 files changed

+22685/−20121 lines, 116 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Data/Interned/URI.hs +0/−91
• Swish.hs +0/−79
• Swish/RDF.hs +0/−44
• Swish/RDF/BuiltInDatatypes.hs +0/−74
• Swish/RDF/BuiltInMap.hs +0/−52
• Swish/RDF/BuiltInRules.hs +0/−157
• Swish/RDF/ClassRestrictionRule.hs +0/−546
• Swish/RDF/Datatype.hs +0/−1064
• Swish/RDF/GraphClass.hs +0/−248
• Swish/RDF/GraphMatch.hs +0/−622
• Swish/RDF/GraphMem.hs +0/−166
• Swish/RDF/GraphPartition.hs +0/−570
• Swish/RDF/MapXsdInteger.hs +0/−69
• Swish/RDF/N3Formatter.hs +0/−941
• Swish/RDF/N3Parser.hs +0/−1145
• Swish/RDF/NTFormatter.hs +0/−247
• Swish/RDF/NTParser.hs +0/−427
• Swish/RDF/Proof.hs +0/−296
• Swish/RDF/RDFDatatype.hs +0/−202
• Swish/RDF/RDFDatatypeXsdInteger.hs +0/−539
• Swish/RDF/RDFDatatypeXsdString.hs +0/−333
• Swish/RDF/RDFGraph.hs +0/−1141
• Swish/RDF/RDFGraphShowM.hs +0/−57
• Swish/RDF/RDFParser.hs +0/−353
• Swish/RDF/RDFProof.hs +0/−380
• Swish/RDF/RDFProofContext.hs +0/−848
• Swish/RDF/RDFQuery.hs +0/−610
• Swish/RDF/RDFRuleset.hs +0/−546
• Swish/RDF/RDFVarBinding.hs +0/−187
• Swish/RDF/Rule.hs +0/−244
• Swish/RDF/Ruleset.hs +0/−153
• Swish/RDF/SwishCommands.hs +0/−422
• Swish/RDF/SwishMain.hs +0/−263
• Swish/RDF/SwishMonad.hs +0/−270
• Swish/RDF/SwishScript.hs +0/−1512
• Swish/RDF/TurtleFormatter.hs +0/−885
• Swish/RDF/TurtleParser.hs +0/−1062
• Swish/RDF/VarBinding.hs +0/−540
• Swish/RDF/Vocabulary.hs +0/−264
• Swish/Utils/ListHelpers.hs +0/−359
• Swish/Utils/LookupMap.hs +0/−454
• Swish/Utils/MiscHelpers.hs +0/−69
• Swish/Utils/Namespace.hs +0/−222
• Swish/Utils/PartOrderedCollection.hs +0/−386
• Swish/Utils/QName.hs +0/−277
• Swish/Utils/ShowM.hs +0/−75
• app/SwishApp.hs +90/−0
• src/Data/Interned/URI.hs +91/−0
• src/Swish.hs +41/−52
• src/Swish/RDF.hs +44/−0
• src/Swish/RDF/BuiltInDatatypes.hs +74/−0
• src/Swish/RDF/BuiltInMap.hs +52/−0
• src/Swish/RDF/BuiltInRules.hs +157/−0
• src/Swish/RDF/ClassRestrictionRule.hs +546/−0
• src/Swish/RDF/Datatype.hs +1064/−0
• src/Swish/RDF/GraphClass.hs +248/−0
• src/Swish/RDF/GraphMatch.hs +622/−0
• src/Swish/RDF/GraphMem.hs +166/−0
• src/Swish/RDF/GraphPartition.hs +570/−0
• src/Swish/RDF/MapXsdInteger.hs +69/−0
• src/Swish/RDF/N3Formatter.hs +941/−0
• src/Swish/RDF/N3Parser.hs +1145/−0
• src/Swish/RDF/NTFormatter.hs +247/−0
• src/Swish/RDF/NTParser.hs +427/−0
• src/Swish/RDF/Proof.hs +296/−0
• src/Swish/RDF/RDFDatatype.hs +202/−0
• src/Swish/RDF/RDFDatatypeXsdInteger.hs +539/−0
• src/Swish/RDF/RDFDatatypeXsdString.hs +333/−0
• src/Swish/RDF/RDFGraph.hs +1396/−0
• src/Swish/RDF/RDFGraphShowM.hs +57/−0
• src/Swish/RDF/RDFParser.hs +353/−0
• src/Swish/RDF/RDFProof.hs +380/−0
• src/Swish/RDF/RDFProofContext.hs +848/−0
• src/Swish/RDF/RDFQuery.hs +636/−0
• src/Swish/RDF/RDFRuleset.hs +546/−0
• src/Swish/RDF/RDFVarBinding.hs +187/−0
• src/Swish/RDF/Rule.hs +247/−0
• src/Swish/RDF/Ruleset.hs +175/−0
• src/Swish/RDF/SwishCommands.hs +422/−0
• src/Swish/RDF/SwishMain.hs +291/−0
• src/Swish/RDF/SwishMonad.hs +270/−0
• src/Swish/RDF/SwishScript.hs +1512/−0
• src/Swish/RDF/TurtleFormatter.hs +885/−0
• src/Swish/RDF/TurtleParser.hs +1062/−0
• src/Swish/RDF/VarBinding.hs +540/−0
• src/Swish/RDF/Vocabulary.hs +233/−0
• src/Swish/RDF/Vocabulary/DublinCore.hs +770/−0
• src/Swish/RDF/Vocabulary/FOAF.hs +466/−0
• src/Swish/RDF/Vocabulary/Geo.hs +109/−0
• src/Swish/RDF/Vocabulary/OWL.hs +175/−0
• src/Swish/RDF/Vocabulary/RDF.hs +325/−0
• src/Swish/RDF/Vocabulary/XSD.hs +201/−0
• src/Swish/Utils/ListHelpers.hs +359/−0
• src/Swish/Utils/LookupMap.hs +454/−0
• src/Swish/Utils/MiscHelpers.hs +69/−0
• src/Swish/Utils/Namespace.hs +222/−0
• src/Swish/Utils/PartOrderedCollection.hs +386/−0
• src/Swish/Utils/QName.hs +277/−0
• src/Swish/Utils/ShowM.hs +75/−0
• swish.cabal +365/−212
• tests/BuiltInMapTest.hs +13/−12
• tests/GraphPartitionTest.hs +8/−3
• tests/GraphTest.hs +18/−11
• tests/LookupMapTest.hs +15/−9
• tests/N3FormatterTest.hs +7/−9
• tests/N3ParserTest.hs +12/−10
• tests/NTTest.hs +4/−2
• tests/QNameTest.hs +18/−15
• tests/RDFDatatypeXsdIntegerTest.hs +6/−88
• tests/RDFGraphTest.hs +6/−17
• tests/RDFProofContextTest.hs +12/−28
• tests/RDFProofTest.hs +10/−29
• tests/RDFQueryTest.hs +11/−34
• tests/RDFRulesetTest.hs +31/−7
• tests/TestHelpers.hs +245/−0
• tests/VarBindingTest.hs +12/−92

@@ -1,91 +0,0 @@-{-# LANGUAGE TypeFamilies, FlexibleInstances #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  URI---  Copyright   :  (c) 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  TypeFamilies, FlexibleInstances------  Support interning URIs.--------------------------------------------------------------------------------------module Data.Interned.URI-       ( InternedURI-       ) where--import Data.String (IsString(..))-import Data.Hashable-import Data.Interned-import Data.Maybe (fromMaybe)--import Network.URI---- Could look at adding UNPACK statements before each component-data InternedURI = InternedURI !Int !URI--instance IsString InternedURI where-  fromString = intern .-               fromMaybe (error "Error: unable to create a URI.") .-               parseURIReference-              --instance Eq InternedURI where-  InternedURI a _ == InternedURI b _ = a == b--instance Ord InternedURI where-  compare (InternedURI a _) (InternedURI b _) = compare a b--instance Show InternedURI where-  showsPrec d (InternedURI _ b) = showsPrec d b--instance Interned InternedURI where-  type Uninterned InternedURI = URI-  data Description InternedURI = DU !URI deriving (Eq) -- DU {-# UNPACK #-} !URI deriving (Eq) -  describe = DU-  identify = InternedURI-  identity (InternedURI i _) = i-  cache = iuCache--instance Uninternable InternedURI where-  unintern (InternedURI _ b) = b ---- Rather than access the URI components, just use the reverse of the--- string representation of the URI.-instance Hashable (Description InternedURI) where-  hash = hashWithSalt 5381 -- use the stringSalt value from Data.Hashable-  hashWithSalt salt (DU u) = hashWithSalt salt ((reverse . show) u)--iuCache :: Cache InternedURI-iuCache = mkCache-{-# NOINLINE iuCache #-}----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 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------------------------------------------------------------------------------------

@@ -1,79 +0,0 @@------------------------------------------------------------------------------------  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------  Swish:  Semantic Web Inference Scripting in Haskell------  This program is a simple skeleton for constructing Semantic Web [1]---  inference tools in Haskell, using the RDF graph and several RDF---  parsers (at present Notation 3 and NTriples).------  It might be viewed as a kind of embroyonic CWM [2] in Haskell,---  except that the intent is that Haskell will be used as a primary---  language for defining inferences.  As such, Swish is an open-ended---  toolkit for constructing new special-purpose Semantic Web---  applications rather than a closed, self-contained general-purpose---  SW application.  As such, it is part of another experiment along---  the lines described in [3].------  The script format used by Swish is described in---  "Swish.RDF.SwishScript".------  Users wishing to process RDF data directly may prefer to look at---  the following modules; "Swish.RDF", "Swish.RDF.TurtleParser",---  "Swish.RDF.N3Parser", "Swish.RDF.N3Formatter", "Swish.RDF.NTParser"---  and "Swish.RDF.NTFormatter".------  (1) Semantic web: <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/TeamSubmission/2008/SUBM-n3-20080114/>------  (5) Turtle:       <http://www.w3.org/TR/turtle/>------  (6) RDF:          <http://www.w3.org/RDF/>--------------------------------------------------------------------------------------module Swish-       (-         module Swish.RDF.SwishMain-       ) where--import Swish.RDF.SwishMain--- should this re-export Swish.RDF.SwishMain or other components?-       ---------------------------------------------------------------------------------------  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------------------------------------------------------------------------------------

@@ -1,44 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  RDF---  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 provides an in-memory RDF Graph (it re-exports---  "Swish.RDF.RDFGraph").--------------------------------------------------------------------------------------module Swish.RDF (module Swish.RDF.RDFGraph) where--import Swish.RDF.RDFGraph----------------------------------------------------------------------------------------  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------------------------------------------------------------------------------------

@@ -1,74 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  BuiltInDatatypes---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module collects references and provides access to all of the---  datatypes built in to Swish.--------------------------------------------------------------------------------------module Swish.RDF.BuiltInDatatypes-       ( allDatatypes, findRDFDatatype )-    where--import Swish.RDF.RDFDatatype (RDFDatatype)--import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe)-import Swish.Utils.Namespace (ScopedName)-import Swish.RDF.RDFDatatypeXsdString (rdfDatatypeXsdString)-import Swish.RDF.RDFDatatypeXsdInteger (rdfDatatypeXsdInteger)-----------------------------------------------------------------  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------------------------------------------------------------------------------------

@@ -1,52 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  BuiltInMap---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module collects references and provides access to all of the---  datatypes, variable binding modifiers and variable binding filters---  built in to Swish.--------------------------------------------------------------------------------------module Swish.RDF.BuiltInMap-    ( findRDFOpenVarBindingModifier-    , findRDFDatatype-    , rdfRulesetMap-    , allRulesets, allDatatypeRulesets-    )-where--import Swish.RDF.BuiltInDatatypes-import Swish.RDF.BuiltInRules----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,157 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  BuiltInRules---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module collects references and provides access to all of the---  rulesets, variable binding modifiers and variable binding filters---  built in to Swish.--------------------------------------------------------------------------------------module Swish.RDF.BuiltInRules-    ( findRDFOpenVarBindingModifier-    , rdfRulesetMap-    , allRulesets, allDatatypeRulesets-    )-where--import Swish.RDF.BuiltInDatatypes (allDatatypes)--import Swish.RDF.RDFVarBinding-    ( RDFOpenVarBindingModify-    , rdfVarBindingUriRef, rdfVarBindingBlank-    , rdfVarBindingLiteral-    , rdfVarBindingUntypedLiteral, rdfVarBindingTypedLiteral-    , rdfVarBindingXMLLiteral, rdfVarBindingDatatyped-    , rdfVarBindingMemberProp-    )--import Swish.RDF.RDFRuleset (RDFRuleset, RDFRulesetMap)--import Swish.RDF.RDFProofContext-    ( rulesetRDF-    , rulesetRDFS-    , rulesetRDFD )--import Swish.RDF.VarBinding-    ( nullVarBindingModify-    , makeVarFilterModify-    , varFilterEQ, varFilterNE-    )--import Swish.RDF.Datatype (typeRules, typeMkModifiers)-import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe)-import Swish.Utils.Namespace (ScopedName)-----------------------------------------------------------------  Declare variable binding filters list----------------------------------------------------------------- |List of rdfOpenVarBindingModify values for predefined filters----rdfVarBindingFilters :: [RDFOpenVarBindingModify]-rdfVarBindingFilters =-    [ filter1 rdfVarBindingUriRef-    , filter1 rdfVarBindingBlank-    , filter1 rdfVarBindingLiteral-    , filter1 rdfVarBindingUntypedLiteral-    , filter1 rdfVarBindingTypedLiteral-    , filter1 rdfVarBindingXMLLiteral-    , filter1 rdfVarBindingMemberProp-    , filter2 rdfVarBindingDatatyped-    -- , filterN nullVarBindingModify-    , filter2 varFilterEQ-    , filter2 varFilterNE-    ]-    where-      -- Swish.RDF.VarBinding.openVbmName seems to require that the label-      -- list not be evaluated which means that we can not replace these-      -- statements by ones like-      ---      --    filter1 f (lb:_) = makeVarFilterModift $ f lb-      ---      filter1 f lbs = makeVarFilterModify $ f (head lbs)-      filter2 f lbs = makeVarFilterModify $ f (head lbs) (lbs!!1)-      -- filterN f lbs = makeVarFilterModify $ f ...-----------------------------------------------------------------  Declare variable binding modifiers map---------------------------------------------------------------rdfVarBindingModifiers :: [RDFOpenVarBindingModify]-rdfVarBindingModifiers =-    [ nullVarBindingModify-    ]-----------------------------------------------------------------  Find a named built-in OpenVarBindingModifier---------------------------------------------------------------allOpenVarBindingModify :: [RDFOpenVarBindingModify]-allOpenVarBindingModify =-    rdfVarBindingFilters    ++-    rdfVarBindingModifiers  ++-    dtsVarBindingModifiers--dtsVarBindingModifiers :: [RDFOpenVarBindingModify]--- dtsVarBindingModifiers = concatMap dtVarBindingModifiers allDatatypes-dtsVarBindingModifiers = concatMap typeMkModifiers allDatatypes--{--dtVarBindingModifiers dtval =-    map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval)--}--findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify-findRDFOpenVarBindingModifier nam =-    mapFindMaybe nam (LookupMap allOpenVarBindingModify)-----------------------------------------------------------------  Lookup map for built-in rulesets---------------------------------------------------------------rdfRulesetMap :: RDFRulesetMap-rdfRulesetMap = LookupMap allRulesets--allRulesets :: [RDFRuleset]-allRulesets =-    [ rulesetRDF-    , rulesetRDFS-    , rulesetRDFD-    ]-    ++ allDatatypeRulesets--allDatatypeRulesets :: [RDFRuleset]-allDatatypeRulesets = map typeRules allDatatypes----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,546 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses, OverloadedStrings #-}-------------------------------------------------------------------------------------  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, OverloadedStrings------  This module implements an inference rule based on a restruction on class---  membership of one or more values.--------------------------------------------------------------------------------------module Swish.RDF.ClassRestrictionRule-       ( ClassRestriction(..), ClassRestrictionFn-       , makeDatatypeRestriction, makeDatatypeRestrictionFn-       , makeRDFClassRestrictionRules-       , makeRDFDatatypeRestrictionRules-       , falseGraph, falseGraphStr       -       )-       where--import Swish.RDF.RDFGraph-    ( RDFLabel(..)-    , getScopedName-    , RDFGraph-    , getArcs-    , merge-    , toRDFGraph, emptyRDFGraph-    , Arc(..)-    , resRdfType-    , resRdfdMaxCardinality-    )--import Swish.RDF.RDFRuleset (RDFRule, makeRDFGraphFromN3Builder)-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.RDF.Vocabulary (namespaceRDFD)--import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder)-import Swish.Utils.PartOrderedCollection-    ( minima, maxima-    , partCompareEq, partComparePair-    , partCompareListMaybe-    , partCompareListSubset-    )--import Swish.Utils.LookupMap (LookupEntryClass(..), LookupMap(..),mapFindMaybe)-import Swish.Utils.ListHelpers (powerSet)--import Control.Monad (liftM)--import Data.Monoid (Monoid (..))-import Data.Maybe (fromJust, fromMaybe, mapMaybe)-import Data.List (delete, nub, (\\))--import qualified Data.Text.Lazy.Builder as B-----------------------------------------------------------------  Class restriction data type----------------------------------------------------------------- |Type of function that evaluates missing node values in a---  restriction from those supplied.-type ClassRestrictionFn = [Maybe RDFLabel] -> Maybe [[RDFLabel]]---- |Datatype for named class restriction-data ClassRestriction = ClassRestriction-    { crName    :: ScopedName-    , crFunc    :: ClassRestrictionFn-    }--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---------------------------------------------------------------mkPrefix :: Namespace -> B.Builder-mkPrefix = namespaceToBuilder--ruleQuery :: RDFGraph-ruleQuery = makeRDFGraphFromN3Builder $-            mconcat-            [ mkPrefix namespaceRDFD-            , " ?c a rdfd:GeneralRestriction ; "-            , "    rdfd:onProperties ?p ; "     -            , "    rdfd:constraint   ?r . "-            ]-            ---  Placeholder false graph for now.-falseGraph :: RDFGraph-falseGraph = makeRDFGraphFromN3Builder $-             mkPrefix namespaceRDFD `mappend` falseGraphStr--falseGraphStr :: B.Builder-falseGraphStr = "_:a rdfd:false _:b . "---- |Make a list of class restriction rules given a list of class restriction---  values and a graph containing one or more class restriction definitions.----makeRDFClassRestrictionRules :: [ClassRestriction] -> RDFGraph -> [RDFRule]-makeRDFClassRestrictionRules crs gr =-    mapMaybe constructRule (queryForRules gr)-    where-        queryForRules = rdfQueryFind ruleQuery-        constructRule = makeRestrictionRule1 crs gr--makeRestrictionRule1 ::-    [ClassRestriction] -> RDFGraph -> RDFVarBinding -> Maybe RDFRule-makeRestrictionRule1 crs gr vb =-    makeRestrictionRule2 rn c ps cs-    where-        c  = fromMaybe NoNode $ vbMap vb (Var "c")-        p  = fromMaybe NoNode $ vbMap vb (Var "p")-        r  = fromMaybe NoNode $ vbMap vb (Var "r")-        cs = filter (>0) $ map fromInteger $-             rdfFindPredInt c resRdfdMaxCardinality gr-        ps = rdfFindList gr p-        rn = mapFindMaybe (getScopedName r) (LookupMap crs)--makeRestrictionRule2 ::-    Maybe ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int]-    -> Maybe RDFRule-makeRestrictionRule2 (Just restriction) cls@(Res cname) props cs =-    Just restrictionRule-    where-        restrictionRule = Rule-            { ruleName = cname-              -- fwdApply :: [ex] -> [ex]-            , fwdApply = fwdApplyRestriction restriction cls props cs-              -- bwdApply :: ex -> [[ex]]-            , bwdApply = bwdApplyRestriction restriction cls props cs-            , checkInference = bwdCheckInference restrictionRule-            }-makeRestrictionRule2 _ _ _ _ = Nothing-    -- trace "\nmakeRestrictionRule: missing class restriction"----  Forward apply class restriction.-fwdApplyRestriction ::-    ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> [RDFGraph]-    -> [RDFGraph]-fwdApplyRestriction restriction cls props cs antgrs =-    maybe [falseGraph] concat newgrs-      where-        -- Instances of the named class in the graph:-        ris = nub $ rdfFindValSubj resRdfType cls antgr-        --  Merge antecedent graphs into one (with bnode renaming):-        --  (Uses 'if' and 'foldl1' to avoid merging in the common case-        --  of just one graph supplied.)-        antgr = if null antgrs then emptyRDFGraph else foldl1 merge antgrs-        --  Apply class restriction to single instance of the restricted class-        newgr :: RDFLabel -> Maybe [RDFGraph]-        newgr ri = fwdApplyRestriction1 restriction ri props cs antgr-        newgrs :: Maybe [[RDFGraph]]-        newgrs = mapM newgr ris----  Forward apply class restriction to single class instance (ci).---  Return single set of inferred results, for each combination of---  property values, or an empty list, or Nothing if the supplied values---  are inconsistent with the restriction.-fwdApplyRestriction1 ::-    ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph-    -> Maybe [RDFGraph]-fwdApplyRestriction1 restriction ci props cs antgr =-    if grConsistent then Just newgrs else Nothing-    where-        --  Apply restriction to graph-        (grConsistent,_,_,sts) = applyRestriction restriction ci props cs antgr-        --  Select results, eliminate those with unknowns-        nts :: [[RDFLabel]]-        nts = mapMaybe sequence sts-        --  Make new graph from results, including only newly generated arcs-        newarcs = 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 resRdfType cls congr-        --  Apply class restriction to single instance of the restricted class-        newgr :: RDFLabel -> Maybe [[RDFGraph]]-        newgr ri = bwdApplyRestriction1 restriction cls ri props cs congr-        --  'map newgr ris' is conjunction of disjunctions, where-        --  each disjunction is itself a conjunction of conjunctions.-        --  'sequence' distributes the conjunction over the disjunction,-        --  yielding an equivalent disjunction of conjunctions-        --  map concat flattens the conjunctions of conjuctions-        newgrs :: Maybe [[RDFGraph]]-        newgrs = 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-    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 resRdfType cls :)----  Helper function to select sub-tuples from which some of a set of---  values can be derived using a class restriction.------  restriction is the restriction being evaluated.---  ft          is a full tuple of values known to be consistent with---              the restriction------  The result returned is a list of pairs, whose first member is a partial---  tuples from which the full tuple supplied can be derived, and the second---  is the supplied tuple calculated from that input.----deriveTuple ::-    ClassRestriction -> [RDFLabel]-    -> [([Maybe RDFLabel],[RDFLabel])]-deriveTuple restriction ft =-    map (tosnd ft) $ minima partCompareListMaybe $ filter derives partials-    where-        partials = mapM (\x -> [Nothing,Just x]) ft-        derives  = ([ft]==) . fromJust . crFunc restriction-        tosnd    = flip (,)----  Helper function to apply a restriction to selected information from---  a supplied graph, and returns a tuple containing:---  (a) an indication of whether the graph is consistent with the---      restriction---  (b) a list of values specified in the graph for each property---  (c) a complete list of tuples that use combinations of values from---      the graph and are consistent with the restriction.---      Each member is a pair consisting of some combination of input---      values, and a list of complete tuple values that can be---      calculated from those inputs, or an empty list if there is---      insufficient information.---  (d) a set of tuples that are consistent with the restriction and use---      as much information from the graph as possible.  This set is---      minimal in the sense that they must all correspond to different---      complete input tuples satisfying the restriction.------  This function factors out logic that is common to forward and---  backward chaining of a class restriction.------  restriction is the class restriction being applied---  ci          is the identifier of a graph node to be tested---  props       is a list of properties of the graph noode whose values---              are constrained by the class restriction.---  cs          is a list of max cardinality constraints on the restriction,---              the minimum of which is used as the cardinality constraint---              on the restriction.  If the list is null, no cardinality---              constraint is applied.---  gr          is the graph from which property values are extracted.----applyRestriction ::-    ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> RDFGraph-    -> ( Bool-       , [[RDFLabel]]-       , [([Maybe RDFLabel],[[RDFLabel]])]-       , [[Maybe RDFLabel]]-       )-applyRestriction restriction ci props cs gr =-    (coversVals deleteMaybe sts pvs && cardinalityOK, pvs, cts, sts )-    where-        --  Extract from the antecedent graph all specified values of the-        --  restricted properties (constructs inner list for each property)-        pvs :: [[RDFLabel]]-        pvs = [ rdfFindPredVal ci p gr | p <- props ]-        --  Convert tuple of alternatives to list of alternative tuples-        --  (Each tuple is an inner list)-        pts :: [[Maybe RDFLabel]]-        pts = mapM allJustAndNothing pvs-        --  Try class restriction calculation for each tuple-        --  For each, result may be:-        --    Nothing  (inconsistent)-        --    Just []  (underspecified)-        --    Just [t] (single tuple of values derived from given values)-        --    Just ts  (alternative tuples derived from given values)-        rts :: [Maybe [[RDFLabel]]]-        rts = map (crFunc restriction) pts-        -        --  Extract list of consistent tuples of given values-        cts :: [([Maybe RDFLabel],[[RDFLabel]])]-        cts = mapMaybe tupleConv (zip pts rts)-        -        --  TODO: be more idiomatic?-        tupleConv :: (a, Maybe b) -> Maybe (a,b)-        tupleConv (a, Just b)  = Just (a,b)-        tupleConv _            = Nothing-        -        --  Build list of consistent tuples with maximum information-        --  based on that supplied and available-        -- mts = concatMap mostValues cts-        mts = map mostOneValue cts-        --  Eliminate consistent results subsumed by others.-        --  This results in a mimimal possible set of consistent inputs,-        --  because if any pair could be consistently unified then their-        --  common subsumer would still be in the list, and both would be-        --  thereby eliminated.-        sts :: [[Maybe RDFLabel]]-        sts = maxima partCompareListMaybe mts-        --  Check the cardinality constraint-        cardinalityOK = null cs || length sts <= minimum cs-        ---  Map a non-empty list of values to a list of Just values,---  preceding each with a Nothing element.------  Nothing corresponds to an unknown value.  This logic is used---  as part of constructing a list of alternative tuples of known---  data values (either supplied or calculated from the class---  restriction).----allJustAndNothing :: [a] -> [Maybe a]-allJustAndNothing as = Nothing:map Just as--{----  Get maximum information about possible tuple values from a---  given pair of input tuple, which is known to be consistent with---  the restriction, and calculated result tuples.  Where the result---  tuple is not exactly calculated, return the input tuple.------  imvs    tuple of Maybe element values, with Nothing for---          unspecified values---  movss   Maybe list of possible fully-specified result tuples,---          an empty list if no result tuples can be computed---          based on the input tuple, or Nothing if the input---          tuple is inconsistent.----mostValues :: ([Maybe a],[[a]]) -> [[Maybe a]]-mostValues (imvs,([])) = [imvs]-mostValues (_,movss) = map (map Just) movss--}----  Get maximum information about possible tuple values from a---  given pair of input and possible result tuples, which is---  known to be consistent with the restriction.  If the result---  tuple is not exactly calculated, return the input tuple.------  This is a variant of mostValues that returns a single vector.---  Multiple possible values are considered to be equivalent to---  Just [], i.e. unknown result.------  imvs    tuple of Maybe element values, with Nothing for---          unspecified values---  movss   Maybe list of possible fully-specified result tuples,---          or an empty list if no result tuples can be computed---          based on the input tuple.----mostOneValue :: ([Maybe a],[[a]]) -> [Maybe a]-mostOneValue (_,[movs]) = map Just movs-mostOneValue (imvs,_)   = imvs----  Helper function that returns subsets of dts that "cover" the indicated---  values;  i.e. from which all of the supplied values can be deduced---  by the enumerated function results.  The minima of all such subsets is---  returned, as each of these corresponds to some minimum information needed---  to deduce all of the given values.------  pvs     is a list of lists of values to be covered.  The inner list---          contains multiple values for each member of a tuple.---  dts     is an enumerated list of function values from some subset of---          the tuple space to complete tuples.  Each member is a pair---          containing the partial tuple (using Nothing for unspecified---          values) and the full tuple calculated from it.------  The return value is a disjunction of conjunctions of partial tuples---  that cover the indicated parameter values.------  NOTE:---  The result minimization is not perfect (cf. test2 below), but I believe---  it is adequate for the practical situations I envisage, and in any---  case will not result in incorrect values.  It's significance is for---  search-tree pruning.  A perfect minimization might be achieved by---  using a more subtle partial ordering that takes account of both subsets---  and the partial ordering of set members in place of 'partCompareListSubset'.----coverSets  :: (Eq a) => [[a]] -> [([Maybe a],[a])] -> [[[Maybe a]]]-coverSets pvs dts =-    minima partCompareListSubset $ map (map fst) ctss-    where-        ctss = filter coverspvs $ 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------------------------------------------------------------------------------------

@@ -1,1064 +0,0 @@-{-# LANGUAGE ExistentialQuantification, MultiParamTypeClasses, OverloadedStrings #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  Datatype---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  ExistentialQuantification, MultiParamTypeClasses, OverloadedStrings------  This module defines the structures used by Swish to represent and---  manipulate datatypes.  It is designed as a basis for handling datatyped---  RDF literals, but the functions in this module are more generic.----------------------------------------------------------------------------------------  Testing note:  this module supports a number of specific datatypes.---  It is intended that functionality in this module will be tested via---  modules "Swish.RDF.RDFDatatype", ---  "Swish.RDF.ClassRestrictionRule" and---  "Swish.RDF.RDFDatatypeXsdInteger".---  See also module ClassRestrictionRuleTest for test cases.--module Swish.RDF.Datatype-    ( Datatype(..)-    , typeName, typeRules, typeMkRules, typeMkModifiers, typeMkCanonicalForm-    , getTypeAxiom, getTypeRule-    , DatatypeVal(..)-    , getDTMod-    , getDTRel-    , tvalMkCanonicalForm-    , DatatypeMap(..)-    , DatatypeRel(..), DatatypeRelFn, DatatypeRelPr-    , altArgs-    , UnaryFnDescr,    UnaryFnTable,    UnaryFnApply,    unaryFnApp-    , BinaryFnDescr,   BinaryFnTable,   BinaryFnApply,   binaryFnApp-    , BinMaybeFnDescr, BinMaybeFnTable, BinMaybeFnApply, binMaybeFnApp-    , ListFnDescr,     ListFnTable,     ListFnApply,     listFnApp-    , DatatypeMod(..), ModifierFn-    , ApplyModifier-    , nullDatatypeMod-    -- , applyDatatypeMod-    , makeVmod11inv, makeVmod11-    , makeVmod21inv, makeVmod21-    , makeVmod20-    , makeVmod22-    , makeVmodN1-    , DatatypeSub(..)-    )-where--import Swish.RDF.Ruleset-    ( Ruleset(..)-    , getRulesetAxiom, getRulesetRule-    )--import Swish.RDF.Rule-    ( Formula(..)-    , Rule(..)-    )--import Swish.RDF.Vocabulary (swishName)-import Swish.Utils.Namespace (ScopedName)--import Swish.RDF.VarBinding-    ( VarBinding(..)-    , addVarBinding-    , VarBindingModify(..), OpenVarBindingModify, nullVarBindingModify-    )--import Swish.Utils.LookupMap-    ( LookupEntryClass(..), LookupMap(..)-    , mapFindMaybe-    )--import Swish.Utils.ListHelpers-    ( flist-    , deleteIndex-    )---- used to add Show instances for structures during debugging--- but backed out again.------ import Swish.Utils.ShowM (ShowM(..))--import Data.Maybe( isJust, catMaybes )--import Control.Monad( join, liftM )--import qualified Data.Text as T-----------------------------------------------------------------  Datatype framework----------------------------------------------------------------- |Datatype wraps a 'DatatypeVal' value, hiding the value type that---  is used only in implementations of the datatype.---  Users see just the datatype name and associated ruleset.----data Datatype ex lb vn = forall vt . Datatype (DatatypeVal ex vt lb vn)--instance LookupEntryClass-        (Datatype ex lb vn) ScopedName (Datatype ex lb vn)-    where-    newEntry (_,dt) = dt-    keyVal dt       = (typeName dt, dt)---- |Get type name from Datatype value-typeName :: Datatype ex lb vn -> ScopedName-typeName (Datatype dtv) = tvalName  dtv---- |Get static rules from Datatype value-typeRules :: Datatype ex lb vn -> Ruleset ex-typeRules (Datatype dtv) = tvalRules dtv---- |Make rules for Datatype value based on supplied expression-typeMkRules :: Datatype ex lb vn -> ex -> [Rule ex]-typeMkRules (Datatype dtv) = tvalMkRules dtv---- |Make variable binding modifiers based on values supplied-typeMkModifiers :: Datatype ex lb vn -> [OpenVarBindingModify lb vn]-typeMkModifiers (Datatype dtv) = tvalMkMods dtv---- |Get the named axiom from a Datatype value.-getTypeAxiom :: ScopedName -> Datatype ex lb vn -> Maybe (Formula ex)-getTypeAxiom nam dt = getRulesetAxiom nam (typeRules dt)---- |Get the named rule from a Datatype value.-getTypeRule :: ScopedName -> Datatype ex lb vn -> Maybe (Rule ex)-getTypeRule nam dt = getRulesetRule nam (typeRules dt)---- |Get the canonical form of a datatype value.-typeMkCanonicalForm :: Datatype ex lb vn -> T.Text -> Maybe T.Text-typeMkCanonicalForm (Datatype dtv) = tvalMkCanonicalForm dtv-----------------------------------------------------------------  DatatypeVal----------------------------------------------------------------- |DatatypeVal is a structure that defines a number of functions---  and values that characterize the behaviour of a datatype.------  A datatype is specified with respect to (polymophic in) a given---  type of (syntactic) expression with which it may be used, and---  a value type (whose existence is hidden as an existential type---  within `DatatypeMap`).------  (I tried hiding the value type with an internal existential---  declaration, but that wouldn't wash.  Hence this two-part---  structure with `Datatype` in which the internal detail---  of the value type is hidden from users of the `Datatype` class.)------  The datatype characteristic functions have two goals:------  (1) to support the general datatype entailment rules defined by---      the RDF semantics specification, and------  (2) to define additional datatype-specific inference patterns by---      means of which provide additional base functionality to---      applications based on RDF inference.------  Datatype-specific inferences are provided using the `DatatypeRel`---  structure for a datatype, which allows a number of named relations---  to be defined on datatype values, and provides mechanisms to---  calculate missing values in a partially-specified member of---  a relation.------  Note that rules and variable binding modifiers that deal with---  combined values of more than one datatype may be defined---  separately.  Definitions in this module are generally applicable---  only when using a single datatype.------  An alternative model for datatype value calculations is inspired---  by that introduced by CWM for arithmetic operations, e.g.------  >     (1 2 3) math:sum ?x => ?x rdf:value 6------  (where the bare integer @n@ here is shorthand for @\"n\"^^xsd:integer@).------  Datatype-specific inference patterns are provided in two ways:------  * by variable binding modifiers that can be combined with the---    query results during forward- for backward-chaining of---    inference rules, and------  * by the definition of inference rulesets that involve---    datatype values.------  I believe the first method to be more flexible than the second,---  in that it more readily supports forward and backward chaining,---  but can be used only through the definition of new rules.------  Type parameters:------  [@ex@] is the type of expression with which the datatype may be used.------  [@vt@] is the internal value type with which the labels are associated.------  [@lb@] is the type of label that may be used as a variable in an---         expression or rule.------  [@vn@] is the type of node that may be used to carry a value in an---         expression or rule.----data DatatypeVal ex vt lb vn = DatatypeVal-    { tvalName      :: ScopedName-                                -- ^Identifies the datatype, and also-                                --  its value space class.-    , tvalRules     :: Ruleset ex-                                -- ^A set of named expressions and rules-                                --  that are valid in in any theory that-                                --  recognizes the current datatype.-    , tvalMkRules   :: ex -> [Rule ex]-                                -- ^A function that accepts an expression-                                --  and devives some datatype-dependent-                                --  rules from it.  This is provided as a-                                --  hook for creating datatyped class-                                --  restriction rules.-    , tvalMkMods    :: [OpenVarBindingModify lb vn]-                                -- ^Constructs a list of open variable-                                --  binding modifiers based on tvalMod,-                                --  but hiding the actual value type.-    , tvalMap       :: DatatypeMap vt-                                -- ^Lexical to value mapping, where @vt@ is-                                --  a datatype used within a Haskell program-                                --  to represent and manipulate values in-                                --  the datatype's value space-    , tvalRel       :: [DatatypeRel vt]-                                -- ^A set of named relations on datatype-                                --  values.  Each relation accepts a list-                                --  of @Maybe vt@, and computes any-                                --  unspecified values that are in the-                                --  relation with values supplied.-    , tvalMod       :: [DatatypeMod vt lb vn]-                                -- ^A list of named values that are used to-                                --  construct variable binding modifiers, which-                                --  in turn may be used by a rule definition.-                                ---                                --  TODO: In due course, this value may be-                                --  calculated automatically from the supplied-                                --  value for @tvalRel@.-    }--{--instance ShowM ex => Show (DatatypeVal ex vt lb vn) where-  show dv = "DatatypeVal: " ++ show (tvalName dv) ++ "\n -> rules:\n" ++ show (tvalRules dv)--}----  Other accessor functions--getDTRel ::-    ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt)-getDTRel nam dtv =-    mapFindMaybe nam (LookupMap (tvalRel dtv))--getDTMod ::-    ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn)-getDTMod nam dtv =-    mapFindMaybe nam (LookupMap (tvalMod dtv))---- |Get the canonical form of a datatype value, or @Nothing@.----tvalMkCanonicalForm :: DatatypeVal ex vt lb vn -> T.Text -> Maybe T.Text-tvalMkCanonicalForm dtv str = can-    where-      dtmap = tvalMap dtv-      val   = mapL2V dtmap str-      can   = join $ liftM (mapV2L dtmap) val---- |DatatypeMap consists of methods that perform lexical-to-value---  and value-to-canonical-lexical mappings for a datatype.------  The datatype mappings apply to string lexical forms which---  are stored as `Data.Text`.----data DatatypeMap vt = DatatypeMap-    { mapL2V  :: T.Text -> Maybe vt-                            -- ^ Function to map a lexical string to-                            --   the datatype value.  This effectively-                            --   defines the lexical space of the-                            --   datatype to be all strings for which-                            --   yield a value other than @Nothing@.-    , mapV2L  :: vt -> Maybe T.Text-                            -- ^ Function to map a value to its canonical-                            --   lexical form, if it has such.-    }---- |Type for a datatype relation inference function.------  A datatype relation defines tuples of values that satisfy some---  relation.  A datatype relation inference function calculates---  values that complete a relation with values supplied.------  The function accepts a list of @Maybe vt@, where vt is the---  datatype value type.  It returns one of:------  * Just a list of lists, where each inner list returned is a---      complete set of values, including the values supplied, that---      are in the relation.------  * Just an empty list is returned if the supplied values are---      insufficient to compute any complete sets of values in the---      relation.------  * Nothing if the supplied values are not consistent with---      the relation.----type DatatypeRelFn vt = [Maybe vt] -> Maybe [[vt]]---- |Type for datatype relation predicate:  accepts a list of values---  and determines whether or not they satisfy the relation.----type DatatypeRelPr vt = [vt] -> Bool---- |Datatype for a named relation on values of a datatype.----data DatatypeRel vt = DatatypeRel-    { dtRelName :: ScopedName-    , dtRelFunc :: DatatypeRelFn vt-    }--instance LookupEntryClass (DatatypeRel vt) ScopedName (DatatypeRel vt)-    where-    newEntry (_,relf) = relf-    keyVal dtrel = (dtRelName dtrel, dtrel)---- |Datatype value modifier functions type------  Each function accepts a list of values and returns a list of values.---  The exact significance of the different values supplied and returned---  depends on the variable binding pattern used (cf. 'ApplyModifier'),---  but in all cases an empty list returned means that the corresponding---  inputs are not consistent with the function and cannot be used.----type ModifierFn vn = [vn] -> [vn]---- |Type of function used to apply a data value modifier to specified---  variables in a supplied variable binding.  It also accepts the---  name of the datatype modifier and carries it into the resulting---  variable binding modifier.------  (Note that @vn@ is not necessarily the same as @vt@, the datatype value---  type:  the modifier functions may be lifted or otherwise adapted---  to operate on some other type from which the raw data values are---  extracted.)----type ApplyModifier lb vn =-    ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn---- |Wrapper for data type variable binding modifier included in---  a datatype value.----data DatatypeMod vt lb vn = DatatypeMod-    { dmName :: ScopedName-    , dmModf :: [ModifierFn vt]-    , dmAppf :: ApplyModifier lb vn-    }--instance LookupEntryClass-        (DatatypeMod vt lb vn) ScopedName (DatatypeMod vt lb vn)-    where-    newEntry (_,dmod) = dmod-    keyVal dmod = (dmName dmod, dmod)---- |Null datatype value modifier-nullDatatypeMod :: DatatypeMod vt lb vn-nullDatatypeMod = DatatypeMod-    { dmName = swishName "nullDatatypeMod"-    , dmModf = []-    , dmAppf = nullAppf-    }-    where-        -- nullAppf :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn-        nullAppf nam _ lbs = (nullVarBindingModify lbs) { vbmName = nam }--{---- |Apply datatype variable binding modifier value to list of labels and---  a variable binding.-applyDatatypeMod :: (Eq lb, Show lb, Eq vn, Show vn)-    => DatatypeMod vt lb vn -> OpenVarBindingModify lb vn-applyDatatypeMod dtmod = dmAppf dtmod (dmName dtmod) (dmModf dtmod)--}--{--dmName dtmod :: ScopedName-dmModf dtmod :: [ModifierFn vt]-             :: [[vt] -> [vt]]-dmAppf dtmod :: ApplyModifier lb vn-             :: ScopedName -> [ModifierFn vn] -> OpenVarBindingModify lb vn-             :: ScopedName -> [[vn] -> [vn]] -> OpenVarBindingModify lb vn-dmAppf dtmod (dmName dtmod)-             :: [[vn] -> [vn]] -> OpenVarBindingModify lb vn--}-------------------------------------------------------------------  Functions for creating datatype variable binding modifiers------------------------------------------------------------------- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a @1->1@ function and inverse, such---  as negate.------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.---        ---  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any---              new variable bindings), returning a non-empty list if @x@ and @y@---              are in the appropriate relationship.------          (1) is @[y] -> [x]@, used to perform the calculation in a forward---              direction.------          (2) is @[x] -> [y]@, used to perform the calculation in a backward---              direction.  This may be the same as (2) (e.g. for negation)---              or may be different (e.g. increment).------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.  (The intent is that a variable-free---          value can be generated as a Curried function, and instantiated---          for particular variables as required.)------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmod11inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod11inv nam [f0,f1,f2] lbs@(~[lb1,lb2]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1],[lb2]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2] vbind = selv     (f0 [v1,v2]) vbind-        app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2])    vbind-        app2 [Just v1,Nothing] vbind = addv lb2 (f2 [v1])    vbind-        app2 _                     _     = []-makeVmod11inv _ _ _ =-    error "makeVmod11inv: requires 3 functions and 2 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases when---  the value mapping is a non-invertable @1->1@ injection, such as---  absolute value.------  [@nam@] is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@] are functions used to implement details of the variable---          binding modifier:------          (0) is @[x,y] -> [?]@, used as a filter (i.e. not creating any---              new variable bindings), returning a non-empty list if @x@ and @y@---              are in the appropriate relationship.------          (1) is @[x]@ -> @[y]@, used to perform the calculation.------  [@lbs@] is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmod11 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod11 nam [f0,f1] lbs@(~[lb1,_]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2])  vbind-        app2 [Nothing,Just v2] vbind = addv lb1 (f1 [v2]) vbind-        app2 _                     _     = []-makeVmod11 _ _ _ =-    error "makeVmod11: requires 2 functions and 2 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a @2->1@ invertable function, such as---  addition or subtraction.------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any---              new variable bindings), returning a non-empty list if---              @x@, @y@ and @z@ are in the appropriate relationship.------          (2) is @[y,z] -> [x]@, used to perform the calculation in a---              forward direction.------          (3) is @[x,z] -> [y]@, used to run the calculation backwards to---              determine the first input argument------          (4) is @[x,y] -> [z]@, used to run the calculation backwards to---              determine the second input argument------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmod21inv :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod21inv nam [f0,f1,f2,f3] lbs@(~[lb1,lb2,lb3]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1],[lb2],[lb3]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind-        app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind-        app2 [Just v1,Nothing,Just v3] vbind = addv lb2 (f2 [v1,v3]) vbind-        app2 [Just v1,Just v2,Nothing] vbind = addv lb3 (f3 [v1,v2]) vbind-        app2 _                               _     = []-makeVmod21inv _ _ _ =-    error "makeVmod21inv: requires 4 functions and 3 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a @2->1@ non-invertable function, such as---  logical @AND@ or @OR@.------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (1) is @[x,y,z] -> [?]@, used as a filter (i.e. not creating any---              new variable bindings), returning a non-empty list if---              @x@, @y@ and @z@ are in the appropriate relationship.------          (2) is @[y,z] -> [x]@, used to perform the calculation in a---              forward direction.------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmod21 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod21 nam [f0,f1] lbs@(~[lb1,_,_]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2,Just v3] vbind = selv (f0 [v1,v2,v3]) vbind-        app2 [Nothing,Just v2,Just v3] vbind = addv lb1 (f1 [v2,v3]) vbind-        app2 _                               _     = []-makeVmod21 _ _ _ =-    error "makeVmod21: requires 2 functions and 3 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a simple comparson of two values.------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (1) is @[x,y] -> [?]@, used as a filter (i.e. not creating any---              new variable bindings), returning a non-empty list if---              @x@ and @y@ are in the appropriate relationship.------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmod20 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod20 nam [f0] lbs@(~[_,_]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2] vbind = selv (f0 [v1,v2]) vbind-        app2 _                     _     = []-makeVmod20 _ _ _ =-    error "makeVmod20: requires 1 function and 2 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a @2->2@ non-invertable function, such as---  quotient/remainder------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (1) is @[w,x,y,z] -> [?]@, used as a filter (i.e. not creating---              any new variable bindings), returning a non-empty list if---              @w@, @x@, @y@ and @z@ are in the appropriate relationship.------          (2) is @[y,z] -> [w,x]@, used to perform the calculation given---              two input values.------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.------  NOTE: this might be generalized to allow one of @w@ or @x@ to be---  specified, and return null if it doesn't match the calculated value.----makeVmod22 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmod22 nam [f0,f1] lbs@(~[lb1,lb2,_,_]) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1,lb2]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 [Just v1,Just v2,Just v3,Just v4] vbind =-            selv (f0 [v1,v2,v3,v4]) vbind-        app2 [Nothing,Nothing,Just v3,Just v4] vbind =-            addv2 lb1 lb2 (f1 [v3,v4]) vbind-        app2 _                               _     = []-makeVmod22 _ _ _ =-    error "makeVmod22: requires 2 functions and 4 labels"---- |'ApplyModifier' function for use with 'DatatypeMod' in cases---  when the value mapping is a @N->1@ function,---  such as Sigma (sum) of a vector.------  [@nam@]     is the name from the 'DatatypeMod' value that is carried into---          the resulting variable binding modifier.------  [@fns@]     are functions used to implement details of the variable---          binding modifier:------          (1) is @[x,y...] -> [?]@, used as a filter (i.e. not creating---              any new variable bindings), returning a non-empty list if---              @x@ and @y...@ are in the appropriate relationship.------          (2) is @[y...] -> [x]@, used to perform the calculation.------  [@lbs@]     is a list of specific label values for which a variable binding---          modifier will be generated.------  Note: an irrefutable pattern match for @lbs@ is used so that a name---  for the 'VarBindingModify' value can be extracted using an undefined---  label value.----makeVmodN1 :: (Eq lb, Show lb, Eq vn, Show vn) => ApplyModifier lb vn-makeVmodN1 nam [f0,f1] lbs@(~(lb1:_)) = VarBindingModify-    { vbmName   = nam-    , vbmApply  = concatMap app1-    , vbmVocab  = lbs-    , vbmUsage  = [[],[lb1]]-    }-    where-        app1 vbind = app2 (map (vbMap vbind) lbs) vbind-        app2 vs@(v1:_) vbind-            | isJust v1 && isJustvs = selv (f0 jvs) vbind-            | isJustvs              = addv lb1 (f1 jvs) vbind-            | otherwise             = []-            where-                isJustvs = all isJust vs-                jvs      = catMaybes vs-        app2 _ _ = error "app2 sent empty list" -- -Wall--makeVmodN1 _ _ _ =-    error "makeVmodN1: requires 2 functions and at 1 or more labels"-------------------------------------------------------------  Local helper functions for makeVmodXXX variants-------------------------------------------------------------  Add value to variable variable binding, if value is singleton list,---  otherwise return empty list.-addv :: (Eq lb, Show lb, Eq vt, Show vt)-    => lb -> [vt] -> VarBinding lb vt-    -> [VarBinding lb vt]-addv lb [val] vbind = [addVarBinding lb val vbind]-addv _  _     _     = []----  Add two entries to variable variable binding, if value supplied is---  a doubleton list, otherwise return empty list.-addv2 :: (Eq lb, Show lb, Eq vt, Show vt)-    => lb -> lb -> [vt] -> VarBinding lb vt-    -> [VarBinding lb vt]-addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $-                                   addVarBinding lb2 val2 vbind]-addv2 _   _   _           _     = []----  If supplied value is non-empty list return supplied variable binding,---  otherwise return empty list.-selv :: [vt] -> varBinding lb vt -> [varBinding lb vt]-selv [] _     = []-selv _  vbind = [vbind]-------------------------------------------------------------------  Functions for evaluating arguments in a datatype relation---------------------------------------------------------------------  altArgs is a generic function for evaluating datatype relation---          values, based on suppied functions and argument values------  UnaryFnDescr, UnaryFnApply and unaryFnApp:---          are support types and function for using altArgs to---          evaluate relations on unary functions (binary relations).------  BinaryFnDescr, BinaryFnApply and binaryFnApp:---          are support types and function for using altArgs to---          evaluate relations on binary functions (3-way relations).------  ListFnDescr, ListFnApply and listFnApp:---          are support types and function for using altArgs to---          evaluate relations on list functions (n-way relations),---          where the first member of the list is the value of a---          fold of a function over the rest of the list.------  See experimental module spike-altargs.hs for test cases and---  development steps for this function.---- |Given a list of argument values and a list of functions for---  calculating new values from supplied values, return a list---  of argument values, or @Nothing@ if the supplied values are---  inconsistent with the calculations specified.------  Each list of values returned corresponds to a set of values that---  satisfy the relation, consistent with the values supplied.------  Functions are described as tuple consisting of:------    (a) a predicate that the argument is required to satisfy------    (b) a function to apply,------    (c) a function to apply function (b) to a list of arguments------    (d) argument list index values to which the function is applied.------  Each supplied argument is of the form @Maybe a@, where the argument---  has value type a.  @Nothing@ indicates arguments of unknown value.------  The basic idea is that, for each argument position in the relation,---  a function may be supplied to calculate that argument's possible values---  from some combination of the other arguments.  The results calculated---  in this way are compared with the original arguments provided:---  if the values conflict then the relation is presumed to be---  unsatisfiable with the supplied values, and @Nothing@ is returned;---  if there are any calculated values for arguments supplied without---  any values, then tbe calculated values are used.---  If there are any arguments for which no values are supplied or---  calculated, then the relation is presumed to be underdetermined,---  and @Just []@ is returned.----altArgs :: -  (Eq vt)-  => DatatypeRelPr vt -  -> [(vt->Bool,[b])]-  -- ^ a list of argument value predicates and-  --   function descriptors.  The predicate indicates any-  --   additional constraints on argument values (e.g. the result-  --   of abs must be positive).  Use @(const True)@ for the predicate-  --   associated with unconstrained relation arguments.-  --   For each argument, a list of function descriptors is-  --   supplied corresponding to alternative values (e.g. a square-  --   relation would offer two alternative values for the root.)--  -> ((vt->Bool)->b->[Maybe vt]->Maybe [vt])-  -- ^ a function that takes an argument value predicate,-  --   a function descriptor and applies it to a supplied argument-  --   list to return:-  --   @Just a@ calculated list of one or more possible argument values,-  --   @Just []@ indicating insufficient information provided, or-  --   @Nothing@ indicating inconsistent information provided.-  --   May be one of 'unaryFnApp', 'binaryFnApp', 'listFnApp' or-  --   some other caller-supplied value.--  -> DatatypeRelFn vt-  -- ^ The return value can be used as the-  -- 'dtRelFunc' component of a 'DatatypeRel' value.--altArgs pr fnss apfn args = cvals4 cvals3-    where-        --  Calculate new value(s) for each argument from supplied values, and-        --  lift inconsistency indicator (Just/Nothing) to outermost Monad.-        --    cvals1 :: [Maybe [vt]]-        cvals1 = flist (map (applyFdescToTuple apfn) fnss) args-        --  Merge calculated values with supplied arguments, and again-        --  lift inconsistency indicator (Just/Nothing) to outermost Monad.-        --    cvals2 :: Maybe [[vt]]-        cvals2 = sequence $ mergeTupleVals (map fst fnss) args cvals1-        --  Map list of alternative values for each tuple member to-        --  a list of alternative tuples.-        cvals3 = liftM sequence cvals2-        --  Check each tuple against the supplied predicate.-        --  If any of the alternative tuples does not match the predicate-        --  then signal an inconsistency.-        cvals4 Nothing       = Nothing-        cvals4 cvs@(Just ts) = if all pr ts then cvs else Nothing----  Perform alternative calculations for single result value---  Each result value is a list of zero or more alternatives---  that can be calculated from available parameters, or---  Nothing if the available parameters are inconsistent.------  apfn    is the function that actually applies an element of---          the function descriptor to a tuple of Maybe arguments---          (where Nothing is used to indicate an unknown value)---  (p,fns) is a pair consisting of a value-checking predicate---          for the corresponding tuple member, and a list of---          function descriptors that each return one or more---          values the tuple member, calculated from other values---          that are present.  Just [] means no values are---          calculated for this member, and Nothing means the---          calculation has detected tuple values supplied that---          are inconsistent with the datatype relation concerned.---  args    is a tuple of Maybe tuple elements, (where Nothing---          indicates an unknown value).------  Returns Maybe a list of alternative values for the member,---  Just [] to indicate insufficient information to calculate---  any new values, and Nothing to indicate an inconsistency.----applyFdescToTuple ::-    ((vt->Bool)->b->[Maybe vt]->Maybe [vt]) -> (vt->Bool,[b]) -> [Maybe vt]-    -> Maybe [vt]-applyFdescToTuple apfn (p,fns) args =-    liftM concat $ sequence cvals-    where-        -- cvals :: [Maybe [vt]]-        cvals = flist (map (apfn p) fns) args----  Merge calculated tuple values with supplied tuple, checking for consistency.------  ps      predicates used for isolated validation of each tuple member---  args    supplied tuple values, with Nothing for unknown values---  cvals   list of alternative calculated values for each tuple member,---          or Nothing if an inconsistency has been detected by the---          tuple-calculation functions.  Note that this list may contain---          more entries than args; the surplus entries are ignored---          (see list functions for how this is used).------  Returns a tuple of Maybe lists of values for each tuple member,---  containing Nothing if an inconsistency has been detected in the---  supplied values.----mergeTupleVals  :: (Eq a) => [a->Bool] -> [Maybe a] -> [Maybe [a]] -> [Maybe [a]]-mergeTupleVals _ _  (Nothing:_) = [Nothing]-mergeTupleVals (_:ps) (Nothing:a1s) (Just a2s:a2ss)-                             = Just a2s:mergeTupleVals ps a1s a2ss-mergeTupleVals (p:ps) (Just a1:a1s) (Just []:a2ss)-    | p a1                   = Just [a1]:mergeTupleVals ps a1s a2ss-    | otherwise              = [Nothing]-mergeTupleVals (p:ps) (Just a1:a1s) (Just a2s:a2ss)-    | p a1 && elem a1 a2s    = Just [a1]:mergeTupleVals ps a1s a2ss-    | otherwise              = [Nothing]-mergeTupleVals _ [] _        = []-mergeTupleVals _ _  _        = [Nothing]---- |'altArgs' support for unary functions: function descriptor type-type UnaryFnDescr a = (a->a,Int)---- |'altArgs' support for unary functions: function descriptor table type-type UnaryFnTable a = [(a->Bool,[UnaryFnDescr a])]---- |'altArgs' support for unary functions: function applicator type-type UnaryFnApply a = (a->Bool) -> UnaryFnDescr a -> [Maybe a] -> Maybe [a]---- |'altArgs' support for unary functions: function applicator-unaryFnApp :: UnaryFnApply a-unaryFnApp p (f1,n) args = apf (args!!n)-    where-        apf (Just a) = if p r then Just [r] else Nothing where r = f1 a-        apf Nothing  = Just []---- |'altArgs' support for binary functions: function descriptor type-type BinaryFnDescr a = (a->a->a,Int,Int)---- |'altArgs' support for binary functions: function descriptor table type-type BinaryFnTable a = [(a->Bool,[BinaryFnDescr a])]---- |'altArgs' support for binary functions: function applicator type-type BinaryFnApply a =-    (a->Bool) -> BinaryFnDescr a -> [Maybe a] -> Maybe [a]---- |'altArgs' support for binary functions: function applicator-binaryFnApp :: BinaryFnApply a-binaryFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2)-    where-        apf (Just a1) (Just a2) = if p r then Just [r] else Nothing-            where r = f a1 a2-        apf _ _  = Just []---- |'altArgs' support for binary function with provision for indicating---  inconsistent supplied values:  function descriptor type-type BinMaybeFnDescr a = (a->a->Maybe [a],Int,Int)---- |'altArgs' support for binary function with provision for indicating---  inconsistent supplied values:  function descriptor table type-type BinMaybeFnTable a = [(a->Bool,[BinMaybeFnDescr a])]---- |'altArgs' support for binary function with provision for indicating---  inconsistent supplied values:  function applicator type-type BinMaybeFnApply a =-    (a->Bool) -> BinMaybeFnDescr a -> [Maybe a] -> Maybe [a]---- |'altArgs' support for binary function with provision for indicating---  inconsistent supplied values:  function applicator-binMaybeFnApp :: BinMaybeFnApply a-binMaybeFnApp p (f,n1,n2) args = apf (args!!n1) (args!!n2)-    where-        apf (Just a1) (Just a2) = if pm r then r else Nothing-            where-                r = f a1 a2-                pm Nothing  = False-                pm (Just x) = all p x-        apf _ _  = Just []---- |'altArgs' support for list functions (e.g. sum over list of args),---  where first element of list is a fold over the rest of the list,---  and remaining elements of list can be calculated in terms---  of the result of the fold and the remaining elements------  List function descriptor is------  (a) list-fold function, f  (e.g. (+)---        ---  (b) list-fold identity, z  (e.g. 0)---        ---  (c) list-fold-function inverse, g (e.g. (-))---        ---  (d) index of element to evaluate---        ---  such that:---        ---  >    (a `f` z) == (z `f` a) == a---  >    (a `g` c) == b <=> a == b `f` c---  >    (a `g` z) == a---  >    (a `g` a) == z------  and the result of the folded function does not depend on---  the order that the list elements are processed.------  NOTE:  the list of 'ListFnDescr' values supplied to 'altArgs' must---  be at least as long as the argument list.  In many cases, Haskell---  lazy evaluation can be used to supply an arbitrarily long list.---  See test cases in spike-altargs.hs for an example.------  Function descriptor type-type ListFnDescr a = (a->a->a,a,a->a->a,Int)---- |Function table type-type ListFnTable a = [(a->Bool,[ListFnDescr a])]---- |'altArgs' support for list functions:  function applicator type-type ListFnApply a = (a->Bool) -> ListFnDescr a -> [Maybe a] -> Maybe [a]---- |'altArgs' support for list functions:  function applicator-listFnApp :: ListFnApply a-listFnApp p (f,z,g,n) (a0:args)-    | n == 0    =-        app $ foldr (apf f) (Just [z]) args-    | otherwise =-        app $ apf g a0 (foldr (apf f) (Just [z]) (args `deleteIndex` (n-1)))-    where-        apf :: (a->a->a) -> Maybe a -> Maybe [a] -> Maybe [a]-        apf fn (Just a1) (Just [a2]) = Just [fn a1 a2]-        apf _  _         _           = Just []-        -        -- app :: Maybe [a] -> Maybe [a]-        app Nothing      = Nothing-        app r@(Just [a]) = if p a then r else Nothing-        app _            = Just []--listFnApp _ _ [] = error "listFnApp called with an empty list" -- -Wall-------------------------------------------------------------  Datatype sub/supertype description------------------------------------------------------------- |Describe a subtype/supertype relationship between a pair of datatypes.------  Originally, I had this as a supertype field of the DatatypeVal structure,---  but that suffered from some problems:------  * supertypes may be introduced retrospectively,------  * the relationship expressed with respect to a single datatype---      cannot indicate how to do injections/restrictions between the---      underlying value types.------  [@ex@]      is the type of expression with which the datatype may be used.------  [@lb@]      is the type of the variable labels used.------  [@vn@]      is the type of value node used to contain a datatyped value------  [@supvt@]   is the internal value type of the super-datatype------  [@subvt@]   is the internal value type of the sub-datatype----data DatatypeSub ex lb vn supvt subvt = DatatypeSub-    { trelSup   :: DatatypeVal ex supvt lb vn-                                -- ^ Datatype that is a supertype of @trelSub@,-                                --   having value space @supvt@.-    , trelSub   :: DatatypeVal ex subvt lb vn-                                -- ^ Datatype that is a subtype of @trelSup@,-                                --   having value space @supvt@.-    , trelToSup :: subvt -> supvt-                                -- ^ Function that maps subtype value to-                                --   corresponding supertype value.-    , trelToSub :: supvt -> Maybe subvt-                                -- ^ Function that maps supertype value to-                                --   corresponding subtype value, if there-                                --   is such a value.-    }----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,248 +0,0 @@-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  GraphClass---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  DeriveFunctor, DeriveFoldable, DeriveTraversable, MultiParamTypeClasses------  This module defines a Labelled Directed Graph and Label classes,---  and the Arc datatype.----------------------------------------------------------------------------------------------------------------------------------------------------- Define LDGraph, arc and related classes and types---------------------------------------------------------------module Swish.RDF.GraphClass-    ( LDGraph(..), replaceArcs-    , Label(..)-    , Arc(..), arcSubj, arcPred, arcObj, arc, arcToTriple, arcFromTriple-    , Selector-    , hasLabel, arcLabels -- , arcNodes-    )-where--import qualified Data.Foldable as F-import qualified Data.Traversable as T--import Data.Hashable (Hashable(..))--import Data.List (foldl', union, (\\))----  NOTE:  I wanted to declare this as a subclass of Functor, but---  the constraint on the label type seems to prevent that.---  So I've just declared specific instances to be Functors.-----{-|-Labelled Directed Graph class--Minimum required implementation:  `setArcs`, `getArcs` and `containedIn`-(although @containedIn@ may be removed as it is currently unused).--}-class (Eq (lg lb), Eq lb ) => LDGraph lg lb-    where-    --  empty graph-    --  emptyGr     :: lg lb    [[[TODO?]]]-    --  component-level operations-      -    -- | Replace the existing arcs in the graph.-    setArcs     :: [Arc lb] -> lg lb -> lg lb-    -    -- | Extract all the arcs from a graph-    getArcs     :: lg lb -> [Arc lb]-    -    -- | Extract those arcs that match the given `Selector`.-    extract     :: Selector lb -> lg lb -> lg lb-    extract sel = update (filter sel)-    -    -- | Add the two graphs-    add         :: lg lb -> lg lb -> lg lb-    add    addg = update (union (getArcs addg))-    -    -- | Remove those arcs in the first graph from the second-    -- graph-    delete :: lg lb  -- ^ g1-              -> lg lb -- ^ g2-              -> lg lb -- ^ g2 - g1 -> g3-    delete delg = update (\\ getArcs delg)-    -    -- | Enumerate the distinct labels contained in a graph;-    -- that is, any label that appears in the subject,-    -- predicate or object position of an `Arc`.-    labels      :: lg lb -> [lb]-    labels g    = foldl' union [] (map arcLabels (getArcs g))-    -    -- | Enumerate the distinct nodes contained in a graph;-    -- that is, any label that appears in the subject-    -- or object position of an `Arc`.-    nodes       :: lg lb -> [lb]-    nodes g     = foldl' union [] (map arcNodes (getArcs g))-    -    -- | Test for graph containment in another.-    ---    -- At present this is unused and may be removed in a future release.-    containedIn :: lg lb -> lg lb -> Bool -    -    -- | Update the arcs in a graph using a supplied function.-    update      :: ( [Arc lb] -> [Arc lb] ) -> lg lb -> lg lb-    update f g  = setArcs ( f (getArcs g) ) g--{--TODO:-  add a Monoid instance for LDGraph, so that we can remove the-  NSGraph instance in RDFGraph--  This means adding the emptyGr function to the interface--}---- |Function to replace arcs in a graph with a given list of arcs.------ This is identical to @flip setArcs@ and so may be removed.---    -replaceArcs :: (LDGraph lg lb) => lg lb -> [Arc lb] -> lg lb-replaceArcs = flip setArcs--- replaceArcs gr as = update (const as) gr---- | Label class------  A label may have a fixed binding, which means that the label identifies (is) a---  particular graph node, and different such labels are always distinct nodes.---  Alternatively, a label may be unbound (variable), which means that it is a---  placeholder for an unknown node label.  Unbound node labels are used as---  graph-local identifiers for indicating when the same node appears in---  several arcs.------  For the purposes of graph-isomorphism testing, fixed labels are matched when they---  are the same.  Variable labels may be matched with any other variable label.---  Our definition of isomorphism (for RDF graphs) does not match variable labels---  with fixed labels.--class (Eq lb, Show lb, Ord lb) => Label lb where-  -  -- | Does this node have a variable binding?-  labelIsVar  :: lb -> Bool           -    -  -- | Calculate the hash of the label using the supplied seed.-  labelHash   :: Int -> lb -> Int     -  -  -- could provide a default of -  --   labelHash = hashWithSalt-  -- but this would then force a Hashable constraint-    -  -- | Extract the local id from a variable node.                 -  getLocal    :: lb -> String-    -  -- | Make a label value from a local id.  -  makeLabel   :: String -> lb-    -  -- compare     :: lb -> lb -> Ordering-  -- compare l1 l2 = compare (show l1) (show l2)---- | Arc type--data Arc lb = Arc -              { asubj :: lb  -- ^ The subject of the arc.-              , apred :: lb  -- ^ The predicate (property) of the arc.-              , aobj :: lb   -- ^ The object of the arc.-              }-            deriving (Eq, Functor, F.Foldable, T.Traversable)--instance (Hashable lb) => Hashable (Arc lb) where-  hash (Arc s p o) = hash s `hashWithSalt` p `hashWithSalt` o-  hashWithSalt salt (Arc s p o) = salt `hashWithSalt` s `hashWithSalt` p `hashWithSalt` o---- | Return the subject of the arc.-arcSubj :: Arc lb -> lb-arcSubj = asubj---- | Return the predicate (property) of the arc.-arcPred :: Arc lb -> lb-arcPred = apred---- | Return the object of the arc.-arcObj :: Arc lb -> lb-arcObj = aobj---- | Create an arc.-arc :: lb      -- ^ The subject of the arc.-       -> lb   -- ^ The predicate of the arc.-       -> lb   -- ^ The object of the arc.-       -> Arc lb-arc = Arc---- | Convert an Arc into a tuple.-arcToTriple :: Arc lb -> (lb,lb,lb)-arcToTriple (Arc s p o) = (s, p, o)---- | Create an Arc from a tuple.-arcFromTriple :: (lb,lb,lb) -> Arc lb-arcFromTriple (s,p,o) = Arc s p o--instance Ord lb => Ord (Arc lb) where-  compare (Arc s1 p1 o1) (Arc s2 p2 o2)-    | cs /= EQ = cs-    | cp /= EQ = cp-    | otherwise = co-    where-      cs = compare s1 s2-      cp = compare p1 p2-      co = compare o1 o2--  {- not needed-  (Arc s1 p1 o1) <= (Arc s2 p2 o2)-    | s1 /= s2 = s1 <= s2-    | p1 /= p2 = p1 <= p2-    | otherwise = o1 <= o2-  -}--instance (Show lb) => Show (Arc lb) where-    show (Arc lb1 lb2 lb3) =-        "("++ show lb1 ++","++ show lb2 ++","++ show lb3 ++")"---- | Identify arcs.-type Selector lb = Arc lb -> Bool--hasLabel :: (Eq lb) => lb -> Arc lb -> Bool-hasLabel lbv lb = lbv `elem` arcLabels lb---- | Return all the labels in an arc.-arcLabels :: Arc lb -> [lb]-arcLabels (Arc lb1 lb2 lb3) = [lb1,lb2,lb3]---- | Return just the subject and object labels in the arc.-arcNodes :: Arc lb -> [lb]-arcNodes (Arc lb1 _ lb3) = [lb1,lb3]----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,622 +0,0 @@-{-# LANGUAGE FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  GraphMatch---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses------  This module contains graph-matching logic.------  The algorithm used is derived from a paper on RDF graph matching---  by Jeremy Carroll [1].------  [1] <http://www.hpl.hp.com/techreports/2001/HPL-2001-293.html>--------------------------------------------------------------------------------------module Swish.RDF.GraphMatch-      ( graphMatch,-        -- * Exported for testing-        LabelMap, GenLabelMap(..), LabelEntry, GenLabelEntry(..),-        ScopedLabel(..), makeScopedLabel, makeScopedArc,-        LabelIndex, EquivalenceClass, nullLabelVal, emptyMap,-        labelIsVar, labelHash,-        mapLabelIndex, setLabelHash, newLabelMap,-        graphLabels, assignLabelMap, newGenerationMap,-        graphMatch1, graphMatch2, equivalenceClasses, reclassify-      ) where--import Control.Exception.Base (assert)-import Control.Arrow (second)--import Data.Ord (comparing)-import Data.List (foldl', nub, sortBy, partition)-import Data.Hashable (combine)-import qualified Data.List as L--import Swish.RDF.GraphClass (Arc(..), Label(..),-                             arcLabels,-                             hasLabel, arcToTriple)-import Swish.Utils.LookupMap (LookupEntryClass(..), LookupMap(..),-                              makeLookupMap, listLookupMap, mapFind, mapReplaceAll,-                              mapAddIfNew, mapReplaceMap, mapMerge)-import Swish.Utils.ListHelpers (select, equiv, pairSort, pairGroup, pairUngroup)-------------------------------  Label index value type---------------------------------- | LabelIndex is a unique value assigned to each label, such that---  labels with different values are definitely different values---  in the graph;  e.g. do not map to each other in the graph---  bijection.  The first member is a generation counter that---  ensures new values are distinct from earlier passes.--type LabelIndex = (Int,Int)--nullLabelVal :: LabelIndex-nullLabelVal = (0,0)----------------------------  Label mapping types--------------------------data (Label lb) => GenLabelEntry lb lv = LabelEntry lb lv--type LabelEntry lb = GenLabelEntry lb LabelIndex--instance (Label lb, Eq lb, Show lb, Eq lv, Show lv)-    => LookupEntryClass (GenLabelEntry lb lv) lb lv where-    keyVal   (LabelEntry k v) = (k,v)-    newEntry (k,v)            = LabelEntry k v--instance (Label lb, Eq lb, Show lb, Eq lv, Show lv)-    => Show (GenLabelEntry lb lv) where-    show = entryShow--instance (Label lb, Eq lb, Show lb, Eq lv, Show lv)-    => Eq (GenLabelEntry lb lv) where-    (==) = entryEq---- | Type for label->index lookup table-data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv =-    LabelMap Int (LookupMap (GenLabelEntry lb lv))--type LabelMap lb = GenLabelMap lb LabelIndex--instance (Label lb) => Show (LabelMap lb) where-    show = showLabelMap--instance (Label lb) => Eq (LabelMap lb) where-    LabelMap gen1 lmap1 == LabelMap gen2 lmap2 =-        gen1 == gen2 && es1 `equiv` es2-        where-            es1 = listLookupMap lmap1-            es2 = listLookupMap lmap2--emptyMap :: (Label lb) => LabelMap lb-emptyMap = LabelMap 1 $ makeLookupMap []-------------------------------  Equivalence class type---------------------------------- | Type for equivalence class description---  (An equivalence class is a collection of labels with---  the same LabelIndex value.)--type EquivalenceClass lb = (LabelIndex,[lb])--{--ecIndex :: EquivalenceClass lb -> LabelIndex-ecIndex = fst--}--ecLabels :: EquivalenceClass lb -> [lb]-ecLabels = snd--{--ecSize :: EquivalenceClass lb -> Int-ecSize = length . ecLabels--}--ecRemoveLabel :: (Label lb) => EquivalenceClass lb -> lb -> EquivalenceClass lb-ecRemoveLabel xs l = second (L.delete l) xs-----------------------------------------------------------------  Augmented graph label value - for graph matching------------------------------------------------------------------- | This instance of class label adds a graph identifier to---  each variable label, so that variable labels from---  different graphs are always seen as distinct values.------  The essential logic added by this class instance is embodied---  in the eq and hash functions.  Note that variable label hashes---  depend only on the graph in which they appear, and non-variable---  label hashes depend only on the variable.  Label hash values are---  used when initializing a label equivalence-class map (and, for---  non-variable labels, also for resolving hash collisions).--data (Label lb) => ScopedLabel lb = ScopedLabel Int lb--makeScopedLabel :: (Label lb) => Int -> lb -> ScopedLabel lb-makeScopedLabel = ScopedLabel --makeScopedArc :: (Label lb) => Int -> Arc lb -> Arc (ScopedLabel lb)-makeScopedArc scope = fmap (ScopedLabel scope)--instance (Label lb) => Label (ScopedLabel lb) where-    getLocal  lab    = error $ "getLocal for ScopedLabel: "++show lab-    makeLabel locnam = error $ "makeLabel for ScopedLabel: "++locnam-    labelIsVar (ScopedLabel _ lab)   = labelIsVar lab-    labelHash seed (ScopedLabel scope lab)-        | labelIsVar lab    = seed `combine` scope -- MH.hash seed $ show scope ++ "???"-        | otherwise         = labelHash seed lab--instance (Label lb) => Eq (ScopedLabel lb) where-    (ScopedLabel s1 l1) == (ScopedLabel s2 l2)-        = l1 == l2 && s1 == s2--instance (Label lb) => Show (ScopedLabel lb) where-    show (ScopedLabel s1 l1) = show s1 ++ ":" ++ show l1--instance (Label lb) => Ord (ScopedLabel lb) where-    compare (ScopedLabel s1 l1) (ScopedLabel s2 l2) =-        case compare s1 s2 of-            LT -> LT-            EQ -> compare l1 l2-            GT -> GT---- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ?---- | Graph matching function accepting two lists of arcs and---  returning a node map if successful----graphMatch :: (Label lb) =>-    (lb -> lb -> Bool)-    -- ^ a function that tests for additional constraints-    --   that may prevent the matching of a supplied pair-    --   of nodes.  Returns `True` if the supplied nodes may be-    --   matched.  (Used in RDF graph matching for checking-    --   that formula assignments are compatible.)-    -> [Arc lb] -- ^ the first graph to be compared, as a list of arcs-    -> [Arc lb] -- ^ the second graph to be compared, as a list of arcs-    -> (Bool,LabelMap (ScopedLabel lb))-    -- ^ If the first element is `True` then the second element maps each label-    --   to an equivalence class identifier, otherwise it is just-    --   `emptyMap`.-    ---graphMatch matchable gs1 gs2 =-    let-        sgs1    = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1-        sgs2    = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2-        ls1     = {- traceShow "ls1 " $ -} graphLabels sgs1-        ls2     = {- traceShow "ls2 " $ -} graphLabels sgs2-        lmap    = {- traceShow "lmap " $ -}-                  newGenerationMap $-                  assignLabelMap ls1 $-                  assignLabelMap ls2 emptyMap-        ec1     = {- traceShow "ec1 " $ -} equivalenceClasses lmap ls1-        ec2     = {- traceShow "ec2 " $ -} equivalenceClasses lmap ls2-        ecpairs = zip (pairSort ec1) (pairSort ec2)-        matchableScoped (ScopedLabel _ l1) (ScopedLabel _ l2) = matchable l1 l2-        match   = graphMatch1 False matchableScoped sgs1 sgs2 lmap ecpairs-    in-        if length ec1 /= length ec2 then (False,emptyMap) else match---- | Recursive graph matching function------  This function assumes that no variable label appears in both graphs.---  (Function `graphMatch`, which calls this, ensures that all variable---  labels are distinct.)------  TODO:------    * replace Equivalence class pair by @(index,[lb],[lb])@ ?------    * possible optimization:  the `graphMapEq` test should be---      needed only if `graphMatch2` has been used to guess a---      mapping;  either: ---          a) supply flag saying guess has been used, or---          b) move test to `graphMatch2` and use different---             test to prevent rechecking for each guess used.-----graphMatch1 :: -  (Label lb) -  => Bool-  -- ^ `True` if a guess has been used before trying this comparison,-  --   `False` if nodes are being matched without any guesswork-  -> (lb -> lb -> Bool)-  -- ^ Test for additional constraints that may prevent the matching-  --  of a supplied pair of nodes.  Returns `True` if the supplied-  --  nodes may be matched.-  -> [Arc lb] -  -- ^ (@gs1@ argument)-  --   first of two lists of arcs (triples) to be compared-  -> [Arc lb]-  -- ^ (@gs2@ argument)-  --   secind of two lists of arcs (triples) to be compared-  -> LabelMap lb-  -- ^ the map so far used to map label values to equivalence class-  --   values-  -> [(EquivalenceClass lb,EquivalenceClass lb)]-  -- ^ (the @ecpairs@ argument) list of pairs of corresponding-  --   equivalence classes of nodes from @gs1@ and @gs2@ that have not-  --   been confirmed in 1:1 correspondence with each other.  Each-  --   pair of equivalence classes contains nodes that must be placed-  --   in 1:1 correspondence with each other.-  ---  -> (Bool,LabelMap lb)-  -- ^ the pair @(match, map)@ where @match@ is @True@ if the supplied-  --   sets of arcs can be matched, in which case @map@ is a-  --   corresponding map from labels to equivalence class identifiers.-  --   When @match@ is @False@, @map@ is the most detailed equivalence-  --   class map obtained before a mismatch was detected or a guess-  --   was required -- this is intended to help identify where the-  --   graph mismatch may be.-graphMatch1 guessed matchable gs1 gs2 lmap ecpairs =-    let-        (secs,mecs) = partition uniqueEc ecpairs-        uniqueEc ( (_,[_])  , (_,[_])  ) = True-        uniqueEc (  _       ,  _       ) = False-        -        doMatch  ( (_,[l1]) , (_,[l2]) ) = labelMatch matchable lmap l1 l2-        doMatch  x = error $ "doMatch failue: " ++ show x -- keep -Wall happy--        ecEqSize ( (_,ls1)  , (_,ls2)  ) = length ls1 == length ls2-        eSize    ( (_,ls1)  , _        ) = length ls1-        ecCompareSize = comparing eSize-        (lmap',mecs',newEc,matchEc) = reclassify gs1 gs2 lmap mecs-        match2 = graphMatch2 matchable gs1 gs2 lmap $ sortBy ecCompareSize mecs-    in-        -- trace ("graphMatch1\nsingle ECs:\n"++show secs++-        --                   "\nmultiple ECs:\n"++show mecs++-        --                   "\n\n") $-        --  if mismatch in singleton equivalence classes, fail-        if not $ all doMatch secs then (False,lmap)-        else-        --  if no multi-member equivalence classes,-        --  check and return label map supplied-        -- trace ("graphMatch1\ngraphMapEq: "++show (graphMapEq lmap gs1 gs2)) $-        if null mecs then (graphMapEq lmap gs1 gs2,lmap)-        else-        --  if size mismatch in equivalence classes, fail-        -- trace ("graphMatch1\nall ecEqSize mecs: "++show (all ecEqSize mecs)) $-        -          --  invoke reclassification, and deal with result-          if not (all ecEqSize mecs) || not matchEc-            then (False, lmap)-            else if newEc-                   then graphMatch1 guessed matchable gs1 gs2 lmap' mecs'-                        --  if guess does not result in a match, return supplied label map-                   else if fst match2 then match2 else (False, lmap)--{--          if not $ all ecEqSize mecs then (False,lmap)-        else-        if not matchEc then (False,lmap)-        else-        if newEc then graphMatch1 guessed matchable gs1 gs2 lmap' mecs'-        else-        if fst match2 then match2 else (False,lmap)--}---- | Auxiliary graph matching function------  This function is called when deterministic decomposition of node---  mapping equivalence classes has run its course.------  It picks a pair of equivalence classes in ecpairs, and arbitrarily matches---  pairs of nodes in those equivalence classes, recursively calling the---  graph matching function until a suitable node mapping is discovered---  (success), or until all such pairs have been tried (failure).------  This function represents a point to which arbitrary choices are backtracked.---  The list comprehension 'glp' represents the alternative choices at the---  point of backtracking------  The selected pair of nodes are placed in a new equivalence class based on their---  original equivalence class value, but with a new NodeVal generation number.--graphMatch2 :: (Label lb) => (lb -> lb -> Bool)-    -> [Arc lb] -> [Arc lb]-    -> LabelMap lb -> [(EquivalenceClass lb,EquivalenceClass lb)]-    -> (Bool,LabelMap lb)-graphMatch2 _         _   _   _    [] = error "graphMatch2 sent an empty list" -- To keep -Wall happy-graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) =-    let-        v1 = snd ev1-        --  Return any equivalence-mapping obtained by matching a pair-        --  of labels in the supplied list, or Nothing.-        try []            = (False,lmap)-        try ((l1,l2):lps) = if isEquiv try1 l1 l2 then try1 else try lps-            where-                try1     = graphMatch1 True matchable gs1 gs2 lmap' ecpairs'-                lmap'    = newLabelMap lmap [(l1,v1),(l2,v1)]-                ecpairs' = ((ev',[l1]),(ev',[l2])):ec':ecpairs-                ev'      = mapLabelIndex lmap' l1-                ec'      = (ecRemoveLabel ec1 l1, ecRemoveLabel ec2 l2)-                -- [[[TODO: replace this: if isJust try ?]]]-                isEquiv (False,_)   _  _  = False-                isEquiv (True,lm) x1 x2 =-                    mapLabelIndex m1 x1 == mapLabelIndex m2 x2-                    where-                        m1 = remapLabels gs1 lm [x1]-                        m2 = remapLabels gs2 lm [x2]-        --  glp is a list of label-pair candidates for matching,-        --  selected from the first label-equivalence class.-        --  NOTE:  final test is call of external matchable function-        glp = [ (l1,l2) | l1 <- ls1 , l2 <- ls2 , matchable l1 l2 ]-    in-        assert (ev1==ev2) -- "GraphMatch2: Equivalence class value mismatch" $-        $ try glp---- this was in Swish.Utils.MiscHelpers along with a simple hash-based function--- based on Sedgewick, Algorithms in C, p233. As we have now moved to using--- Data.Hashable it is not clear whether this is still necessary or sensible.----hashModulus :: Int-hashModulus = 16000001---- | Returns a string representation  of a LabelMap value----showLabelMap :: (Label lb) => LabelMap lb -> String-showLabelMap (LabelMap gn lmap) =-    "LabelMap gen="++ Prelude.show gn ++", map="++-    foldl' (++) "" (map (("\n    "++) . Prelude.show) es)-    where-        es = listLookupMap lmap---- | Map a label to its corresponding label index value in the supplied LabelMap----mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex-mapLabelIndex (LabelMap _ lxms) lb = mapFind nullLabelVal lb lxms---- | Confirm that a given pair of labels are matchable, and are---  mapped to the same value by the supplied label map----labelMatch :: (Label lb)-    =>  (lb -> lb -> Bool) -> LabelMap lb -> lb -> lb -> Bool-labelMatch matchable lmap l1 l2 =-    matchable l1 l2 && (mapLabelIndex lmap l1 == mapLabelIndex lmap l1)---- | Replace selected values in a label map with new values from the supplied---  list of labels and new label index values.  The generation number is---  supplied from the current label map.  The generation number in the---  resulting label map is incremented.----newLabelMap :: (Label lb) => LabelMap lb -> [(lb,Int)] -> LabelMap lb-newLabelMap lmap []       = newGenerationMap lmap-newLabelMap lmap (lv:lvs) = setLabelHash (newLabelMap lmap lvs) lv---- | Replace a label and its associated value in a label map---  with a new value using the supplied hash value and the current---  `LabelMap` generation number.  If the key is not found, then no change---  is made to the label map.--setLabelHash :: (Label lb)-    => LabelMap lb -> (lb,Int) -> LabelMap lb-setLabelHash  (LabelMap g lmap) (lb,lh) =-    LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) )---- | Increment the generation of the label map.------  Returns a new label map identical to the supplied value---  but with an incremented generation number.----newGenerationMap :: (Label lb) => LabelMap lb -> LabelMap lb-newGenerationMap (LabelMap g lvs) = LabelMap (g+1) lvs---- | Scan label list, assigning initial label map values,---  adding new values to the label map supplied.------  Label map values are assigned on the basis of the---  label alone, without regard for it's connectivity in---  the graph.  (cf. `reclassify`).------  All variable node labels are assigned the same initial---  value, as they may be matched with each other.----assignLabelMap :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb-assignLabelMap ns lmap = foldl' (flip assignLabelMap1) lmap ns--assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb-assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs'-    where-        lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab))----  Calculate initial value for a node--initVal :: (Label lb) => lb -> Int-initVal = hashVal 0--hashVal :: (Label lb) => Int -> lb -> Int-hashVal seed lab =-  if labelIsVar lab then seed `combine` 23 else labelHash seed lab-  -- if labelIsVar lab then hash seed "???" else labelHash seed lab--equivalenceClasses :: -  (Label lb) -  => LabelMap lb -- ^ label map-  -> [lb]        -- ^ list of nodes to be reclassified-  -> [EquivalenceClass lb]-  -- ^ the equivalence classes of the supplied labels under the-  --   supplied label map-equivalenceClasses lmap ls =-    pairGroup $ map labelPair ls-    where-        labelPair l = (mapLabelIndex lmap l,l)---- | Reclassify labels------  Examines the supplied label equivalence classes (based on the supplied---  label map), and evaluates new equivalence subclasses based on node---  values and adjacency (for variable nodes) and rehashing---  (for non-variable nodes).------  Note, assumes that all all equivalence classes supplied are---  non-singletons;  i.e. contain more than one label.----reclassify :: -  (Label lb) -  => [Arc lb] -  -- ^ (the @gs1@ argument) the first of two lists of arcs (triples) to perform a-  --   basis for reclassifying the labels in the first equivalence-  --   class in each pair of @ecpairs@.-  -> [Arc lb]-  -- ^ (the @gs2@ argument) the second of two lists of arcs (triples) to perform a-  --   basis for reclassifying the labels in the second equivalence-  --   class in each pair of the @ecpairs@ argument-  -> LabelMap lb -  -- ^ the label map used for classification of the labels in-  --   the supplied equivalence classes-  -> [(EquivalenceClass lb,EquivalenceClass lb)]-  -- ^ (the @ecpairs@ argument) a list of pairs of corresponding equivalence classes of-  --   nodes from @gs1@ and @gs2@ that have not been confirmed-  --   in 1:1 correspondence with each other.-  -> (LabelMap lb,[(EquivalenceClass lb,EquivalenceClass lb)],Bool,Bool)-  -- ^ The output tuple consists of:-  ---  --  1) a revised label map reflecting the reclassification-  ---  --  2) a new list of equivalence class pairs based on the-  --   new node map-  ---  --  3) if the reclassification partitions any of the-  --     supplied equivalence classes then `True`, else `False`-  ---  --  4) if reclassification results in each equivalence class-  --     being split same-sized equivalence classes in the two graphs,-  --     then `True`, otherwise `False`.--reclassify gs1 gs2 lmap@(LabelMap _ lm) ecpairs =-    assert (gen1==gen2) -- "Label map generation mismatch"-      (LabelMap gen1 lm',ecpairs',newPart,matchPart)-    where-        LabelMap gen1 lm1 =-            remapLabels gs1 lmap $ foldl1 (++) $ map (ecLabels . fst) ecpairs-        LabelMap gen2 lm2 =-            remapLabels gs2 lmap $ foldl1 (++) $ map (ecLabels . snd) ecpairs-        lm' = mapReplaceMap lm $ mapMerge lm1 lm2-        -        tmap f (a,b) = (f a, f b)-        -        -- ecGroups :: [([EquivalenceClass lb],[EquivalenceClass lb])]-        ecGroups  = map (tmap remapEc) ecpairs-        ecpairs'  = concatMap (uncurry zip) ecGroups-        newPart   = any pairG1 lenGroups-        matchPart = all pairEq lenGroups-        lenGroups = map (tmap length) ecGroups-        pairEq = uncurry (==)-        pairG1 (p1,p2) = p1 > 1 || p2 > 1-        remapEc = pairGroup . map (newIndex lm') . pairUngroup -        newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab)---- | Calculate a new index value for a supplied list of labels based on the---  supplied label map and adjacency calculations in the supplied graph----remapLabels :: -  (Label lb) -  => [Arc lb] -- ^ arcs used for adjacency calculations when remapping-  -> LabelMap lb -- ^ the current label index values-  -> [lb] -- ^ the graph labels for which new mappings are to be created-  -> LabelMap lb-  -- ^ the updated label map containing recalculated label index values-  -- for the given graph labels. The label map generation number is-  -- incremented by 1.-remapLabels gs lmap@(LabelMap gen _) ls =-    LabelMap gen' (LookupMap newEntries)-    where-        gen'                = gen+1-        newEntries          = [ newEntry (l, (gen',newIndex l)) | l <- ls ]-        newIndex l-            | labelIsVar l  = mapAdjacent l     -- adjacency classifies variable labels-            | otherwise     = hashVal gen l     -- otherwise rehash (to disentangle collisions)-        -- mapAdjacent l       = sum (sigsOver l) `rem` hashModulus-        mapAdjacent l       = sum (sigsOver l) `combine` hashModulus -- is this a sensible replacement for `rem` MH.hashModulus        -        sigsOver l          = select (hasLabel l) gs (arcSignatures lmap gs)---- | Return list of distinct labels used in a graph--graphLabels :: (Label lb) => [Arc lb] -> [lb]-graphLabels = nub . concatMap arcLabels---- | Calculate a signature value for each arc that can be used in constructing an---   adjacency based value for a node.  The adjacancy value for a label is obtained---   by summing the signatures of all statements containing that label.----arcSignatures :: -  (Label lb) -  => LabelMap lb -- ^ the current label index values-  -> [Arc lb] -- ^ calculate signatures for these arcs-  -> [Int] -- ^ the signatures of the arcs-arcSignatures lmap gs =-    map (sigCalc . arcToTriple) gs-    where-        sigCalc (s,p,o)  =-            ( labelVal2 s +-              labelVal2 p * 3 +-              labelVal2 o * 5 )-            `combine` hashModulus-            -- `rem` hashModulus-          -        labelVal         = mapLabelIndex lmap-        labelVal2        = uncurry (*) . labelVal---- | Return a new graph that is supplied graph with every node/arc---  mapped to a new value according to the supplied function.------  Used for testing for graph equivalence under a supplied---  label mapping;  e.g.------  >  if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same)----graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex]-graphMap = map . fmap . mapLabelIndex  -- graphMapStmt---- | Compare a pair of graphs for equivalence under a given mapping---   function.------  This is used to perform the ultimate test that two graphs are---  indeed equivalent:  guesswork in `graphMatch2` means that it is---  occasionally possible to construct a node mapping that generates---  the required singleton equivalence classes, but does not fully---  reflect the topology of the graphs.--graphMapEq :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc lb] -> Bool-graphMapEq lmap gs1 gs2 = graphMap lmap gs1 `equiv` graphMap lmap gs2----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,166 +0,0 @@-{-# LANGUAGE FlexibleInstances, MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor, DeriveFoldable, DeriveTraversable #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  GraphMem---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  DeriveFunctor, DeriveFoldable, DeriveTraversable, FlexibleInstances, MultiParamTypeClasses------  This module defines a simple memory-based graph instance.----------------------------------------------------------------------------------------------------------------------------------------------------- Simple labelled directed graph value---------------------------------------------------------------module Swish.RDF.GraphMem-    ( GraphMem(..)-    , setArcs, getArcs, add, delete, extract, labels-    , LabelMem(..)-    , labelIsVar, labelHash-      -- For debug/test:-    , matchGraphMem-    ) where--import Swish.RDF.GraphClass-import Swish.RDF.GraphMatch--- import Swish.Utils.MiscHelpers (hash)--import Data.Hashable (Hashable(..), combine)-import Data.Ord (comparing)--import qualified Data.Foldable as F-import qualified Data.Traversable as T---- | Memory-based graph type --data GraphMem lb = GraphMem { arcs :: [Arc lb] }-                   deriving (Functor, F.Foldable, T.Traversable)-                            -instance (Label lb) => LDGraph GraphMem lb where-    getArcs      = arcs-    setArcs as g = g { arcs=as }-    -- gmap f g = g { arcs = (map $ fmap f) (arcs g) }-    containedIn = error "containedIn for LDGraph GraphMem lb is undefined!" -- TODO: should there be one defined?--instance (Label lb) => Eq (GraphMem lb) where-    (==) = graphEq--instance (Label lb) => Show (GraphMem lb) where-    show = graphShow--graphShow   :: (Label lb) => GraphMem lb -> String-graphShow g = "Graph:" ++ foldr ((++) . ("\n    " ++) . show) "" (arcs g)--{--toGraph :: (Label lb) => [Arc lb] -> GraphMem lb-toGraph as = GraphMem { arcs=nub as }--}---- |  Return Boolean graph equality--graphEq :: (Label lb) => GraphMem lb -> GraphMem lb -> Bool-graphEq g1 g2 = fst ( matchGraphMem g1 g2 )---- | GraphMem matching function accepting GraphMem value and returning---  node map if successful----matchGraphMem ::-  (Label lb)-  => GraphMem lb -  -> GraphMem lb-  -> (Bool,LabelMap (ScopedLabel lb))-  -- ^ if the first element is @True@ then the second value is a label-  --   map that maps each label to an equivalence-class identifier,-  --   otherwise `emptyMap`.-  ---matchGraphMem g1 g2 =-    let-        gs1     = arcs g1-        gs2     = arcs g2-        matchable l1 l2-            | labelIsVar l1 && labelIsVar l2 = True-            | labelIsVar l1 || labelIsVar l2 = False-            | otherwise                      = l1 == l2-    in-        graphMatch matchable gs1 gs2--{---- |  Return bijection between two graphs, or empty list-graphBiject :: (Label lb) => GraphMem lb -> GraphMem lb -> [(lb,lb)]-graphBiject g1 g2 = if null lmap then [] else zip (sortedls g1) (sortedls g2)-    where-        lmap        = graphMatch g1 g2-        sortedls g  = map snd $-                      (sortBy indexComp) $-                      equivalenceClasses (graphLabels $ arcs g) lmap-        classComp ec1 ec2 = indexComp (classIndexVal ec1) (classIndexVal ec2)-        indexComp (g1,v1) (g2,v2)-            | g1 == g2  = compare v1 v2-            | otherwise = compare g1 g2--}---- |  Minimal graph label value - for testing--data LabelMem-    = LF String-    | LV String--instance Hashable LabelMem where-  hash (LF l) = 1 `hashWithSalt` l-  hash (LV l) = 2 `hashWithSalt` l-  hashWithSalt salt (LF l) = salt `combine` 1 `hashWithSalt` l-  hashWithSalt salt (LV l) = salt `combine` 2 `hashWithSalt` l--instance Label LabelMem where-    labelIsVar (LV _)   = True-    labelIsVar _        = False-    getLocal   (LV loc) = loc-    getLocal   lab      = error "getLocal of non-variable label: " ++ show lab-    makeLabel           = LV -    -- labelHash  seed lb  = hash seed (show lb)-    labelHash = hashWithSalt--instance Eq LabelMem where-    (LF l1) == (LF l2)  = l1 == l2-    (LV l1) == (LV l2)  = l1 == l2-    _ == _              = False--instance Show LabelMem where-    show (LF l1)        = '!' : l1-    show (LV l2)        = '?' : l2--instance Ord LabelMem where-    compare = comparing show ----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,570 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  GraphPartition---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module contains functions for partitioning a graph into subgraphs---  that rooted from different subject nodes.--------------------------------------------------------------------------------------module Swish.RDF.GraphPartition-    ( PartitionedGraph(..), getArcs, getPartitions-    , GraphPartition(..), node, toArcs-    , partitionGraph, comparePartitions-    , partitionShowP-    )-where--import Swish.RDF.GraphClass-    ( Label(..)-    , Arc(..), arcSubj, arcObj, -    -- , hasLabel, arcLabels-    )--import Data.List (foldl', partition)--import Control.Monad.State-    ( MonadState(..), State, evalState )--import Data.Maybe (isJust, fromJust, mapMaybe)------------------------------------------------------------------  Data type for a partitioned graph----------------------------------------------------------------- |Representation of a graph as a collection of (possibly nested)---  partitions.  Each node in the graph appears at least once as the---  root value of a 'GraphPartition' value:------  * Nodes that are the subject of at least one statement appear as---    the first value of exactly one 'PartSub' constructor, and may---    also appear in any number of 'PartObj' constructors.------  * Nodes appearing only as objects of statements appear only in---    'PartObj' constructors.--data PartitionedGraph lb = PartitionedGraph [GraphPartition lb]-    deriving (Eq,Show)--getArcs :: PartitionedGraph lb -> [Arc lb]-getArcs (PartitionedGraph ps) = concatMap toArcs ps--getPartitions :: PartitionedGraph lb -> [GraphPartition lb]-getPartitions (PartitionedGraph ps) = ps---- QUS: is the list always guaranteed to be non-empty in PartSub?-data GraphPartition lb-    = PartObj lb-    | PartSub lb [(lb,GraphPartition lb)]--node :: GraphPartition lb -> lb-node (PartObj ob)   = ob-node (PartSub sb _) = sb--toArcs :: GraphPartition lb -> [Arc lb]-toArcs (PartObj _)      = []-toArcs (PartSub sb prs) = concatMap toArcs1 prs-    where-        toArcs1 (pr,ob) = Arc sb pr (node ob) : toArcs ob--instance (Label lb) => Eq (GraphPartition lb) where-    (==) = partitionEq--instance (Label lb) => Show (GraphPartition lb) where-    show = partitionShow----  Equality is based on total structural equivalence.---  This is not the same as graph equality.-partitionEq :: (Label lb) => GraphPartition lb -> GraphPartition lb -> Bool-partitionEq (PartObj o1)    (PartObj o2)    = o1 == o2-partitionEq (PartSub s1 p1) (PartSub s2 p2) = s1 == s2 && p1 == p2-partitionEq  _               _              = False--partitionShow :: (Label lb) => GraphPartition lb -> String-partitionShow (PartObj ob)          = show ob-partitionShow (PartSub sb [])       = "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible?-partitionShow (PartSub sb (pr:prs)) =-    "("++ show sb ++ " " ++ showpr pr ++ concatMap ((" ; "++).showpr) prs ++ ")"-    where-        showpr (a,b) = show a ++ " " ++ show b-  -partitionShowP :: (Label lb) => String -> GraphPartition lb -> String-partitionShowP _    (PartObj ob)          = show ob-partitionShowP pref (PartSub sb [])       = pref ++ "(" ++ show sb ++ ")" -- just to make -Wall happy, is this sensible?-partitionShowP pref (PartSub sb (pr:prs)) =-    pref++"("++ show sb ++ " " ++ showpr pr ++ concatMap (((pref++"  ; ")++).showpr) prs ++ ")"-    where-        showpr (a,b) = show a ++ " " ++ partitionShowP (pref++"  ") b-----------------------------------------------------------------  Creating partitioned graphs------------------------------------------------------------------- |Turning a partitioned graph into a flat graph is easy.---  The interesting challenge is to turn a flat graph into a---  partitioned graph that is more useful for certain purposes.---  Currently, I'm interested in:---        ---  (1) isolating differences between graphs---        ---  (2) pretty-printing graphs------  For (1), the goal is to separate subgraphs that are known---  to be equivalent from subgraphs that are known to be different,---  such that: ------  * different sub-graphs are minimized,------  * different---  sub-graphs are placed into 1:1 correspondence (possibly with null---  subgraphs), and------  * only deterministic matching decisions are made.------  For (2), the goal is to decide when a subgraph is to be treated---  as nested in another partition, or treated as a new top-level partition.---  If a subgraph is referenced by exactly one graph partition, it should---  be nested in that partition, otherwise it should be a new top-level---  partition.------  Strategy.  Examining just subject and object nodes:------  * all non-blank subject nodes are the root of a top-level partition------  * blank subject nodes that are not the object of exactly one statement---     are the root of a top-level partition.------  * blank nodes referenced as the object of exactly 1 statement---     of an existing partition are the root of a sub-partition of the---     refering partition.------  * what remain are circular chains of blank nodes not referenced---     elsewhere:  for each such chain, pick a root node arbitrarily.----partitionGraph :: (Label lb) => [Arc lb] -> PartitionedGraph lb-partitionGraph arcs =-    makePartitions fixs topv1 intv1-    where-        (fixs,vars)  = partition isNonVar $ collect arcSubj arcs-        vars1        = collectMore arcObj arcs vars-        (intv,topv)  = partition objOnce vars1-        intv1        = map stripObj intv-        topv1        = map stripObj topv-        isNonVar     = not . labelIsVar . fst-        objOnce      = isSingle . snd . snd-        isSingle [_] = True-        isSingle _   = False-        stripObj (k,(s,_)) = (k,s)---- Local state type for partitioning function-type MakePartitionState lb = ([(lb,[Arc lb])],[(lb,[Arc lb])],[(lb,[Arc lb])])--makePartitions :: (Eq lb) =>-    [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> [(lb,[Arc lb])] -> PartitionedGraph lb-makePartitions fixs topv intv =-    PartitionedGraph $ evalState (makePartitions1 []) (fixs,topv,intv)---- Use a state monad to keep track of arcs that have been incorporated into--- the resulting list of graph partitions.  The collections of arcs used to--- generate the list of partitions are supplied as theinitial state of the--- monad (see call of evalState above).----makePartitions1 :: (Eq lb) =>-    [(lb,[Arc lb])] -> State (MakePartitionState lb) [GraphPartition lb]-makePartitions1 [] =-    do  { s <- pickNextSubject-        ; if null s then return [] else makePartitions1 s-        }-makePartitions1 (sub:subs) =-    do  { ph <- makePartitions2 sub-        ; pt <- makePartitions1 subs-        ; return $ ph++pt-        }--makePartitions2 :: (Eq lb) =>-    (lb,[Arc lb]) -> State (MakePartitionState lb) [GraphPartition lb]-makePartitions2 subs =-    do  { (part,moresubs) <- makeStatements subs-        ; moreparts <- if not (null moresubs) then-            makePartitions1 moresubs-          else-            return []-        ; return $ part:moreparts-        }--makeStatements :: (Eq lb) =>-    (lb,[Arc lb])-    -> State (MakePartitionState lb) (GraphPartition lb,[(lb,[Arc lb])])-makeStatements (sub,stmts) =-    do  { propmore <- mapM makeStatement stmts-        ; let (props,moresubs) = unzip propmore-        ; return (PartSub sub props,concat moresubs)-        }--makeStatement :: (Eq lb) =>-    Arc lb-    -> State (MakePartitionState lb) ((lb,GraphPartition lb),[(lb,[Arc lb])])-makeStatement (Arc _ prop obj) =-    do  { intobj <- pickIntSubject obj-        ; (gpobj,moresubs) <- if null intobj-          then-            do  { ms <- pickVarSubject obj-                ; return (PartObj obj,ms)-                }-          else-            makeStatements (head intobj)-        ; return ((prop,gpobj),moresubs)-        }--pickNextSubject :: State (MakePartitionState lb) [(lb,[Arc lb])]-pickNextSubject =-    do  { (a1,a2,a3) <- get-        ; let (s,st) = case (a1,a2,a3) of-                (s1h:s1t,s2,s3) -> ([s1h],(s1t,s2,s3))-                ([],s2h:s2t,s3) -> ([s2h],([],s2t,s3))-                ([],[],s3h:s3t) -> ([s3h],([],[],s3t))-                ([],[],[])      -> ([]   ,([],[],[] ))-        ; put st-        ; return s-        }--pickIntSubject :: (Eq lb) =>-    lb -> State (MakePartitionState lb) [(lb,[Arc lb])]-pickIntSubject sub =-    do  { (s1,s2,s3) <- get-        ; let varsub = removeBy (\x->(x==).fst) sub s3-        ; if isJust varsub then-            do  { let (vs,s3new) = fromJust varsub-                ; put (s1,s2,s3new)-                ; return [vs]-                }-          else-            return []-        }--pickVarSubject :: (Eq lb) =>-    lb -> State (MakePartitionState lb) [(lb,[Arc lb])]-pickVarSubject sub =-    do  { (s1,s2,s3) <- get-        ; let varsub = removeBy (\x->(x==).fst) sub s2-        ; if isJust varsub then-            do  { let (vs,s2new) = fromJust varsub-                ; put (s1,s2new,s3)-                ; return [vs]-                }-          else-            return []-        }-----------------------------------------------------------------  Other useful functions-------------------------------------------------------------------  Create a list of pairs of corresponding Partitions that---  are unequal--comparePartitions :: (Label lb) =>-    PartitionedGraph lb -> PartitionedGraph lb-    -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]-comparePartitions (PartitionedGraph gp1) (PartitionedGraph gp2) =-    comparePartitions1 (reverse gp1) (reverse gp2)--comparePartitions1 :: (Label lb) =>-    [GraphPartition lb] -> [GraphPartition lb]-    -> [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]-comparePartitions1 pg1 pg2 =-        ds ++ [ (Just r1p,Nothing) | r1p<-r1 ]-           ++ [ (Nothing,Just r2p) | r2p<-r2 ]-    where-        (ds,r1,r2) = listDifferences comparePartitions2 pg1 pg2----  Compare two graph partitions, with three possible outcomes:---    Nothing    -> no match---    Just []    -> total match---    Just [...] -> partial match, with mismatched sub-partitions listed.------  A partial match occurs when the leading nodes are non-variable and---  equal, but something else in the partition does not match.------  A complete match can be achieved with variable nodes that have---  different labels----comparePartitions2 :: (Label lb) =>-    GraphPartition lb -> GraphPartition lb-    -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]-comparePartitions2 (PartObj l1) (PartObj l2) =-    if matchNodes l1 l2 then Just [] else Nothing-comparePartitions2 pg1@(PartSub l1 p1s) pg2@(PartSub l2 p2s) =-    if match then comp1 else Nothing-    where-        comp1  = case comparePartitions3 l1 l2 p1s p2s of-                    Nothing -> if matchVar then Nothing-                                           else Just [(Just pg1,Just pg2)]-                    Just [] -> Just []-                    Just ps -> {- if matchVar then Nothing else -} Just ps-        matchVar = labelIsVar l1 && labelIsVar l2-        match    = matchVar || l1 == l2-comparePartitions2 pg1 pg2 =-    if not (labelIsVar l1) && l1 == l2-        then Just [(Just pg1,Just pg2)]-        else Nothing-    where-        l1 = node pg1-        l2 = node pg2--comparePartitions3 :: (Label lb) =>-    lb -> lb -> [(lb,GraphPartition lb)] -> [(lb,GraphPartition lb)]-    -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]-comparePartitions3 l1 l2 s1s s2s = Just $-        ds ++ [ (Just (PartSub l1 [r1p]),Nothing) | r1p<-r1 ]-           ++ [ (Nothing,Just (PartSub l2 [r2p])) | r2p<-r2 ]-    where-        (ds,r1,r2) = listDifferences (comparePartitions4 l1 l2) s1s s2s--comparePartitions4 :: (Label lb) =>-    lb -> lb -> (lb,GraphPartition lb) -> (lb,GraphPartition lb)-    -> Maybe [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]-comparePartitions4 _ _ (p1,o1) (p2,o2) =-    if matchNodes p1 p2 then comp1 else Nothing-    where-        comp1   = case comparePartitions2 o1 o2 of-                    Nothing -> Just [(Just o1,Just o2)]-                    ds      -> ds--matchNodes :: (Label lb) => lb -> lb -> Bool-matchNodes l1 l2-    | labelIsVar l1 = labelIsVar l2-    | otherwise     = l1 == l2------------------------------------------------------------------  Helpers----------------------------------------------------------------- |Collect a list of items by some comparison of a selected component---  or other derived value.------  cmp     a comparison function that determines if a pair of values---          should be grouped together---  sel     a function that selects a value from any item------  Example:    collect fst [(1,'a'),(2,'b'),(1,'c')] =---                  [(1,[(1,'a'),(1,'c')]),(2,[(2,'b')])]----collect :: (Eq b) => (a->b) -> [a] -> [(b,[a])]-collect = collectBy (==)--collectBy :: (b->b->Bool) -> (a->b) -> [a] -> [(b,[a])]-collectBy cmp sel = map reverseCollection . collectBy1 cmp sel []--collectBy1 :: (b->b->Bool) -> (a->b) -> [(b,[a])] -> [a] -> [(b,[a])]-collectBy1 _   _   sofar []     = sofar-collectBy1 cmp sel sofar (a:as) =-    collectBy1 cmp sel (collectBy2 cmp sel a sofar) as--collectBy2 :: (b->b->Bool) -> (a->b) -> a -> [(b,[a])] -> [(b,[a])]-collectBy2 _   sel a [] = [(sel a,[a])]-collectBy2 cmp sel a (col@(k,as):cols)-    | cmp ka k  = (k,a:as):cols-    | otherwise = col:collectBy2 cmp sel a cols-    where-        ka = sel a--reverseCollection :: (b,[a]) -> (b,[a])-reverseCollection (k,as) = (k,reverse as)--{---- Example/test:-testCollect1 :: [(Int, [(Int, Char)])]-testCollect1 = collect fst [(1,'a'),(2,'b'),(1,'c'),(1,'d'),(2,'d'),(3,'d')]--testCollect2 :: Bool-testCollect2 = testCollect1-                == [ (1,[(1,'a'),(1,'c'),(1,'d')])-                   , (2,[(2,'b'),(2,'d')])-                   , (3,[(3,'d')])-                   ]--}---- |Add new values to an existing list of collections.---  The list of collections is not extended, but each collection is---  augmented with a further list of values from the supplied list,---  each of which are related to the existing collection in some way.------  NOTE: the basic pattern of 'collect' and 'collectMore' is similar,---  and might be generalized into a common set of core functions.----collectMore :: (Eq b) => (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))]-collectMore = collectMoreBy (==)--collectMoreBy ::-    (b->b->Bool) -> (a->b) -> [a] -> [(b,c)] -> [(b,(c,[a]))]-collectMoreBy cmp sel as cols =-    map reverseMoreCollection $-    collectMoreBy1 cmp sel as (map (\ (b,cs) -> (b,(cs,[])) ) cols)--collectMoreBy1 ::-    (b->b->Bool) -> (a->b) -> [a] -> [(b,(c,[a]))] -> [(b,(c,[a]))]-collectMoreBy1 _   _   []     cols = cols-collectMoreBy1 cmp sel (a:as) cols =-    collectMoreBy1 cmp sel as (collectMoreBy2 cmp sel a cols)--collectMoreBy2 ::-    (b->b->Bool) -> (a->b) -> a -> [(b,(c,[a]))] -> [(b,(c,[a]))]-collectMoreBy2 _   _   _ [] = []-collectMoreBy2 cmp sel a (col@(k,(b,as)):cols)-    | cmp (sel a) k = (k,(b,a:as)):cols-    | otherwise     = col:collectMoreBy2 cmp sel a cols--reverseMoreCollection :: (b,(c,[a])) -> (b,(c,[a]))-reverseMoreCollection (k,(c,as)) = (k,(c,reverse as))--{---- Example/test:-testCollectMore1 =-    collectMore snd [(111,1),(112,1),(211,2),(311,3),(411,4)] testCollect1--testCollectMore2 :: Bool-testCollectMore2 = testCollectMore1-                == [ (1,([(1,'a'),(1,'c'),(1,'d')],[(111,1),(112,1)]))-                   , (2,([(2,'b'),(2,'d')],[(211,2)]))-                   , (3,([(3,'d')],[(311,3)]))-                   ]--}---- |Remove supplied element from a list using the supplied test---  function, and return Just the element remoived and the---  remaining list, or Nothing if no element was matched for removal.----{--remove :: (Eq a) => a -> [a] -> Maybe (a,[a])-remove = removeBy (==)--testRemove1  = remove 3 [1,2,3,4,5]-testRemove2  = testRemove1 == Just (3,[1,2,4,5])-testRemove3  = remove 3 [1,2,4,5]-testRemove4  = testRemove3 == Nothing-testRemove5  = remove 5 [1,2,4,5]-testRemove6  = testRemove5 == Just (5,[1,2,4])-testRemove7  = remove 1 [1,2,4]-testRemove8  = testRemove7 == Just (1,[2,4])-testRemove9  = remove 2 [2]-testRemove10 = testRemove9 == Just (2,[])---}--removeBy :: (b->a->Bool) -> b -> [a] -> Maybe (a,[a])-removeBy cmp a0 as = removeBy1 cmp a0 as []--removeBy1 :: (b->a->Bool) -> b -> [a] -> [a] -> Maybe (a,[a])-removeBy1 _   _  []     _     = Nothing-removeBy1 cmp a0 (a:as) sofar-    | cmp a0 a  = Just (a,reverseTo sofar as)-    | otherwise = removeBy1 cmp a0 as (a:sofar)---- |Reverse first argument, prepending the result to the second argument----reverseTo :: [a] -> [a] -> [a]-reverseTo front back = foldl' (flip (:)) back front---- |Remove each element from a list, returning a list of pairs,---  each of which is the element removed and the list remaining.----removeEach :: [a] -> [(a,[a])]-removeEach [] = []-removeEach (a:as) = (a,as):[ (a1,a:a1s) | (a1,a1s) <- removeEach as ]--{--testRemoveEach1 = removeEach [1,2,3,4,5]-testRemoveEach2 = testRemoveEach1 ==-    [ (1,[2,3,4,5])-    , (2,[1,3,4,5])-    , (3,[1,2,4,5])-    , (4,[1,2,3,5])-    , (5,[1,2,3,4])-    ]--}---- |List differences between the members of two lists, where corresponding---  elements may appear at arbitrary locations in the corresponding lists.------  Elements are compared using the function 'cmp', which returns:---  * Nothing  if the elements are completely unrelated---  * Just []  if the elements are identical---  * Just ds  if the elements are related but not identical, in which case---             ds is a list of values describing differences between them.------  Returns (ds,u1,u2), where:---  ds is null if the related elements from each list are identical,---  otherwise is a list of differences between the related elements.---  u1 is a list of elements in a1 not related to elements in a2.---  u2 is a list of elements in a2 not related to elements in a1.----listDifferences :: (a->a->Maybe [d]) -> [a] -> [a] -> ([d],[a],[a])-listDifferences _   []       a2s = ([],[],a2s)-listDifferences cmp (a1:a1t) a2s =-    case mcomp of-        Nothing       -> morediffs [] [a1] a1t a2s-        Just (ds,a2t) -> morediffs ds []   a1t a2t-    where-        -- mcomp finds identical match, if there is one, or-        -- the first element in a2s related to a1, or Nothing-        -- [choose was listToMaybe,-        --  but that didn't handle repeated properties well]-        mcomp = choose $ mapMaybe maybeResult comps-        comps = [ (cmp a1 a2,a2t) | (a2,a2t) <- removeEach a2s ]-        maybeResult (Nothing,_)   = Nothing-        maybeResult (Just ds,a2t) = Just (ds,a2t)-        morediffs xds xa1h xa1t xa2t  = (xds++xds1,xa1h++xa1r,xa2r)-            where-                (xds1,xa1r,xa2r) = listDifferences cmp xa1t xa2t-        choose  []       = Nothing-        choose  ds@(d:_) = choose1 d ds-        choose1 _ (d@([],_):_)  = Just d-        choose1 d []            = Just d-        choose1 d (_:ds)        = choose1 d ds--{--testcmp (l1,h1) (l2,h2)-    | (l1 >= h2) || (l2 >= h1) = Nothing-    | (l1 == l2) && (h1 == h2) = Just []-    | otherwise                = Just [((l1,h1),(l2,h2))]--testdiff1 = listDifferences testcmp-                [(12,15),(1,2),(3,4),(5,8),(10,11)]-                [(10,11),(0,1),(3,4),(6,9),(13,15)]-testdiff2 = testdiff1 == ([((12,15),(13,15)),((5,8),(6,9))],[(1,2)],[(0,1)])--}----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,69 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  MapXsdInteger---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  OverloadedStrings------  This module defines the datatytpe mapping and relation values---  used for RDF dataype xsd:integer--------------------------------------------------------------------------------------module Swish.RDF.MapXsdInteger (mapXsdInteger) where--import Swish.RDF.Datatype (DatatypeMap(..))--import qualified Data.Text as T-import qualified Data.Text.Read as T-----------------------------------------------------------------  Implementation of DatatypeMap for xsd:integer----------------------------------------------------------------- |mapXsdInteger contains functions that perform lexical-to-value---  and value-to-canonical-lexical mappings for xsd:integer values----mapXsdInteger :: DatatypeMap Integer-mapXsdInteger = DatatypeMap-    { -- mapL2V :: T.Text -> Maybe Integer-      mapL2V = \txt -> case T.signed T.decimal txt of-         Right (val, "") -> Just val-         _ -> Nothing-         -      -- mapV2L :: Integer -> Maybe T.Text-      -- TODO: for now convert via String as issues with text-format-      --       (inability to use with ghci)   -    , mapV2L = Just . T.pack . show-    }----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,941 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  N3Formatter---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  OverloadedStrings------  This Module implements a Notation 3 formatter (see [1], [2] and [3]),---  for an RDFGraph value.------ REFERENCES:------ (1) <http://www.w3.org/TeamSubmission/2008/SUBM-n3-20080114/>---     Notation3 (N3): A readable RDF syntax,---     W3C Team Submission 14 January 2008------ (2) <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:------   * Initial prefix list to include nested formulae;---      then don't need to update prefix list for these.------   * correct output of strings containing unsupported escape---     characters (such as @\\q@)------   * more flexible terminator generation for formatted formulae---     (for inline blank nodes.)--------------------------------------------------------------------------------------{--TODO:--The code used to determine whether a blank node can be written-using the "[]" short form could probably take advantage of the-GraphPartition module.---}--module Swish.RDF.N3Formatter-    ( NodeGenLookupMap-    , formatGraphAsText-    , formatGraphAsLazyText-    , formatGraphAsBuilder-    , formatGraphIndent  -    , formatGraphDiag-    )-where--import Swish.RDF.RDFGraph (-  RDFGraph, RDFLabel(..),-  NamespaceMap, RevNamespaceMap,-  emptyNamespaceMap,-  FormulaMap, emptyFormulaMap,-  getArcs, labels,-  setNamespaces, getNamespaces,-  getFormulae,-  emptyRDFGraph-  , quote-  , quoteT-  , resRdfFirst, resRdfRest, resRdfNil-  )--import Swish.RDF.Vocabulary (-  isLang, langTag, -  rdfType,-  rdfNil,-  owlSameAs, logImplies-  , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble -  )--import Swish.RDF.GraphClass (Arc(..))--import Swish.Utils.LookupMap-    ( LookupEntryClass(..)-    , LookupMap, emptyLookupMap, reverseLookupMap-    , listLookupMap-    , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge-    )--import Swish.Utils.Namespace (ScopedName, getScopeLocal, getScopeURI)--import Data.Char (isDigit)--import Data.List (foldl', delete, groupBy, partition, sort, intersperse)--import Data.Monoid (Monoid(..))-import Control.Monad (liftM, when)-import Control.Monad.State (State, modify, get, put, runState)---- it strikes me that using Lazy Text here is likely to be--- wrong; however I have done no profiling to back this--- assumption up!--import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as B---- temporary conversion-quoteB :: Bool -> String -> B.Builder-quoteB f v = B.fromString $ quote f v---------------------------------------------------------------------------  Graph formatting state monad-----------------------------------------------------------------------------  The graph to be formatted is carried as part of the formatting---  state, so that decisions about what needs to be formatted can---  themselves be based upon and reflected in the state (e.g. if a---  decision is made to include a blank node inline, it can be removed---  from the graph state that remains to be formatted).--type SubjTree lb = [(lb,PredTree lb)]-type PredTree lb = [(lb,[lb])]--data N3FormatterState = N3FS-    { indent    :: B.Builder-    , lineBreak :: Bool-    , graph     :: RDFGraph-    , subjs     :: SubjTree RDFLabel-    , props     :: PredTree RDFLabel   -- for last subject selected-    , objs      :: [RDFLabel]          -- for last property selected-    , formAvail :: FormulaMap RDFLabel-    , formQueue :: [(RDFLabel,RDFGraph)]-    , nodeGenSt :: NodeGenState-    , bNodesCheck   :: [RDFLabel]      -- these bNodes are not to be converted to '[..]' format-    , traceBuf  :: [String]-    }-             -type Formatter a = State N3FormatterState a--emptyN3FS :: NodeGenState -> N3FormatterState-emptyN3FS ngs = N3FS-    { indent    = "\n"-    , lineBreak = False-    , graph     = emptyRDFGraph-    , subjs     = []-    , props     = []-    , objs      = []-    , formAvail = emptyFormulaMap-    , formQueue = []-    , nodeGenSt = ngs-    , bNodesCheck   = []-    , traceBuf  = []-    }----  | Node name generation state information that carries through---  and is updated by nested formulae-type NodeGenLookupMap = LookupMap (RDFLabel,Int)--data NodeGenState = Ngs-    { prefixes  :: NamespaceMap-    , nodeMap   :: NodeGenLookupMap-    , nodeGen   :: Int-    }--emptyNgs :: NodeGenState-emptyNgs = Ngs-    { prefixes  = emptyLookupMap-    , nodeMap   = emptyLookupMap-    , nodeGen   = 0-    }---- simple context for label creation--- (may be a temporary solution to the problem---  of label creation)----data LabelContext = SubjContext | PredContext | ObjContext-                    deriving (Eq, Show)--getIndent :: Formatter B.Builder-getIndent = indent `liftM` get--setIndent :: B.Builder -> Formatter ()-setIndent ind = modify $ \st -> st { indent = ind }--getLineBreak :: Formatter Bool-getLineBreak = lineBreak `liftM` get--setLineBreak :: Bool -> Formatter ()-setLineBreak brk = modify $ \st -> st { lineBreak = brk }--getNgs :: Formatter NodeGenState-getNgs = nodeGenSt `liftM` get--setNgs :: NodeGenState -> Formatter ()-setNgs ngs = modify $ \st -> st { nodeGenSt = ngs }--getPrefixes :: Formatter NamespaceMap-getPrefixes = prefixes `liftM` getNgs--getSubjs :: Formatter (SubjTree RDFLabel)-getSubjs = subjs `liftM` get--setSubjs :: SubjTree RDFLabel -> Formatter ()-setSubjs sl = modify $ \st -> st { subjs = sl }--getProps :: Formatter (PredTree RDFLabel)-getProps = props `liftM` get--setProps :: PredTree RDFLabel -> Formatter ()-setProps ps = modify $ \st -> st { props = ps }--{--getObjs :: Formatter ([RDFLabel])-getObjs = objs `liftM` get--setObjs :: [RDFLabel] -> Formatter ()-setObjs os = do-  st <- get-  put $ st { objs = os }--}--getBnodesCheck :: Formatter [RDFLabel]-getBnodesCheck = bNodesCheck `liftM` get--{--addTrace :: String -> Formatter ()-addTrace tr = do-  st <- get-  put $ st { traceBuf = tr : traceBuf st }--}-  -queueFormula :: RDFLabel -> Formatter ()-queueFormula fn = do-  st <- get-  let fa = formAvail st-      newState fv = st {-                      formAvail = mapDelete fa fn,-                      formQueue = (fn,fv) : formQueue st-                    }-  case mapFindMaybe fn fa of-    Nothing -> return ()-    Just v -> put (newState v) >> return ()--{--Return the graph associated with the label and delete it-from the store, if there is an association, otherwise-return Nothing.--}-extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph)-extractFormula fn = do-  st <- get-  let fa = formAvail st-      newState = st { formAvail=mapDelete fa fn }-  case mapFindMaybe fn fa of-    Nothing -> return Nothing-    Just fv -> put newState >> return (Just fv)--{--moreFormulae :: Formatter Bool-moreFormulae =  do-  st <- get-  return $ not $ null (formQueue st)--nextFormula :: Formatter (RDFLabel,RDFGraph)-nextFormula = do-  st <- get-  let (nf : fq) = formQueue st-  put $ st { formQueue = fq }-  return nf---}---- list has a length of 1-len1 :: [a] -> Bool-len1 (_:[]) = True-len1 _ = False--{-|-Given a set of statements and a label, return the details of the-RDF collection referred to by label, or Nothing.--For label to be considered as representing a collection we require the-following conditions to hold (this is only to support the-serialisation using the '(..)' syntax and does not make any statement-about semantics of the statements with regard to RDF Collections):--  - there must be one rdf_first and one rdfRest statement-  - there must be no other predicates for the label---} -getCollection ::          -  SubjTree RDFLabel -- ^ statements organized by subject-  -> RDFLabel -- ^ does this label represent a list?-  -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel])-     -- ^ the statements with the elements removed; the-     -- content elements of the collection (the objects of the rdf:first-     -- predicate) and the nodes that represent the spine of the-     -- collection (in reverse order, unlike the actual contents which are in-     -- order).-getCollection subjList lbl = go subjList lbl ([],[]) -    where-      go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss)-                      | otherwise = do-        (pList1, sl') <- removeItem sl l-        (pFirst, pList2) <- removeItem pList1 resRdfFirst-        (pNext, pList3) <- removeItem pList2 resRdfRest--        -- QUS: could I include these checks implicitly in the pattern matches above?-        -- ie instrad of (pFirst, pos1) <- ..-        -- have ([content], pos1) <- ...-        -- ?-        if and [len1 pFirst, len1 pNext, null pList3]-          then go sl' (head pNext) (head pFirst : cs, l : ss)-          else Nothing--{--TODO:--Should we change the preds/objs entries as well?---}-extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel])-extractList lctxt ln = do-  osubjs <- getSubjs-  oprops <- getProps-  let mlst = getCollection osubjs' ln--      -- we only want to send in rdf:first/rdf:rest here-      fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops--      osubjs' =-          case lctxt of-            SubjContext -> (ln, fprops) : osubjs-            _ -> osubjs --      -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n"-  -- addTrace tr-  case mlst of-    -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext-    Just (sl,ls,_) -> do-              setSubjs sl-              when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops-              return (Just ls)--    Nothing -> return Nothing-  -{-|-Removes the first occurrence of the item from the-association list, returning it's contents and the rest-of the list, if it exists.--}-removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)])-removeItem os x =-  let (as, bs) = break (\a -> fst a == x) os-  in case bs of-    ((_,b):bbs) -> Just (b, as ++ bbs)-    [] -> Nothing---------------------------------------------------------------------------  Define a top-level formatter function:-------------------------------------------------------------------------formatGraphAsText :: RDFGraph -> T.Text-formatGraphAsText = L.toStrict . formatGraphAsLazyText--formatGraphAsLazyText :: RDFGraph -> L.Text-formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder-  -formatGraphAsBuilder :: RDFGraph -> B.Builder-formatGraphAsBuilder = formatGraphIndent "\n" True-  -formatGraphIndent :: B.Builder -> Bool -> RDFGraph -> B.Builder-formatGraphIndent indnt flag gr = -  let (res, _, _, _) = formatGraphDiag indnt flag gr-  in res-  --- | Format graph and return additional information-formatGraphDiag :: -  B.Builder  -- ^ indentation-  -> Bool    -- ^ are prefixes to be generated?-  -> RDFGraph -  -> (B.Builder, NodeGenLookupMap, Int, [String])-formatGraphDiag indnt flag gr = -  let fg  = formatGraph indnt " .\n" False flag gr-      ngs = emptyNgs {-        prefixes = emptyLookupMap,-        nodeGen  = findMaxBnode gr-        }-             -      (out, fgs) = runState fg (emptyN3FS ngs)-      ogs        = nodeGenSt fgs-  -  in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs)---------------------------------------------------------------------------  Formatting as a monad-based computation-------------------------------------------------------------------------formatGraph :: -  B.Builder     -- indentation string-  -> B.Builder  -- text to be placed after final statement-  -> Bool       -- True if a line break is to be inserted at the start-  -> Bool       -- True if prefix strings are to be generated-  -> RDFGraph   -- graph to convert-  -> Formatter B.Builder-formatGraph ind end dobreak dopref gr = do-  setIndent ind-  setLineBreak dobreak-  setGraph gr-  -  fp <- if dopref-        then formatPrefixes (getNamespaces gr)-        else return mempty-  more <- moreSubjects-  if more-    then do-      fr <- formatSubjects-      return $ mconcat [fp, fr, end]-    else return fp--formatPrefixes :: NamespaceMap -> Formatter B.Builder-formatPrefixes pmap = do-  let mls = map (pref . keyVal) (listLookupMap pmap)-  ls <- sequence mls-  return $ mconcat ls-    where-      pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."]-      pref (_,u)      = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."]--{--NOTE:-I expect there to be confusion below where I need to-convert from Text to Builder--}--formatSubjects :: Formatter B.Builder-formatSubjects = do-  sb    <- nextSubject-  sbstr <- formatLabel SubjContext sb-  -  flagP <- moreProperties-  if flagP-    then do-      prstr <- formatProperties sb sbstr-      flagS <- moreSubjects-      if flagS-        then do-          fr <- formatSubjects-          return $ mconcat [prstr, " .", fr]-        else return prstr-           -    else do-      txt <- nextLine sbstr-    -      flagS <- moreSubjects-      if flagS-        then do-          fr <- formatSubjects-          return $ mconcat [txt, " .", fr]-        else return txt--{--TODO: now we are throwing a Builder around it is awkward to-get the length of the text to calculate the indentation--So--  a) change the indentation scheme-  b) pass around text instead of builder--mkIndent :: L.Text -> L.Text-mkIndent inVal = L.replicate (L.length inVal) " "--}--hackIndent :: B.Builder-hackIndent = "    "--formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder-formatProperties sb sbstr = do-  pr <- nextProperty sb-  prstr <- formatLabel PredContext pr-  obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr]-  more  <- moreProperties-  let sbindent = hackIndent -- mkIndent sbstr-  if more-    then do-      fr <- formatProperties sb sbindent-      nl <- nextLine $ obstr `mappend` " ;"-      return $ nl `mappend` fr-    else nextLine obstr--formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder-formatObjects sb pr prstr = do-  ob    <- nextObject sb pr-  obstr <- formatLabel ObjContext ob-  more  <- moreObjects-  if more-    then do-      let prindent = hackIndent -- mkIndent prstr-      fr <- formatObjects sb pr prindent-      nl <- nextLine $ mconcat [prstr, " ", obstr, ","]-      return $ nl `mappend` fr-    else return $ mconcat [prstr, " ", obstr]--insertFormula :: RDFGraph -> Formatter B.Builder-insertFormula gr = do-  ngs0  <- getNgs-  ind   <- getIndent-  let grm = formatGraph (ind `mappend` "    ") "" True False-            (setNamespaces emptyNamespaceMap gr)--      (f3str, fgs') = runState grm (emptyN3FS ngs0)--  setNgs (nodeGenSt fgs')-  f4str <- nextLine " } "-  return $ mconcat [" { ",f3str, f4str]--{--Add a list inline. We are given the labels that constitute-the list, in order, so just need to display them surrounded-by ().--}-insertList :: [RDFLabel] -> Formatter B.Builder-insertList [] = return "()" -- not convinced this can happen-insertList xs = do-  ls <- mapM (formatLabel ObjContext) xs-  return $ mconcat ("( " : intersperse " " ls) `mappend` " )"-    -{--Add a blank node inline.--}--insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder-insertBnode SubjContext lbl = do-  flag <- moreProperties-  txt <- if flag-         then (`mappend` "\n") `liftM` formatProperties lbl ""-         else return ""--  -- TODO: handle indentation?-  return $ mconcat ["[", txt, "]"]--insertBnode _ lbl = do-  ost <- get-  let osubjs = subjs ost-      oprops = props ost-      oobjs  = objs  ost--      (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs--      rprops = case bsubj of-                 [(_,rs)] -> rs-                 _ -> []--      -- we essentially want to create a new subgraph-      -- for this node but it's not as simple as that since-      -- we could have something like-      --     :a :b [ :foo [ :bar "xx" ] ]-      -- so we still need to carry around the whole graph-      ---      nst = ost { subjs = rsubjs,-                  props = rprops,-                  objs  = []-                }--  put nst-  flag <- moreProperties-  txt <- if flag-         then (`mappend` "\n") `liftM` formatProperties lbl ""-         else return ""--  -- TODO: how do we restore the original set up?-  --       I can't believe the following is sufficient-  ---  nst' <- get-  let slist  = map fst $ subjs nst'-      nsubjs = filter (\(l,_) -> l `elem` slist) osubjs--  put $ nst' { subjs = nsubjs,-                       props = oprops, -                       objs  = oobjs-             }--  -- TODO: handle indentation?-  return $ mconcat ["[", txt, "]"]-  --------------------------------------------------------------------------  Formatting helpers-------------------------------------------------------------------------setGraph :: RDFGraph -> Formatter ()-setGraph gr = do-  st <- get--  let ngs0 = nodeGenSt st-      pre' = mapMerge (prefixes ngs0) (getNamespaces gr)-      ngs' = ngs0 { prefixes = pre' }-      arcs = sortArcs $ getArcs gr-      nst  = st  { graph     = gr-                 , subjs     = arcTree arcs-                 , props     = []-                 , objs      = []-                 , formAvail = getFormulae gr-                 , nodeGenSt = ngs'-                 , bNodesCheck   = countBnodes arcs-                 }--  put nst--hasMore :: (N3FormatterState -> [b]) -> Formatter Bool-hasMore lens = (not . null . lens) `liftM` get--moreSubjects :: Formatter Bool-moreSubjects = hasMore subjs--- moreSubjects = (not . null . subjs) `liftM` get--moreProperties :: Formatter Bool-moreProperties = hasMore props--- moreProperties = (not . null . props) `liftM` get--moreObjects :: Formatter Bool-moreObjects = hasMore objs--- moreObjects = (not . null . objs) `liftM` get--nextSubject :: Formatter RDFLabel-nextSubject = do-  st <- get--  let sb:sbs = subjs st-      nst = st  { subjs = sbs-                , props = snd sb-                , objs  = []-                }--  put nst-  return $ fst sb--nextProperty :: RDFLabel -> Formatter RDFLabel-nextProperty _ = do-  st <- get--  let pr:prs = props st-      nst = st  { props = prs-                 , objs  = snd pr-                 }--  put nst-  return $ fst pr--nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel-nextObject _ _ = do-  st <- get--  let ob:obs = objs st-      nst = st { objs = obs }--  put nst-  return ob--nextLine :: B.Builder -> Formatter B.Builder-nextLine str = do-  ind <- getIndent-  brk <- getLineBreak-  if brk-    then return $ ind `mappend` str-    else do-      --  After first line, always insert line break-      setLineBreak True-      return str----  Format a label---  Most labels are simply displayed as provided, but there are a---  number of wrinkles to take care of here:---  (a) blank nodes automatically allocated on input, with node---      identifiers of the form of a digit string nnn.  These are---      not syntactically valid, and are reassigned node identifiers---      of the form _nnn, where nnn is chosen so that is does not---      clash with any other identifier in the graph.---  (b) URI nodes:  if possible, replace URI with qname,---      else display as <uri>---  (c) formula nodes (containing graphs).---  (d) use the "special-case" formats for integer/float/double---      literals.      ---      ---  [[[TODO:]]]---  (d) generate multi-line literals when appropriate------ This is being updated to produce inline formula, lists and     --- blank nodes. The code is not efficient.-----specialTable :: [(ScopedName, String)]-specialTable = -  [ (rdfType, "a")-  , (owlSameAs, "=")-  , (logImplies, "=>")-  , (rdfNil, "()")-  ]--formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder-{--formatLabel lab@(Blank (_:_)) = do-  name <- formatNodeId lab-  queueFormula lab-  return name--}--{--The "[..]" conversion is done last, after "()" and "{}" checks.--}-formatLabel lctxt lab@(Blank (_:_)) = do-  mlst <- extractList lctxt lab-  case mlst of-    Just lst -> insertList lst-    Nothing -> do-              mfml <- extractFormula lab-              case mfml of-                Just fml -> insertFormula fml-                Nothing -> do-                          nb1 <- getBnodesCheck-                          if lctxt /= PredContext && lab `notElem` nb1-                            then insertBnode lctxt lab-                            else formatNodeId lab--formatLabel _ lab@(Res sn) = -  case lookup sn specialTable of-    Just txt -> return $ quoteB True txt -- TODO: do we need to quote?-    Nothing -> do-      pr <- getPrefixes-      let nsuri  = getScopeURI sn-          local  = getScopeLocal sn-          premap = reverseLookupMap pr :: RevNamespaceMap-          prefix = mapFindMaybe nsuri premap-          -          name   = case prefix of-                     Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames-                     _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"]-      -      {--          name   = case prefix of-                     Just p -> quoteB True (p ++ ":" ++ local) -- TODO: what are quoting rules for QNames-                     _ -> mconcat ["<", quoteB True (nsuri++local), ">"]-      -}-          -      queueFormula lab-      return name---- The canonical notation for xsd:double in XSD, with an upper-case E,--- does not match the syntax used in N3, so we need to convert here.     --- Rather than converting back to a Double and then displaying that       --- we just convert E to e for now.      ---      -formatLabel _ (Lit lit (Just dtype)) -  | dtype == xsdDouble = return $ B.fromText $ T.toLower lit-  | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit-  | otherwise = return $ quoteText lit `mappend` formatAnnotation dtype-formatLabel _ (Lit lit Nothing) = return $ quoteText lit--formatLabel _ lab = return $ B.fromString $ show lab---- the annotation for a literal (ie type or language)-formatAnnotation :: ScopedName -> B.Builder-formatAnnotation a  | isLang a  = "@" `mappend` B.fromText (langTag a)-                    | otherwise = "^^" `mappend` showScopedName a--{--We have to decide whether to use " or """ to quote-the string.--There is also no need to restrict the string to the-ASCII character set; this could be an option but we-can also leave Unicode as is (or at least convert to UTF-8).--If we use """ to surround the string then we protect the-last character if it is a " (assuming it isn't protected).--}--quoteText :: T.Text -> B.Builder-quoteText txt = -  let st = T.unpack txt -- TODO: fix-      qst = quoteB (n==1) st-      n = if '\n' `elem` st || '"' `elem` st then 3 else 1-      qch = B.fromString (replicate n '"')-  in mconcat [qch, qst, qch]--formatNodeId :: RDFLabel -> Formatter B.Builder-formatNodeId lab@(Blank (lnc:_)) =-    if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab-formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall--mapBlankNode :: RDFLabel -> Formatter B.Builder-mapBlankNode lab = do-  ngs <- getNgs-  let cmap = nodeMap ngs-      cval = nodeGen ngs-  nv <- case mapFind 0 lab cmap of-    0 -> do -      let nval = succ cval-          nmap = mapAdd cmap (lab, nval)-      setNgs $ ngs { nodeGen = nval, nodeMap = nmap }-      return nval-      -    n -> return n-  -  -- TODO: is this what we want?-  return $ "_:swish" `mappend` B.fromString (show nv)---- TODO: need to be a bit more clever with this than we did in NTriples---       not sure the following counts as clever enough ...---  -showScopedName :: ScopedName -> B.Builder-{--showScopedName (ScopedName n l) = -  let uri = nsURI n ++ l-  in quote uri--}-showScopedName = quoteB True . show---------------------------------------------------------------------------  Graph-related helper functions-------------------------------------------------------------------------newtype SortedArcs lb = SA [Arc lb]--sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb-sortArcs = SA . sort----  Rearrange a list of arcs into a tree of pairs which group together---  all statements for a single subject, and similarly for multiple---  objects of a common predicate.----arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb-arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as-    where-        spopair (Arc s p o) = (s,(p,o))--{--arcTree as = map spopair $ sort as-    where-        spopair (Arc s p o) = (s,[(p,[o])])--}----  Rearrange a list of pairs so that multiple occurrences of the first---  are commoned up, and the supplied function is applied to each sublist---  with common first elements to obtain the corresponding second value-commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)]-commonFstEq f ps =-    [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ]-    where-        fstEq (f1,_) (f2,_) = f1 == f2--{---- Diagnostic code for checking arcTree logic:-testArcTree = (arcTree testArcTree1) == testArcTree2-testArcTree1 =-    [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112"-    ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122"-    ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212"-    ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222"-    ]-testArcTree2 =-    [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])])-    ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])])-    ]--}---findMaxBnode :: RDFGraph -> Int-findMaxBnode = maximum . map getAutoBnodeIndex . labels--getAutoBnodeIndex   :: RDFLabel -> Int-getAutoBnodeIndex (Blank ('_':lns)) = res where-    -- cf. prelude definition of read s ...-    res = case [x | (x,t) <- reads lns, ("","") <- lex t] of-            [x] -> x-            _   -> 0-getAutoBnodeIndex _                   = 0--{--Find all blank nodes that occur-  - any number of times as a subject-  - 0 or 1 times as an object--Such nodes can be output using the "[..]" syntax. To make it simpler-to check we actually store those nodes that can not be expanded.--Note that we do not try and expand any bNode that is used in-a predicate position.--Should probably be using the SubjTree RDFLabel structure but this-is easier for now.---}--countBnodes :: SortedArcs RDFLabel -> [RDFLabel]-countBnodes (SA as) = snd (foldl' ctr ([],[]) as)-    where-      -- first element of tuple are those blank nodes only seen once,-      -- second element those blank nodes seen multiple times-      ---      inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b-                                  | l `elem` b1s = (delete l b1s, l:bms)-                                  | otherwise    = (l:b1s, bms)-      inc b _ = b--      -- if the bNode appears as a predicate we instantly add it to the-      -- list of nodes not to expand, even if only used once-      incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b-                                   | l `elem` b1s = (delete l b1s, l:bms)-           			   | otherwise    = (b1s, l:bms)-      incP b _ = b--      ctr orig (Arc _ p o) = inc (incP orig p) o----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,1145 +0,0 @@-{-# LANGUAGE OverloadedStrings #-} -- only used in 'fromMaybe "" mbase' line of parseN3-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  N3Parser---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  OverloadedStrings------  This Module implements a Notation 3 parser (see [1], [2], [3]), returning a---  new 'RDFGraph' consisting of triples and namespace information parsed from---  the supplied N3 input string, or an error indication.------ REFERENCES:------ 1 <http://www.w3.org/TeamSubmission/2008/SUBM-n3-20080114/>---     Notation3 (N3): A readable RDF syntax,---     W3C Team Submission 14 January 2008------ 2 <http://www.w3.org/DesignIssues/Notation3.html>---     Tim Berners-Lee's design issues series notes and description------ 3 <http://www.w3.org/2000/10/swap/Primer.html>---     Notation 3 Primer by Sean Palmer------ NOTES:------  UTF-8 handling is not really tested.------  No performance testing has been applied.------  Not all N3 grammar elements are supported, including:------    - @\@forSome@ (we read it in but ignore the arguments)------    - @\@forAll@  (this causes a parse error)------    - formulae are lightly tested------    - string support is incomplete (e.g. unrecognized escape characters---      such as @\\q@ are probably handled incorrectly)--------------------------------------------------------------------------------------module Swish.RDF.N3Parser-    ( ParseResult-    , parseN3      -    , parseN3fromText      -    , parseAnyfromText-    , parseTextFromText, parseAltFromText-    , parseNameFromText -- , parsePrefixFromText-    , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText-    -    -- * Exports for parsers that embed Notation3 in a bigger syntax-    , N3Parser, N3State(..), SpecialMap-    -    , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions-    , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct      -    , quickVariable -- was varid      -    , lexUriRef       -    , document, subgraph                                                   -    , newBlankNode-    )-where--import Swish.RDF.RDFGraph-    ( RDFGraph, RDFLabel(..)-    , ToRDFLabel(..)-    , NamespaceMap-    , LookupFormula(..) -    , addArc -    , setFormula-    , setNamespaces-    , emptyRDFGraph-    )--import Swish.RDF.GraphClass (arc)--import Swish.Utils.LookupMap-    ( LookupMap(..)-    , LookupEntryClass(..)-    , mapFind, mapFindMaybe, mapReplaceOrAdd, mapAdd, mapReplace )--import Swish.Utils.Namespace-    ( Namespace, makeNamespace-    , ScopedName-    , getScopeNamespace-    , getScopedNameURI-    , getScopeNamespace-    , makeURIScopedName-    , makeQNameScopedName-    , makeNSScopedName-    , nullScopedName-    )--import Swish.Utils.QName (QName)--import Swish.RDF.Vocabulary-    ( langName-    , rdfType-    , rdfFirst, rdfRest, rdfNil-    , owlSameAs, logImplies-    , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble-    )--import Swish.RDF.RDFParser-    ( SpecialMap-    , ParseResult-    , runParserWithError-    -- , mapPrefix-    , prefixTable-    , specialTable-    , ignore-    , notFollowedBy-    , endBy-    , sepEndBy-    , manyTill-    , noneOf-    , char-    , ichar-    , string-    , stringT-    , symbol-    , lexeme-    , whiteSpace-    , mkTypedLit-    , hex4  -    , hex8  -    , appendURIs-    )--import Control.Applicative-import Control.Monad (forM_, foldM)--import Network.URI (URI(..), parseURIReference)--import Data.Char (isSpace, isDigit, ord) -import Data.Maybe (fromMaybe, fromJust)--import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import Text.ParserCombinators.Poly.StateText--------------------------------------------------------------------------- Define parser state and helper functions--------------------------------------------------------------------------- | N3 parser state-data N3State = N3State-        { graphState :: RDFGraph            -- Graph under construction-        , thisNode   :: RDFLabel            -- current context node (aka 'this')-        , prefixUris :: NamespaceMap        -- namespace prefix mapping table-        , syntaxUris :: SpecialMap          -- special name mapping table-        , nodeGen    :: Int                 -- blank node id generator-        , keywordsList :: [T.Text]          -- contents of the @keywords statement-        , allowLocalNames :: Bool           -- True if @keywords used so that bare names are QNames in default namespace-        }---- | Functions to update N3State vector (use with stUpdate)--setPrefix :: Maybe T.Text -> URI -> N3State -> N3State-setPrefix pre uri st =  st { prefixUris=p' }-    where-        p' = mapReplaceOrAdd (makeNamespace pre uri) (prefixUris st)---- | Set name for special syntax element-setSName :: String -> ScopedName -> N3State -> N3State-setSName nam snam st =  st { syntaxUris=s' }-    where-        s' = mapReplaceOrAdd (nam,snam) (syntaxUris st)--setSUri :: String -> URI -> N3State -> N3State-setSUri nam = setSName nam . makeURIScopedName---- | Set the list of tokens that can be used without needing the leading --- \@ symbol.-setKeywordsList :: [T.Text] -> N3State -> N3State-setKeywordsList ks st = st { keywordsList = ks, allowLocalNames = True }----  Functions to access state:---- | Get name for special syntax element, default null-getSName :: N3State -> String -> ScopedName-getSName st nam =  mapFind nullScopedName nam (syntaxUris st)--getSUri :: N3State -> String -> URI-getSUri st nam = getScopedNameURI $ getSName st nam----  Map prefix to URI-getPrefixURI :: N3State -> Maybe T.Text -> Maybe URI-getPrefixURI st pre = mapFindMaybe pre (prefixUris st)--getKeywordsList :: N3State -> [T.Text]-getKeywordsList = keywordsList--getAllowLocalNames :: N3State -> Bool-getAllowLocalNames = allowLocalNames----  Return function to update graph in N3 parser state,---  using the supplied function of a graph----updateGraph :: (RDFGraph -> RDFGraph) -> N3State -> N3State-updateGraph f s = s { graphState = f (graphState s) }---------------------------------------------------------------------------  Define top-level parser function:---  accepts a string and returns a graph or error-------------------------------------------------------------------------type N3Parser a = Parser N3State a---- | Parse a string as N3 (with no real base URI).--- --- See 'parseN3' if you need to provide a base URI.----parseN3fromText ::-  L.Text -- ^ input in N3 format.-  -> ParseResult-parseN3fromText = flip parseN3 Nothing---- | Parse a string with an optional base URI.---            --- See also 'parseN3fromString'.            ----parseN3 ::-  L.Text -- ^ input in N3 format.-  -> Maybe QName -- ^ optional base URI-  -> ParseResult-parseN3 txt mbase = parseAnyfromText document mbase txt--{---- useful for testing-test :: String -> RDFGraph-test = either error id . parseAnyfromString document Nothing--}--hashURI :: URI-hashURI = fromJust $ parseURIReference "#"--emptyState :: -  Maybe QName  -- ^ starting base for the graph-  -> N3State-emptyState mbase = -  let pmap   = LookupMap [makeNamespace Nothing hashURI]-      muri   = fmap (makeQNameScopedName Nothing) mbase-      smap   = LookupMap $ specialTable muri-  in N3State-     { graphState = emptyRDFGraph-     , thisNode   = NoNode-     , prefixUris = pmap-     , syntaxUris = smap-     , nodeGen    = 0-     , keywordsList = ["a", "is", "of", "true", "false"] -- not 100% sure about true/false here-     , allowLocalNames = False-     }----- TODO: change from QName to URI for the base?---- | Function to supply initial context and parse supplied term.----parseAnyfromText :: N3Parser a      -- ^ parser to apply-                    -> Maybe QName  -- ^ base URI of the input, or @Nothing@ to use default base value-                    -> L.Text       -- ^ input to be parsed-                    -> Either String a-parseAnyfromText parser mbase = runParserWithError parser (emptyState mbase)--newBlankNode :: N3Parser RDFLabel-newBlankNode = do-  n <- stQuery (succ . nodeGen)-  stUpdate $ \s -> s { nodeGen = n }-  return $ Blank (show n)-  ---  Test functions for selected element parsing---- TODO: remove these-  -parseTextFromText :: String -> L.Text -> Either String String-parseTextFromText s =-    parseAnyfromText (string s) Nothing--parseAltFromText :: String -> String -> L.Text -> Either String String-parseAltFromText s1 s2 =-    parseAnyfromText (string s1 <|> string s2) Nothing--parseNameFromText :: L.Text -> Either String String-parseNameFromText =-    parseAnyfromText n3NameStr Nothing--{--This has been made tricky by the attempt to remove the default list-of prefixes from the starting point of a N3 parse and the subsequent-attempt to add every new namespace we come across to the parser state.--So we add in the original default namespaces for testing, since-this routine is really for testing.--}--addTestPrefixes :: N3Parser ()-addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map--{--parsePrefixFromText :: L.Text -> Either String URI-parsePrefixFromText =-    parseAnyfromText p Nothing-      where-        p = do-          addTestPrefixes-          pref <- n3Name-          st   <- stGet-          case getPrefixURI st (Just pref) of-            Just uri -> return uri-            _ -> fail $ "Undefined prefix: '" ++ pref ++ "'"--}--parseAbsURIrefFromText :: L.Text -> Either String URI-parseAbsURIrefFromText =-    parseAnyfromText explicitURI Nothing--parseLexURIrefFromText :: L.Text -> Either String URI-parseLexURIrefFromText =-    parseAnyfromText lexUriRef Nothing--parseURIref2FromText :: L.Text -> Either String ScopedName-parseURIref2FromText = -    parseAnyfromText (addTestPrefixes *> n3symbol) Nothing---------------------------------------------------------------------------  Syntax productions--------------------------------------------------------------------------- helper routines--comma, semiColon , fullStop :: N3Parser ()-comma = ignore $ symbol ","-semiColon = ignore $ symbol ";"-fullStop = ignore $ symbol "."---- a specialization of bracket/between -br :: String -> String -> N3Parser a -> N3Parser a-br lsym rsym = bracket (symbol lsym) (symbol rsym)---- to make porting from parsec to polyparse easier-between :: Parser s lbr -> Parser s rbr -> Parser s a -> Parser s a-between = bracket---- The @ character is optional if the keyword is in the--- keyword list----atSign :: T.Text -> N3Parser ()-atSign s = do-  st <- stGet-  -  let p = ichar '@'-  -  if s `elem` getKeywordsList st-    then ignore $ optional p-    else p-         -atWord :: T.Text -> N3Parser T.Text-atWord s = do-  atSign s-  -  -- TODO: does it really make sense to add the not-followed-by-a-colon rule here?-  -- apply to both cases even though should only really be necessary-  -- when the at sign is not given-  ---  lexeme $ stringT s *> notFollowedBy (== ':')-  return s--{--Since operatorLabel can be used to add a label with an -unknown namespace, we need to ensure that the namespace-is added if not known. If the namespace prefix is already-in use then it is over-written (rather than add a new-prefix for the label).--TODO:-  - could we use the reverse lookupmap functionality to-    find if the given namespace URI is in the namespace-    list? If it is, use it's key otherwise do a-    mapReplaceOrAdd for the input namespace.-    --}-operatorLabel :: ScopedName -> N3Parser RDFLabel-operatorLabel snam = do-  st <- stGet-  let sns = getScopeNamespace snam-      opmap = prefixUris st-      pkey = entryKey sns-      pval = entryVal sns-      -      rval = Res snam-      -  -- the lookup and the replacement could be fused-  case mapFindMaybe pkey opmap of-    Just val | val == pval -> return rval-             | otherwise   -> do-               stUpdate $ \s -> s { prefixUris = mapReplace opmap sns }-               return rval-    -    _ -> do-      stUpdate $ \s -> s { prefixUris = mapAdd opmap sns }-      return rval-        -{--Add statement to graph in N3 parser state.--To support literals that are written directly/implicitly - i.e.  as-true/false/1/1.0/1.0e23 - rather than a string with an explicit-datatype we need to special case handling of the object label for-literals. Is this actually needed? The N3 Formatter now doesn't-display the xsd: datatypes on output, but there may be issues with-other formats (e.g RDF/XML once it is supported).---}--type AddStatement = RDFLabel -> N3Parser ()--addStatement :: RDFLabel -> RDFLabel -> AddStatement-addStatement s p o@(Lit _ (Just dtype)) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do -  ost <- stGet-  let stmt = arc s p o-      oldp = prefixUris ost-      ogs = graphState ost-      newp = mapReplaceOrAdd (getScopeNamespace dtype) oldp-  stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs }-addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) ))--addStatementRev :: RDFLabel -> RDFLabel -> AddStatement-addStatementRev o p s = addStatement s p o--{--A number of productions require a name, which starts with--[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]--and then has--[\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*--we encode this as the n3Name production--}--isaz, is09, isaz09 :: Char -> Bool-isaz c = c >= 'a' && c <= 'z'-is09 c = c >= '0' && c <= '9'-isaz09 c = isaz c || is09 c--match :: (Ord a) => a -> [(a,a)] -> Bool-match v = any (\(l,h) -> v >= l && v <= h)--startChar :: Char -> Bool-startChar c = let i = ord c-              in c == '_' || -                 match c [('A', 'Z'), ('a', 'z')] ||-                 match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x02ff), -                          (0x0370, 0x037d), -                          (0x037f, 0x1fff), (0x200c, 0x200d), -                          (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), -                          (0xf900, 0xfdcf), (0xfdf0, 0xfffd), -                          (0x00010000, 0x000effff)]           -  -inBody :: Char -> Bool-inBody c = let i = ord c-           in c `elem` "-_" || i == 0x007 ||-              match c [('0', '9'), ('A', 'Z'), ('a', 'z')] ||-              match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x037d), -                       (0x037f, 0x1fff), (0x200c, 0x200d), (0x203f, 0x2040), -                       (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), -                       (0xf900, 0xfdcf), (0xfdf0, 0xfffd), -                       (0x00010000, 0x000effff)]           ---- should this be strict or lazy text?-n3Name :: N3Parser T.Text-n3Name = T.cons <$> n3Init <*> n3Body-  where-    n3Init = satisfy startChar-    n3Body = L.toStrict <$> manySatisfy inBody---n3NameStr :: N3Parser String-n3NameStr = T.unpack <$> n3Name--{--quickvariable ::=	\?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*--}---- TODO: is mapping to Var correct?-quickVariable :: N3Parser RDFLabel-quickVariable = char '?' *> (Var <$> n3NameStr) --{--string ::=	("""[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*""")|("[^"\\]*(?:\\.[^"\\]*)*")--or--string ::= tripleQuoted | singleQUoted---}--n3string :: N3Parser T.Text-n3string = tripleQuoted <|> singleQuoted --{--singleQuoted ::=  "[^"\\]*(?:\\.[^"\\]*)*"--asciiChars :: String-asciiChars = map chr [0x20..0x7e]--asciiCharsN3 :: String-asciiCharsN3 = filter (`notElem` "\\\"") asciiChars---}--digit :: N3Parser Char-digit = satisfy isDigit--{--This is very similar to NTriples accept that also allow the escaping of '-even though it is not required.--The Python rules allow \N{name}, where name is the Unicode name. It's-not clear whether we need to support this too, so for now we do not.---}-protectedChar :: N3Parser Char-protectedChar =-  (char 't' *> return '\t')-  <|> (char 'n' *> return '\n')-  <|> (char 'r' *> return '\r')-  <|> (char '"' *> return '"')-  <|> (char '\'' *> return '\'')-  <|> (char '\\' *> return '\\')-  <|> (char 'u' *> hex4)-  <|> (char 'U' *> hex8)---- Accept an escape character or any character as long as it isn't--- a new-line or quote. Unrecognized escape sequences should therefore--- be left alone by this. ----n3Character :: N3Parser Char-n3Character = -  (char '\\' *> (protectedChar <|> return '\\'))-  <|> noneOf "\"\n"-      -{--      <|> (oneOf asciiCharsN3 <?> "ASCII character")-              -- TODO: bodyChar and asciiCharsN3 overlap-      <|> (oneOf bodyChar <?> "Unicode character")--}              --sQuot :: N3Parser Char-sQuot = char '"'--{--TODO: there must be a better way of building up the Text--}--singleQuoted :: N3Parser T.Text-singleQuoted = fmap T.pack (bracket sQuot sQuot $ many n3Character)-    -{--tripleQUoted ::=	"""[^"\\]*(?:(?:\\.|"(?!""))[^"\\]*)*"""--}-tripleQuoted :: N3Parser T.Text-tripleQuoted = tQuot *> fmap T.pack (manyTill (n3Character <|> sQuot <|> char '\n') tQuot)-  where-    -- tQuot = try (count 3 sQuot)-    tQuot = exactly 3 sQuot--getDefaultPrefix :: N3Parser Namespace-getDefaultPrefix = do-  s <- stGet-  case getPrefixURI s Nothing of-    Just uri -> return $ makeNamespace Nothing uri-    _ -> fail "No default prefix defined; how unexpected!"--addBase :: URI -> N3Parser ()-addBase = stUpdate . setSUri "base" --addPrefix :: Maybe T.Text -> URI -> N3Parser ()-addPrefix p = stUpdate . setPrefix p --{-|-Update the set of keywords that can be given without-an \@ sign.--}-updateKeywordsList :: [T.Text] -> N3Parser ()-updateKeywordsList = stUpdate . setKeywordsList--{--document ::=		|	statements_optional EOF--}--document :: N3Parser RDFGraph-document = mkGr <$> (whiteSpace *> statementsOptional *> eof *> stGet)-  where-    mkGr s = setNamespaces (prefixUris s) (graphState s)--{--statements_optional ::=		|	statement  "."  statements_optional-		|	void---}--statementsOptional :: N3Parser ()-statementsOptional = ignore $ endBy (lexeme statement) fullStop-    -{--statement ::=		|	declaration-		|	existential-		|	simpleStatement-		|	universal---}--statement :: N3Parser ()-statement =-  declaration-  <|> existential-  <|> universal-  <|> simpleStatement-  -- having an error here leads to less informative errors in general, it seems-  -- <?> "statement (existential or universal quantification or a simple statement)"-  -{--declaration ::=		|	 "@base"  explicituri-		|	 "@keywords"  barename_csl-		|	 "@prefix"  prefix explicituri--}---- TODO: do we need the try statements here? atWord would need to have a try on '@'--- (if applicable) which should mean being able to get rid of try----declaration :: N3Parser ()-declaration = oneOf [-  atWord "base" >> explicitURI >>= addBase,-  atWord "keywords" >> bareNameCsl >>= updateKeywordsList,-  atWord "prefix" *> getPrefix-  ]--  {--  (try (atWord "base") >> explicitURI >>= addBase)-  <|>-  (try (atWord "keywords") >> bareNameCsl >>= updateKeywordsList)-  <|>-  (try (atWord "prefix") *> getPrefix)-  -}-  -getPrefix :: N3Parser ()  -getPrefix = do-  p <- lexeme prefix-  u <- explicitURI-  addPrefix p u--{--explicituri ::=	<[^>]*>--Note: white space is to be ignored within <>--}--explicitURI :: N3Parser URI-explicitURI = do-  let lb = char '<'-      rb = char '>'-  -  -- TODO: do the whitespace definitions match?-  ustr <- between lb rb $ many (satisfy (/= '>'))-  let uclean = filter (not . isSpace) ustr-  -  case parseURIReference uclean of-    Nothing -> fail $ "Unable to convert <" ++ uclean ++ "> to a URI"-    Just uref -> do-      s <- stGet-      let base = getSUri s "base"-      either fail return $ appendURIs base uref-      --- production from the old parser; used in SwishScript-lexUriRef :: N3Parser URI-lexUriRef = lexeme explicitURI--{--barename ::=	[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*-barename_csl ::=		|	barename barename_csl_tail-		|	void-barename_csl_tail ::=		|	 ","  barename barename_csl_tail-		|	void--}--bareNameCsl :: N3Parser [T.Text]-bareNameCsl = sepBy (lexeme bareName) comma--bareName :: N3Parser T.Text-bareName = n3Name --{--prefix ::=	([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?:--}--prefix :: N3Parser (Maybe T.Text)-prefix = optional (lexeme n3Name) <* char ':'-         --{--symbol ::=		|	explicituri-		|	qname-symbol_csl ::=		|	symbol symbol_csl_tail-		|	void-symbol_csl_tail ::=		|	 ","  symbol symbol_csl_tail-		|	void---}--n3symbol :: N3Parser ScopedName-n3symbol = -  (makeURIScopedName <$> explicitURI)-  <|> qname--symbolCsl :: N3Parser [ScopedName]-symbolCsl = sepBy (lexeme n3symbol) comma--{--qname ::=	(([A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*)?:)?[A-Z_a-z#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x02ff#x0370-#x037d#x037f-#x1fff#x200c-#x200d#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff][\-0-9A-Z_a-z#x00b7#x00c0-#x00d6#x00d8-#x00f6#x00f8-#x037d#x037f-#x1fff#x200c-#x200d#x203f-#x2040#x2070-#x218f#x2c00-#x2fef#x3001-#xd7ff#xf900-#xfdcf#xfdf0-#xfffd#x00010000-#x000effff]*--TODO:-  Note that, for now, we explicitly handle blank nodes-  (of the form _:name) direcly in pathItem'.-  This is not a good idea since qname' is used elsewhere-  and so shouldn't we do the same thing there too?--}--qname :: N3Parser ScopedName-qname =-  fmap (uncurry makeNSScopedName) (char ':' >> g)-  <|> (n3Name >>= fullOrLocalQName)-    where-      g = (,) <$> getDefaultPrefix <*> (n3Name <|> return "")-               -fullOrLocalQName :: T.Text -> N3Parser ScopedName-fullOrLocalQName name = -  (char ':' *> fullQName name)-  <|> localQName name-  -fullQName :: T.Text -> N3Parser ScopedName-fullQName name = makeNSScopedName <$> findPrefix name <*> (n3Name <|> pure "")-  -findPrefix :: T.Text -> N3Parser Namespace-findPrefix pre = do-  st <- stGet-  case mapFindMaybe (Just pre) (prefixUris st) of-    Just uri -> return $ makeNamespace (Just pre) uri-    Nothing  -> failBad $ "Prefix '" ++ T.unpack pre ++ ":' not bound."-  -localQName :: T.Text -> N3Parser ScopedName-localQName name = do-  st <- stGet-  if getAllowLocalNames st-    then let g = (,) <$> getDefaultPrefix <*> pure name-         in uncurry makeNSScopedName <$> g-            -    else fail ("Invalid 'bare' word: " ++ T.unpack name)-- TODO: not ideal error message; can we handle this case differently?--{--existential ::=		|	 "@forSome"  symbol_csl--For now we just read in the symbols and ignore them,-since we do not mark blank nodes as existentially quantified-(we assume this is the case).--TODO: fix this?--}--existential :: N3Parser ()--- existential = try (atWord "forSome") *> symbolCsl >> return ()-existential = atWord "forSome" *> symbolCsl *> pure ()--{--simpleStatement ::=		|	subject propertylist--}--simpleStatement :: N3Parser ()-simpleStatement = subject >>= propertyListWith-  -{--subject ::=		|	expression--}--subject :: N3Parser RDFLabel-subject = lexeme expression--{--expression ::=		|	pathitem pathtail-pathtail ::=		|	 "!"  expression-		|	 "^"  expression-		|	void---}--expression :: N3Parser RDFLabel-expression = do-  i <- pathItem-  -  let backwardExpr = char '!' *> return addStatementRev -      forwardExpr  = char '^' *> return addStatement-  -  mpt <- optional-        ( (,) <$> lexeme (forwardExpr <|> backwardExpr) <*> lexeme expression )-  case mpt of-    Nothing -> return i -    Just (addFunc, pt) -> do-      bNode <- newBlankNode-      addFunc bNode pt i-      return bNode-  -{--pathitem ::=		|	 "("  pathlist  ")" -		|	 "["  propertylist  "]" -		|	 "{"  formulacontent  "}" -		|	boolean-		|	literal-		|	numericliteral-		|	quickvariable-		|	symbol--pathlist ::=		|	expression pathlist-		|	void--Need to think about how to handle formulae, since need to know the context-of the call to know where to add them.--TOOD: may include direct support for blank nodes here,-namely convert _:stringval -> Blank stringval since although-this should be done by symbol the types don't seem to easily match-up (at first blush anyway)--}--pathItem :: N3Parser RDFLabel-pathItem = -  br "(" ")" pathList-  <|> br "[" "]" propertyListBNode-  <|> br "{" "}" formulaContent-  -- <|> try boolean-  <|> boolean-  <|> literal-  <|> numericLiteral-  <|> quickVariable-  <|> Blank <$> (string "_:" *> n3NameStr) -- TODO a hack that needs fixing-  <|> Res <$> n3symbol-  -{-  -we create a blank node for the list and return it, whilst-adding the list contents to the graph--}-pathList :: N3Parser RDFLabel-pathList = do-  cts <- many (lexeme expression)-  eNode <- operatorLabel rdfNil-  case cts of-    [] -> return eNode-      -    (c:cs) -> do-      sNode <- newBlankNode-      first <- operatorLabel rdfFirst-      addStatement sNode first c-      lNode <- foldM addElem sNode cs-      rest <- operatorLabel rdfRest-      addStatement lNode rest eNode-      return sNode--    where      -      addElem prevNode curElem = do-        bNode <- newBlankNode-        first <- operatorLabel rdfFirst-        rest <- operatorLabel rdfRest-        addStatement prevNode rest bNode-        addStatement bNode first curElem-        return bNode-        -{--formulacontent ::=		|	statementlist--statementlist ::=		|	statement statementtail-		|	void-statementtail ::=		|	 "."  statementlist-		|	void--}--restoreState :: N3State -> N3Parser N3State-restoreState origState = do-  oldState <- stGet-  stUpdate $ \_ -> origState { nodeGen = nodeGen oldState }-  return oldState--{--We create a subgraph and assign it to a blank node, returning the-blank node. At present it is a combination of the subgraph and formula-productions from the origial parser.--TODO: is it correct?--}-formulaContent :: N3Parser RDFLabel-formulaContent = do-  bNode <- newBlankNode-  pstate <- stGet-  stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = bNode }-  statementList-  oldState <- restoreState pstate-  stUpdate $ updateGraph $ setFormula (Formula bNode (graphState oldState))-  return bNode-  -subgraph :: RDFLabel -> N3Parser RDFGraph-subgraph this = do-  pstate <- stGet-  stUpdate $ \st -> st { graphState = emptyRDFGraph, thisNode = this }-  statementsOptional    -- parse statements of formula-  oldState <- restoreState pstate  -  return $ graphState oldState-  -statementList :: N3Parser ()-statementList = ignore $ sepEndBy (lexeme statement) fullStop--{--boolean ::=		|	 "@false" -		|	 "@true" --}--boolean :: N3Parser RDFLabel-boolean = mkTypedLit xsdBoolean <$> -          (atWord "false" <|> atWord "true")-          -- (try (atWord "false") <|> atWord "true")-           -{--dtlang ::=		|	 "@"  langcode-		|	 "^^"  symbol-		|	void-literal ::=		|	string dtlang--langcode ::=	[a-z]+(-[a-z0-9]+)*---}--literal :: N3Parser RDFLabel-literal = Lit <$> n3string <*> optional dtlang-  -dtlang :: N3Parser ScopedName-dtlang = -  (char '@' *> langcode)-  <|> string "^^" *> n3symbol-  -- <|> (try (string "^^") *> n3symbol)--langcode :: N3Parser ScopedName-langcode = do-  h <- many1Satisfy isaz-  mt <- optional ( L.append <$> (char '-' *> pure (L.singleton '-')) <*> many1Satisfy isaz09)-  return $ langName $ L.toStrict $ L.append h (fromMaybe L.empty mt)-    -{--decimal ::=	[-+]?[0-9]+(\.[0-9]+)?-double ::=	[-+]?[0-9]+(\.[0-9]+)?([eE][-+]?[0-9]+)-integer ::=	[-+]?[0-9]+-numericliteral ::=		|	decimal-		|	double-		|	integer--We actually support 1. for decimal values which isn't supported -by the above production.--TODO: we could convert via something like--  maybeRead value :: Double >>= Just . toRDFLabel--which would mean we store the canonical XSD value in the-label, but it is not useful for the xsd:decimal case-since we currently don't have a Haskell type that-goes with it.--}--numericLiteral :: N3Parser RDFLabel-numericLiteral =-  -- -- try (mkTypedLit xsdDouble <$> n3double)-  -- try (d2s <$> n3double)-  -- <|> try (mkTypedLit xsdDecimal <$> n3decimal)-  d2s <$> n3double-  <|> mkTypedLit xsdDecimal . T.pack <$> n3decimal-  <|> mkTypedLit xsdInteger . T.pack <$> n3integer--n3sign :: N3Parser Char-n3sign = char '+' <|> char '-'--n3integer :: N3Parser String-n3integer = do-  ms <- optional n3sign-  ds <- many1 digit-  case ms of-    Just s -> return $ s : ds-    _ -> return ds--n3decimal :: N3Parser String--- n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many1 digit )-n3decimal = (++) <$> n3integer <*> ( (:) <$> char '.' <*> many digit )-           -n3double :: N3Parser String-n3double = (++) <$> n3decimal <*> ( (:) <$> satisfy (`elem` "eE") <*> n3integer )---- Convert a double, as returned by n3double, into it's--- canonical XSD form. We assume that n3double returns--- a syntactivally valid Double, so do not bother with reads here----d2s :: String -> RDFLabel-d2s s = toRDFLabel (read s :: Double)--{--propertylist ::=		|	verb object objecttail propertylisttail-		|	void-propertylisttail ::=		|	 ";"  propertylist-		|	void---}---- it's probably important that bNode is created *after*--- processing the plist (mainly for the assumptions made by--- formatting the output as N3; e.g. list/sequence ordering)----propertyListBNode :: N3Parser RDFLabel-propertyListBNode = do-  plist <- sepEndBy ((,) <$> lexeme verb <*> objectList) semiColon-  bNode <- newBlankNode-  let addList ((addFunc,vrb),items) = mapM_ (addFunc bNode vrb) items-  forM_ plist addList-  return bNode--propertyListWith :: RDFLabel -> N3Parser ()-propertyListWith subj = -  let -- term = lexeme verb >>= objectListWith subj-      term = lexeme verb >>= \(addFunc, vrb) -> objectListWith (addFunc subj vrb)-  in ignore $ sepEndBy term semiColon-  -{--object ::=		|	expression-objecttail ::=		|	 ","  object objecttail-		|	void--We change the production rule from objecttail to objectlist for lists of-objects (may change back).---}--object :: N3Parser RDFLabel-object = lexeme expression--objectList :: N3Parser [RDFLabel]-objectList = sepBy1 object comma--objectWith :: AddStatement -> N3Parser ()-objectWith addFunc = object >>= addFunc --objectListWith :: AddStatement -> N3Parser ()-objectListWith addFunc =-  ignore $ sepBy1 (objectWith addFunc) comma--{--objectList1 :: N3Parser [RDFLabel]-objectList1 = sepBy1 object comma--}--{--verb ::=		|	 "<=" -		|	 "=" -		|	 "=>" -		|	 "@a" -		|	 "@has"  expression-		|	 "@is"  expression  "@of" -		|	expression---}--verb :: N3Parser (RDFLabel -> RDFLabel -> AddStatement, RDFLabel)-verb = -  -- we check reverse first so that <= is tried before looking for a URI via expression rule-  (,) addStatementRev <$> verbReverse-  <|> (,) addStatement <$> verbForward---- those verbs for which subject is on the right and object on the left-verbReverse :: N3Parser RDFLabel-verbReverse =-  string "<=" *> operatorLabel logImplies-  <|> between (atWord "is") (atWord "of") (lexeme expression)--{--  try (string "<=") *> operatorLabel logImplies-  <|> between (try (atWord "is")) (atWord "of") (lexeme expression)--}---- those verbs with subject on the left and object on the right-verbForward :: N3Parser RDFLabel-verbForward =  -  -- (try (string "=>") *> operatorLabel logImplies)-  (string "=>" *> operatorLabel logImplies)-  <|> (string "=" *> operatorLabel owlSameAs)-  -- <|> (try (atWord "a") *> operatorLabel rdfType)-  <|> (atWord "a" *> operatorLabel rdfType)-  <|> (atWord "has" *> lexeme expression)-  <|> lexeme expression--{--universal ::=		|	 "@forAll"  symbol_csl--TODO: what needs to be done to support universal quantification--}-universal :: N3Parser ()-universal = -  -- try (atWord "forAll") *> -  atWord "forAll" *> -  failBad "universal (@forAll) currently unsupported." -  -- will be something like: *> symbolCsl----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,247 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  N3Formatter---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  OverloadedStrings------  This Module implements a NTriples formatter (see [1])---  for an RDFGraph value.--------- REFERENCES:------ 1 <http://www.w3.org/TR/rdf-testcases/#ntriples>---     RDF Test Cases---     W3C Recommendation 10 February 2004--------------------------------------------------------------------------------------module Swish.RDF.NTFormatter-    ( NodeGenLookupMap-    , formatGraphAsText-    , formatGraphAsLazyText-    , formatGraphAsBuilder-    )-where--import Swish.RDF.RDFGraph-  ( RDFGraph, RDFLabel(..)-  , getArcs-  )--import Swish.RDF.GraphClass-    ( Arc(..) )--import Swish.Utils.Namespace (ScopedName, getQName)-import Swish.RDF.Vocabulary (isLang, langTag)--import Swish.Utils.LookupMap-    ( LookupMap, emptyLookupMap-    , mapFind, mapAdd-    )--import Data.Char (ord, intToDigit, toUpper)--import Control.Monad.State-import Control.Applicative ((<$>))-import Data.Monoid---- it strikes me that using Lazy Text here is likely to be--- wrong; however I have done no profiling to back this--- assumption up!--import qualified Data.Text as T-import qualified Data.Text.Lazy as L-import qualified Data.Text.Lazy.Builder as B---------------------------------------------------------------------------  Graph formatting state monad-----------------------------------------------------------------------------  This is a lot simpler than other formatters.----  | Node name generation state information that carries through---  and is updated by nested formulae-type NodeGenLookupMap = LookupMap (RDFLabel,Int)--data NTFormatterState = NTFS { -      ntfsNodeMap :: NodeGenLookupMap,-      ntfsNodeGen :: Int-    } deriving Show--emptyNTFS :: NTFormatterState-emptyNTFS = NTFS {-              ntfsNodeMap = emptyLookupMap,-              ntfsNodeGen = 0-              }--type Formatter a = State NTFormatterState a---- | Convert a RDF graph to NTriples format.-formatGraphAsText :: RDFGraph -> T.Text-formatGraphAsText = L.toStrict . formatGraphAsLazyText---- | Convert a RDF graph to NTriples format.-formatGraphAsLazyText :: RDFGraph -> L.Text-formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder---- | Convert a RDF graph to NTriples format.-formatGraphAsBuilder :: RDFGraph -> B.Builder-formatGraphAsBuilder gr = fst $ runState (formatGraph gr) emptyNTFS---------------------------------------------------------------------------  Formatting as a monad-based computation-------------------------------------------------------------------------formatGraph :: RDFGraph -> Formatter B.Builder-formatGraph gr = mconcat <$> mapM formatArc (getArcs gr)---- TODO: this reverses the contents but may be faster?---       that is if I've got the order right in the mappend call--- formatGraphBuilder gr = foldl' (\a b -> b `mappend` (formatArcBuilder a)) B.empty (getArcs gr)--space, nl :: B.Builder-space = B.singleton ' '-nl    = " .\n"--formatArc :: Arc RDFLabel -> Formatter B.Builder-formatArc (Arc s p o) = do-  sl <- formatLabel s-  pl <- formatLabel p-  ol <- formatLabel o-  return $ mconcat [sl, space, pl, space, ol, nl]-  -- return $ sl `mappend` $ space `mappend` $ pl `mappend` $ space `mappend` $ ol `mappend` nl-  -{--If we have a blank node then can--  - use the label it contains-  - generate a new one on output--For now we create new labels whatever the input was since this-simplifies things, but it may be changed.--formatLabel :: RDFLabel -> Formatter String-formatLabel lab@(Blank (lnc:_)) = -  if isDigit lnc then mapBlankNode lab else return $ show lab-formatLabel lab = return $ show lab--}--squote, at, carets  :: B.Builder-squote = "\""-at     = "@"-carets = "^^"--formatLabel :: RDFLabel -> Formatter B.Builder-formatLabel lab@(Blank _) = mapBlankNode lab-formatLabel (Res sn) = return $ showScopedName sn-formatLabel (Lit lit Nothing) = return $ quoteText lit-formatLabel (Lit lit (Just nam)) | isLang nam = return $ mconcat [quoteText lit, at, B.fromText (langTag nam)]-                                 | otherwise  = return $ mconcat [quoteText lit, carets, showScopedName nam]---- do not expect to get the following, but include--- just in case rather than failing-formatLabel lab = return $ B.fromString $ show lab--mapBlankNode :: RDFLabel -> Formatter B.Builder-mapBlankNode lab = do-  st <- get-  let cmap = ntfsNodeMap st-      cval = ntfsNodeGen st--  nv <- case mapFind 0 lab cmap of-            0 -> do-              let nval = succ cval-                  nmap = mapAdd cmap (lab, nval)--              put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval }-              return nval--            n -> return n--  return $ "_:swish" `mappend` B.fromString (show nv)---- TODO: can we use Network.URI to protect the URI?-showScopedName :: ScopedName -> B.Builder-{--showScopedName (ScopedName n l) = -  let uri = T.pack (show (nsURI n)) `mappend` l-  in mconcat ["<", B.fromText (quote uri), ">"]--}--- showScopedName s = mconcat ["<", B.fromText (quote (T.pack (show (getQName s)))), ">"]-showScopedName s = B.fromText (quote (T.pack (show (getQName s)))) -- looks like qname already adds the <> around this--{--Swish.Utils.MiscHelpers contains a quote routine-which we expand upon here to match the NT syntax.--}--quoteText :: T.Text -> B.Builder-quoteText  st = mconcat [squote, B.fromText (quote st), squote]--{--QUS: should we be operating on Text like this?--}--quote :: T.Text -> T.Text-quote = T.concatMap quoteT--quoteT :: Char -> T.Text-quoteT '\\' = "\\\\"-quoteT '"'  = "\\\""-quoteT '\n' = "\\n"-quoteT '\t' = "\\t"-quoteT '\r' = "\\r"-quoteT c    = -  let nc = ord c-      -  in if nc > 0xffff -     then T.pack ('\\':'U': numToHex 8 nc)-     else if nc > 0x7e || nc < 0x20-          then T.pack ('\\':'u': numToHex 4 nc)-          else T.singleton c-                      --- we assume c > 0, n >= 0 and that the input value fits--- into the requested number of digits-numToHex :: Int -> Int -> String-numToHex c v = go [] v-  where-    go s 0 = replicate (c - length s) '0' ++ s-    go s n = -      let (m,x) = divMod n 16-      in go (iToD x:s) m--    -- Data.Char.intToDigit uses lower-case Hex-    iToD x | x < 10    = intToDigit x-           | otherwise = toUpper $ intToDigit x-      ---------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,427 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  NTParser---  Copyright   :  (c) 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This Module implements a NTriples parser (see [1]), returning a---  new 'RDFGraph' consisting of triples and namespace information parsed from---  the supplied NTriples input string, or an error indication.------ REFERENCES:------ 1 <http://www.w3.org/TR/rdf-testcases/#ntriples>---     RDF Test Cases---     W3C Recommendation 10 February 2004--------------------------------------------------------------------------------------module Swish.RDF.NTParser-    ( ParseResult-    , parseNT      -    , parsefromString-    -      {--    -- * Exports for parsers that embed NTriples in a bigger syntax-    , NTParser, NTState(..)-    , ntripleDoc-    , line, ws, comment, eoln-    , character, name, triple-    , subject, predicate, object-    , uriref, urirefLbl-    , nodeID, literal, language-      -}-      -    )-where--import Swish.RDF.RDFGraph-    ( RDFGraph, RDFLabel(..)-    , addArc -    , emptyRDFGraph-    )--import Swish.RDF.GraphClass (arc)--import Swish.Utils.Namespace (ScopedName, makeURIScopedName)--import Swish.RDF.Vocabulary (langName)--import Swish.RDF.RDFParser ( ParseResult-    , runParserWithError-    , ignore-    , skipMany-    , noneOf-    , char-    , string-    , eoln-    , fullStop-    , hex4-    , hex8-    )-  -{--import Swish.RDF.RDFParser-    ( ParseResult, RDFParser-    , ignore-    , annotateParsecError-    )--}--import Control.Applicative--import Network.URI (parseURI)--import qualified Data.Text as T-import qualified Data.Text.Lazy as L--import Data.Char (ord) -import Data.Maybe (fromMaybe)--import Text.ParserCombinators.Poly.StateText--------------------------------------------------------------------------- Define parser state and helper functions--------------------------------------------------------------------------- | NT parser state-data NTState = NTState-        { graphState :: RDFGraph            -- Graph under construction-        }--emptyState :: NTState-emptyState = NTState { graphState = emptyRDFGraph }-           ---  Return function to update graph in NT parser state,---  using the supplied function of a graph. This is for use---  with stUpdate.----updateGraph :: (RDFGraph -> RDFGraph) -> NTState -> NTState-updateGraph f s = s { graphState = f (graphState s) }---------------------------------------------------------------------------  Define top-level parser function:---  accepts a string and returns a graph or error--------------------------------------------------------------------------- | Parser that carries around a `NTState` record.-type NTParser a = Parser NTState a---- | Parse a string.--- -parseNT ::-  L.Text -- ^ input in NTriples format.-  -> ParseResult-parseNT = parsefromText ntripleDoc--{---- useful for testing-test :: String -> RDFGraph-test = either error id . parseNT--}---- | Function to supply initial context and parse supplied term.----parsefromString :: -    NTParser a      -- ^ parser to apply-    -> String       -- ^ input to be parsed-    -> Either String a-parsefromString parser = parsefromText parser . L.pack---- | Function to supply initial context and parse supplied term.----parsefromText :: -    NTParser a      -- ^ parser to apply-    -> L.Text       -- ^ input to be parsed-    -> Either String a-parsefromText parser = runParserWithError parser emptyState---- helper routines--{--lineFeed :: NTParser ()-lineFeed = ignore (char '\r')--}---- Add statement to graph in NT parser state--addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> NTParser ()-addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) ))---------------------------------------------------------------------------  Syntax productions-------------------------------------------------------------------------{---EBNF from the specification, using the notation from XML 1.0, second edition,-is included inline below.--We do not force ASCII 7-bit semantics here yet.--space	::=	#x20 /* US-ASCII space - decimal 32 */	-cr	::=	#xD /* US-ASCII carriage return - decimal 13 */	-lf	::=	#xA /* US-ASCII line feed - decimal 10 */	-tab	::=	#x9 /* US-ASCII horizontal tab - decimal 9 */	--The productions are kept as close as possible to the specification-for now.---}--{--ntripleDoc	::=	line*	-line	::=	ws* ( comment | triple )? eoln	--We relax the rule that the input must be empty or end with a new line.--ntripleDoc :: NTParser RDFGraph-ntripleDoc = graphState <$> (many line *> eof *> getState)--line :: NTParser ()-line = skipMany ws *> optional (comment <|> triple) *> eoln--}--ntripleDoc :: NTParser RDFGraph-ntripleDoc = graphState <$> (sepBy line eoln *> optional eoln *> skipWS *> eof *> stGet)--line :: NTParser ()-line = skipWS *> ignore (optional (comment <|> triple))--{--ws	::=	space | tab	--Could use whiteSpace rule here, but that would permit-constructs (e.g. comments) where we do not support them.--}--isWS :: Char -> Bool-isWS = (`elem` " \t")--{--ws :: NTParser ()--- ws = ignore (char ' ' <|> tab)-ws = ignore $ satisfy isWS--}-           -skipWS :: NTParser ()-skipWS = ignore $ manySatisfy isWS--skip1WS :: NTParser ()-skip1WS = ignore $ many1Satisfy isWS--{--comment	::=	'#' ( character - ( cr | lf ) )*	--}--comment :: NTParser ()-comment = char '#' *> skipMany (noneOf "\r\n")--{--eoln	::=	cr | lf | cr lf	--}--{--name	::=	[A-Za-z][A-Za-z0-9]*	--}--isaz, isAZ, is09 :: Char -> Bool-isaz c = c >= 'a' && c <= 'z'-isAZ c = c >= 'A' && c <= 'Z'-is09 c = c >= '0' && c <= '9'--isHeadChar, isBodyChar :: Char -> Bool-isHeadChar c = isaz c || isAZ c-isBodyChar c = isHeadChar c || is09 c--name :: NTParser L.Text-name = L.cons <$> satisfy isHeadChar <*> manySatisfy isBodyChar--nameStr :: NTParser String-nameStr = L.unpack <$> name--{--triple	::=	subject ws+ predicate ws+ object ws* '.' ws*	---}--triple :: NTParser ()-triple = -  {- tryin to be fancy but addStatement is a Parser not a pure function-  addStatement -  <$> (subject <* skip1WS)-  <*> (predicate <* skip1WS)-  <*> (object <* (skipWS *> fullStop *> skipWS))-  -}-  -  do-    s <- subject-    skip1WS-    p <- predicate-    skip1WS-    o <- object-    skipWS-    fullStop-    skipWS-    addStatement s p o--{--subject	::=	uriref | nodeID	-predicate	::=	uriref	-object	::=	uriref | nodeID | literal	--}--subject :: NTParser RDFLabel-subject = urirefLbl <|> nodeID--predicate :: NTParser RDFLabel-predicate = urirefLbl--object :: NTParser RDFLabel-object = urirefLbl <|> nodeID <|> literal--{--uriref	::=	'<' absoluteURI '>'	-absoluteURI	::=	character+ with escapes as defined in section URI References	---}--uriref :: NTParser ScopedName-uriref = do-  -- not ideal, as want to reject invalid characters immediately rather than via parseURI-  ustr <- L.unpack <$> bracket (char '<') (char '>') (many1Satisfy (/= '>'))-  -- ustr <- bracket (char '<') (char '>') $ many1 character -- looks like need to exclude > from character-  -- ustr <- char '<' *> manyTill character (char '>')-  -  maybe (failBad ("Invalid URI: <" ++ ustr ++ ">"))-    (return . makeURIScopedName)-    (parseURI ustr)--urirefLbl :: NTParser RDFLabel-urirefLbl = Res <$> uriref--{--nodeID	::=	'_:' name	--}--nodeID :: NTParser RDFLabel-nodeID = Blank <$> (string "_:" *> nameStr)--{-  -literal	::=	langString | datatypeString	-langString	::=	'"' string '"' ( '@' language )?	-datatypeString	::=	'"' string '"' '^^' uriref	-language	::=	[a-z]+ ('-' [a-z0-9]+ )*-encoding a language tag.	-string	::=	character* with escapes as defined in section Strings	---}--literal :: NTParser RDFLabel-literal = Lit <$> (T.pack <$> ntstring) <*> optional dtlang--ntstring :: NTParser String-ntstring = bracket (char '"') (char '"') (many character)--dtlang :: NTParser ScopedName-dtlang = -    (char '@' *> language)-    <|> (string "^^" *> uriref)--language :: NTParser ScopedName-language = do-  h <- many1Satisfy isaz-  mt <- optional ( L.cons <$> char '-' <*> many1Satisfy (\c -> isaz c || is09 c) )-  return $ langName $ L.toStrict $ L.append h $ fromMaybe L.empty mt--{--String handling: --EBNF has:--character	::=	[#x20-#x7E] /* US-ASCII space to decimal 126 */	--Additional information from:--  http://www.w3.org/TR/rdf-testcases/#ntrip_strings--N-Triples strings are sequences of US-ASCII character productions encoding [UNICODE] character strings. The characters outside the US-ASCII range and some other specific characters are made available by \-escape sequences as follows:-- Unicode character- (with code point u)	N-Triples encoding- [#x0-#x8]	\uHHHH- 4 required hexadecimal digits HHHH encoding Unicode character u- #x9	\t- #xA	\n- [#xB-#xC]	\uHHHH- 4 required hexadecimal digits HHHH encoding Unicode character u- #xD	\r- [#xE-#x1F]	\uHHHH- 4 required hexadecimal digits HHHH encoding Unicode character u- [#x20-#x21]	the character u- #x22	\"- [#x23-#x5B]	the character u- #x5C	\\- [#x5D-#x7E]	the character u- [#x7F-#xFFFF]	\uHHHH- 4 required hexadecimal digits HHHH encoding Unicode character u- [#10000-#x10FFFF]	\UHHHHHHHH- 8 required hexadecimal digits HHHHHHHH encoding Unicode character u- where H is a hexadecimal digit: [#x30-#x39],[#x41-#x46] (0-9, uppercase A-F).--This escaping satisfies the [CHARMOD] section Reference Processing Model on making the full Unicode character range U+0 to U+10FFFF available to applications and providing only one way to escape any character.---}---- 0x22 is " and 0x5c is \--isAsciiChar :: Char -> Bool-isAsciiChar c = let i = ord c-                in i >= 0x20 && i <= 0x21 ||-                   i >= 0x23 && i <= 0x5b ||-                   i >= 0x5d && i <= 0x7e--protectedChar :: NTParser Char-protectedChar =-  (char 't' *> return '\t')-  <|> (char 'n' *> return '\n')-  <|> (char 'r' *> return '\r')-  <|> (char '"' *> return '"')-  <|> (char '\\' *> return '\\')-  <|> (char 'u' *> hex4)-  <|> (char 'U' *> hex8)--character :: NTParser Char-character = -  (char '\\' *> protectedChar)-  <|> satisfy isAsciiChar----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,296 +0,0 @@------------------------------------------------------------------------------------  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, foldl')-import Data.Maybe (catMaybes, isNothing)-----------------------------------------------------------------  Proof framework----------------------------------------------------------------- |Step in proof chain------  The display name for a proof step comes from the display name of its---  consequence formula.-data Step ex = Step-    { stepRule :: Rule ex           -- ^ Inference rule used-    , stepAnt  :: [Formula ex]      -- ^ Antecedents of inference rule-    , stepCon  :: Formula ex        -- ^ Named consequence of inference rule-    } deriving Show---- |Proof is a structure that presents a chain of rule applications---  that yield a result expression from a given expression-data Proof ex = Proof-    { proofContext :: [Ruleset ex]  -- ^ Proof context:  list of rulesets,-                                    --   each of which provides a number of-                                    --   axioms and rules.-    , proofInput   :: Formula ex    -- ^ Given expression-    , proofResult  :: Formula ex    -- ^ Result expression-    , proofChain   :: [Step ex]     -- ^ Chain of inference rule applications-                                    --   progressing from input to result-    }---- |Return a list of axioms from all the rulesets in a proof-proofAxioms :: Proof a -> [Formula a]-proofAxioms = concatMap rsAxioms . proofContext---- |Return a list of rules from all the rulesets in a proof-proofRules :: Proof a -> [Rule a]-proofRules = concatMap rsRules . proofContext---- |Return list of axioms actually referenced by a proof-proofAxiomsUsed :: Proof ex -> [Formula ex]-proofAxiomsUsed proof = foldl' union [] $ map stepAxioms (proofChain proof)-    where-        stepAxioms st = stepAnt st `intersect` proofAxioms proof---- |Check consistency of given proof.---  The supplied rules and axioms are assumed to be correct.-checkProof :: (Expression ex) => Proof ex -> Bool-checkProof pr =-    checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr-    where-        initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr)-        goalExpr = formExpr $ proofResult pr--checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool-checkProof1 _     prev []       res = res `elem` prev-checkProof1 rules prev (st:steps) res =-    checkStep rules prev st &&-    checkProof1 rules (formExpr (stepCon st):prev) steps res---- | A proof step is valid if rule is in list of rules---  and the antecedents are sufficient to obtain the conclusion---  and the antecedents are in the list of formulae already proven.------  Note:  this function depends on the ruleName of any rule being---  unique among all rules.  In particular the name of the step rule---  being in correspondence with the name of one of the indicated---  valid rules of inference.-checkStep :: -  (Expression ex) -  => [Rule ex]   -- ^ rules-  -> [ex]        -- ^ antecedants-  -> Step ex     -- ^ the step to validate-  -> Bool        -- ^ @True@ if the step is valid--checkStep rules prev step = isNothing $ explainStep rules prev step--{---Is the following an optimisation of the above?--checkStep rules prev step =-    -- Rule name is one of supplied rules, and-    (ruleName srul `elem` map ruleName rules) &&-    -- Antecedent expressions are all previously accepted expressions-    (sant `subset` prev)   &&-    -- Inference rule yields concequence from antecendents-    checkInference srul sant scon-    where-        --  Rule from proof step:-        srul = stepRule step-        --  Antecedent expressions from proof step:-        sant = map formExpr $ stepAnt step-        --  Consequentent expression from proof step:-        scon = formExpr $ stepCon step--}---{--    (formExpr (stepCon step) `elem` sfwd)-    -- (or $ map (`subset` sant) sbwd)-    where-        --  Rule from proof step:-        srul = stepRule step-        --  Antecedent expressions from proof step:-        sant = map formExpr $ stepAnt step-        --  Forward chaining from antecedents of proof step-        scon = map formExpr $ stepCon step-        --  Forward chaining from antecedents of proof step--        sfwd = fwdApply srul sant-        --  Backward chaining from consequent of proof step-        --  (Does not work because of introduction of existentials)-        sbwd = bwdApply srul (formExpr $ stepCon step)--}---- |Check proof. If there is an error then return information--- about the failing step.-explainProof ::-    (Expression ex) => Proof ex -> Maybe String-explainProof pr =-    explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr-    where-        initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr)-        goalExpr = formExpr $ proofResult pr--explainProof1 ::-    (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String-explainProof1 _     prev []       res   =-    if res `elem` prev then Nothing else Just "Result not demonstrated"-explainProof1 rules prev (st:steps) res =-    case explainStep rules prev st  of-        Nothing -> explainProof1 rules (formExpr (stepCon st):prev) steps res-        Just ex -> Just ("Invalid step: "++show (formName $ stepCon st)++": "++ex)---- | A proof step is valid if rule is in list of rules---  and the antecedents are sufficient to obtain the conclusion---  and the antecedents are in the list of formulae already proven.------  Note:  this function depends on the ruleName of any rule being---  unique among all rules.  In particular the name of the step rule---  being in correspondence with the name of one of the indicated---  valid rules of inference.----explainStep :: -  (Expression ex) -  => [Rule ex]  -- ^ rules-  -> [ex]       -- ^ previous-  -> Step ex    -- ^ step-  -> Maybe String -- ^ @Nothing@ if step is okay, otherwise a string indicating the error-explainStep rules prev step =-        if null errors then Nothing else Just $ intercalate ", " errors-    where-        --  Rule from proof step:-        srul = stepRule step-        --  Antecedent expressions from proof step:-        sant = map formExpr $ stepAnt step-        --  Consequentent expression from proof step:-        scon = formExpr $ stepCon step-        --  Tests for step to be valid-        errors = catMaybes-            -- Rule name is one of supplied rules, and-            [ require (ruleName srul `elem` map ruleName rules)-                      ("rule "++show (ruleName srul)++" not present")-            -- Antecedent expressions are all previously accepted expressions-            , require (sant `subset` prev)-                      "antecedent not axiom or previous result"-            -- Inference rule yields consequence from antecedents-            , require (checkInference srul sant scon)-                      "rule does not deduce consequence from antecedents"-            ]-        require b s = if b then Nothing else Just s---- |Create a displayable form of a proof, returned as a `ShowS` value.------  This function is intended to allow the calling function some control---  of multiline displays by providing:------  (1) the first line of the proof is not preceded by any text, so---      it may be appended to some preceding text on the same line,------  (2) the supplied newline string is used to separate lines of the---      formatted text, and may include any desired indentation, and------  (3) no newline is output following the final line of text.-showsProof :: -  (ShowM ex) -  => String    -- ^ newline string-  -> Proof ex -  -> ShowS-showsProof newline proof =-    if null axioms then shProof else shAxioms . shProof-    where-        axioms = proofAxiomsUsed proof-        shAxioms =-            showString    ("Axioms:" ++ newline) .-            showsFormulae newline (proofAxiomsUsed proof) newline-        shProof =-            showString    ("Input:" ++ newline) .-            showsFormula  newline (proofInput  proof) .-            showString    (newline ++ "Proof:" ++ newline) .-            showsSteps    newline (proofChain  proof)---- |Returns a simple string representation of a proof.-showProof :: -  (ShowM ex) -  => String    -- ^ newline string-  -> Proof ex -  -> String-showProof newline proof = showsProof newline proof ""---- |Create a displayable form of a list of labelled proof steps-showsSteps :: (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 []      = "<nothing>"-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------------------------------------------------------------------------------------

@@ -1,202 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  RDFDatatype---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module defines the structures used by Swish to represent and---  manipulate RDF datatypes.--------------------------------------------------------------------------------------module Swish.RDF.RDFDatatype-    ( RDFDatatype-    , RDFDatatypeVal-    , RDFDatatypeMod-    , RDFModifierFn, RDFApplyModifier-    , makeRdfDtOpenVarBindingModify, makeRdfDtOpenVarBindingModifiers-    , applyRDFDatatypeMod-    , RDFDatatypeSub-    , fromRDFLabel, toRDFLabel, makeDatatypedLiteral-    )-where--import Swish.RDF.RDFGraph-    ( RDFLabel(..)-    , isDatatyped-    , getLiteralText-    , RDFGraph-    )--import Swish.RDF.RDFVarBinding-    ( RDFVarBinding, RDFOpenVarBindingModify )--import Swish.RDF.Datatype-    ( Datatype -- , typeName, typeRules-    , DatatypeVal(..)-    , DatatypeMap(..)-    , DatatypeMod(..), ModifierFn-    , ApplyModifier-    , DatatypeSub(..)-    )--import Swish.RDF.VarBinding (VarBindingModify(..))-import Swish.Utils.Namespace (ScopedName)--import Control.Monad (liftM)-import Data.Maybe (fromMaybe, isJust, fromJust)--import qualified Data.Text as T-----------------------------------------------------------------  Specialize datatype framework types for use with RDF----------------------------------------------------------------- |RDF datatype wrapper used with RDF graph values----type RDFDatatype = Datatype RDFGraph RDFLabel RDFLabel---- |RDF datatype value used with RDF graph values----type RDFDatatypeVal vt = DatatypeVal RDFGraph vt RDFLabel RDFLabel---- |RDF datatype modifier used with RDF graph values----type RDFDatatypeMod vt = DatatypeMod vt RDFLabel RDFLabel---- |Describe a subtype/supertype relationship between a pair---  of RDF datatypes.----type RDFDatatypeSub supvt subvt = DatatypeSub RDFGraph RDFLabel RDFLabel supvt subvt---- |RDF value modifier function type------  This indicates a modifier function that operates on 'RDFLabel' values.----type RDFModifierFn = ModifierFn RDFLabel---- |RDF value modifier application function type------  This indicates a function that applies RDFModifierFn functions.----type RDFApplyModifier = ApplyModifier RDFLabel RDFLabel-------------------------------------------------------------------  Functions for creating datatype variable binding modifiers------------------------------------------------------------------- |Create an 'RDFOpenVarBindingModify' value.------  The key purpose of this function is to lift the supplied---  variable constraint functions from operating on data values directly---  to a corresponding list of functions that operate on values contained---  in RDF graph labels (i.e. RDF literal nodes).  It also applies---  node type checking, such that if the actual RDF nodes supplied do---  not contain appropriate values then the variable binding is not---  accepted.----makeRdfDtOpenVarBindingModify ::-    RDFDatatypeVal vt-    -- ^ is an 'RDFDatatype' value containing details of the datatype-    --   for which a variable binding modifier is created.-    -> RDFDatatypeMod vt -    -- ^ is the data value modifier value that defines the calculations-    --   that are used to implement a variable binding modifier.-    -> RDFOpenVarBindingModify-makeRdfDtOpenVarBindingModify dtval dtmod =-    dmAppf dtmod (dmName dtmod) $ map (makeRDFModifierFn dtval) (dmModf dtmod)---- |Create all RDFOpenVarBindingModify values for a given datatype value.---  See 'makeRdfDtOpenVarBindingModify'.----makeRdfDtOpenVarBindingModifiers ::-    RDFDatatypeVal vt -    -- ^  is an 'RDFDatatype' value containing details of the datatype-    --    for which variable binding modifiers are created.-    -> [RDFOpenVarBindingModify]-makeRdfDtOpenVarBindingModifiers dtval =-    map (makeRdfDtOpenVarBindingModify dtval) (tvalMod dtval)---- |Apply a datatype modifier using supplied RDF labels to a supplied---  RDF variable binding.----applyRDFDatatypeMod ::-    RDFDatatypeVal vt -> RDFDatatypeMod vt -> [RDFLabel] -> [RDFVarBinding]-    -> [RDFVarBinding]-applyRDFDatatypeMod dtval dtmod lbs =-    vbmApply (makeRdfDtOpenVarBindingModify dtval dtmod lbs)---- |Given details of a datatype and a single value constraint function,---  return a new constraint function that operates on 'RDFLabel' values.------  The returned constraint function incorporates checks for appropriately---  typed literal nodes, and returns similarly typed literal nodes.----makeRDFModifierFn ::-    RDFDatatypeVal vt -> ModifierFn vt -> RDFModifierFn-makeRDFModifierFn dtval fn ivs =-    let-        ivals = mapM (fromRDFLabel dtval) ivs-        ovals | isJust ivals = fn (fromJust ivals)-              | otherwise    = []-    in-        fromMaybe [] $ mapM (toRDFLabel dtval) ovals-----------------------------------------------------------------  Helpers to map between datatype values and RDFLabels----------------------------------------------------------------- | Convert from a typed literal to a Haskell value,--- with the possibility of failure.-fromRDFLabel ::-    RDFDatatypeVal vt -> RDFLabel -> Maybe vt-fromRDFLabel dtv lab-    | isDatatyped dtnam lab = mapL2V dtmap $ getLiteralText lab-    | otherwise             = Nothing-    where-        dtnam = tvalName dtv-        dtmap = tvalMap dtv---- | Convert a Haskell value to a typed literal (label),--- with the possibility of failure.-toRDFLabel :: RDFDatatypeVal vt -> vt -> Maybe RDFLabel-toRDFLabel dtv =-    liftM (makeDatatypedLiteral dtnam) . mapV2L dtmap-    where-        dtnam = tvalName dtv-        dtmap = tvalMap dtv---- | Create a typed literal from the given value.-makeDatatypedLiteral :: ScopedName -> T.Text -> RDFLabel-makeDatatypedLiteral dtnam txtval =-    Lit txtval (Just dtnam)----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -1,539 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  RDFDatatypeXsdInteger---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  OverloadedStrings------  This module defines the structures used by Swish to represent and---  manipulate RDF @xsd:integer@ datatyped literals.--------------------------------------------------------------------------------------module Swish.RDF.RDFDatatypeXsdInteger-    ( rdfDatatypeXsdInteger-    , rdfDatatypeValXsdInteger-    , typeNameXsdInteger, namespaceXsdInteger-    , axiomsXsdInteger, rulesXsdInteger-    , prefixXsdInteger-    )-where--import Swish.RDF.RDFRuleset-    ( RDFFormula, RDFRule, RDFRuleset -    , makeRDFGraphFromN3Builder-    , makeRDFFormula-    )--import Swish.RDF.RDFDatatype-    ( RDFDatatype-    , RDFDatatypeVal-    , RDFDatatypeMod-    , makeRdfDtOpenVarBindingModifiers-    )--import Swish.RDF.ClassRestrictionRule (makeRDFDatatypeRestrictionRules)-import Swish.RDF.MapXsdInteger (mapXsdInteger)--import Swish.RDF.Datatype-    ( Datatype(..)-    , DatatypeVal(..)-    , DatatypeRel(..), DatatypeRelPr-    , altArgs-    , UnaryFnTable,    unaryFnApp-    , BinaryFnTable,   binaryFnApp-    , BinMaybeFnTable, binMaybeFnApp-    , DatatypeMod(..) -    , makeVmod11inv, makeVmod11-    , makeVmod21inv, makeVmod21-    , makeVmod20-    , makeVmod22-    )--import Swish.RDF.Ruleset (makeRuleset)--import Swish.Utils.Namespace (Namespace, ScopedName, namespaceToBuilder, makeNSScopedName)--import Swish.RDF.Vocabulary-    ( namespaceRDF-    , namespaceRDFS-    , namespaceRDFD-    , namespaceXSD-    , namespaceXsdType-    )--import Data.Monoid(Monoid(..))-import Control.Monad (liftM)-import Data.Maybe (maybeToList)--import qualified Data.Text as T-import qualified Data.Text.Lazy.Builder as B-----------------------------------------------------------------  Misc values-----------------------------------------------------------------  Local name for Integer datatype-nameXsdInteger :: T.Text-nameXsdInteger      = "integer"---- |Type name for xsd:integer datatype-typeNameXsdInteger :: ScopedName-typeNameXsdInteger  = makeNSScopedName namespaceXSD nameXsdInteger---- |Namespace for xsd:integer datatype functions-namespaceXsdInteger :: Namespace-namespaceXsdInteger = namespaceXsdType nameXsdInteger----  Compose with function of two arguments-c2 :: (b -> c) -> (a -> d -> b) -> a -> d -> c-c2 = (.) . (.)----  Integer power (exponentiation) function---  returns Nothing if exponent is negative.----intPower :: Integer -> Integer -> Maybe Integer-intPower a b = if b < 0 then Nothing else Just (intPower1 a b)-    where-        intPower1 x y-            | q == 1           = atopsq*x-            | p == 0           = 1-            | otherwise        = atopsq-            where-                (p,q)  = y `divMod` 2-                atop   = intPower1 x p-                atopsq = atop*atop-----------------------------------------------------------------  Declare exported RDFDatatype value for xsd:integer---------------------------------------------------------------rdfDatatypeXsdInteger :: RDFDatatype-rdfDatatypeXsdInteger = Datatype rdfDatatypeValXsdInteger-----------------------------------------------------------------  Implmentation of RDFDatatypeVal for xsd:integer----------------------------------------------------------------- |Define Datatype value for @xsd:integer@.------  Members of this datatype are positive or negative integer values.------  The lexical form consists of an optional @+@ or @-@---  followed by a sequence of decimal digits.------  The canonical lexical form has leading zeros and @+@ sign removed.----rdfDatatypeValXsdInteger :: RDFDatatypeVal Integer-rdfDatatypeValXsdInteger = DatatypeVal-    { tvalName      = typeNameXsdInteger-    , tvalRules     = rdfRulesetXsdInteger  -- Ruleset RDFGraph-    , tvalMkRules   = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger-                                            -- RDFGraph -> [RDFRules]-    , tvalMkMods    = makeRdfDtOpenVarBindingModifiers rdfDatatypeValXsdInteger-    , tvalMap       = mapXsdInteger         -- DatatypeMap Integer-    , tvalRel       = relXsdInteger         -- [DatatypeRel Integer]-    , tvalMod       = modXsdInteger         -- [DatatypeMod Integer]-    }---- |relXsdInteger contains arithmetic and other relations for xsd:Integer values.------  The functions are inspired by those defined by CWM as math: properties---  (<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 ::-    T.Text -> DatatypeRelPr Integer -> UnaryFnTable Integer-    -> DatatypeRel Integer-mkIntRel2 nam pr fns = DatatypeRel-    { dtRelName = makeNSScopedName namespaceXsdInteger nam-    , dtRelFunc = altArgs pr fns unaryFnApp-    }--mkIntRel3 ::-    T.Text -> DatatypeRelPr Integer -> BinaryFnTable Integer-    -> DatatypeRel Integer-mkIntRel3 nam pr fns = DatatypeRel-    { dtRelName = makeNSScopedName namespaceXsdInteger nam-    , dtRelFunc = altArgs pr fns binaryFnApp-    }--mkIntRel3maybe ::-    T.Text -> DatatypeRelPr Integer -> BinMaybeFnTable Integer-    -> DatatypeRel Integer-mkIntRel3maybe nam pr fns = DatatypeRel-    { dtRelName = makeNSScopedName namespaceXsdInteger nam-    , dtRelFunc = altArgs pr fns binMaybeFnApp-    }--relXsdIntegerAbs :: DatatypeRel Integer-relXsdIntegerAbs = mkIntRel2 "abs" (const True)-    [ ( (>=0),      [ (abs,1) ] )-    , ( const True, [ (id,0), (negate,0) ] )-    ]--relXsdIntegerNeg :: DatatypeRel Integer-relXsdIntegerNeg = mkIntRel2 "neg" (const True)-    [ ( const True, [ (negate,1) ] )-    , ( const True, [ (negate,0) ] )-    ]--relXsdIntegerSum :: DatatypeRel Integer-relXsdIntegerSum = mkIntRel3 "sum" (const True)-    [ ( const True, [ ((+),1,2) ] )-    , ( const True, [ ((-),0,2) ] )-    , ( const True, [ ((-),0,1) ] )-    ]--relXsdIntegerDiff :: DatatypeRel Integer-relXsdIntegerDiff = mkIntRel3 "diff" (const True)-    [ ( const True, [ ((-),1,2) ] )-    , ( const True, [ ((+),0,2) ] )-    , ( const True, [ ((-),1,0) ] )-    ]--relXsdIntegerProd :: DatatypeRel Integer-relXsdIntegerProd = mkIntRel3 "prod" (const True)-    [ ( const True, [ ((*),1,2) ] )-    , ( const True, [ (div,0,2) ] )-    , ( const True, [ (div,0,1) ] )-    ]--relXsdIntegerDivMod :: DatatypeRel Integer-relXsdIntegerDivMod = mkIntRel3 "divmod" (const True)-    [ ( const True, [ (div,2,3) ] )-    , ( const True, [ (mod,2,3) ] )-    , ( const True, [ ] )-    , ( const True, [ ] )-    ]--relXsdIntegerPower :: DatatypeRel Integer-relXsdIntegerPower = mkIntRel3maybe "power" (const True)-    [ ( const True, [ (liftM (:[]) `c2` intPower,1,2) ] )-    , ( const True, [ ] )-    , ( (>=0),      [ ] )-    ]--liftL2 :: (a->a->Bool) -> ([a]->a) -> ([a]->a) -> [a] -> Bool-liftL2 p i1 i2 as = p (i1 as) (i2 as)--lcomp :: (a->a->Bool) -> [a] -> Bool-lcomp p = liftL2 p head (head . tail)---- eq--relXsdIntegerEq :: DatatypeRel Integer-relXsdIntegerEq = mkIntRel2 "eq" (lcomp (==))-    ( repeat (const True, []) )---- ne--relXsdIntegerNe :: DatatypeRel Integer-relXsdIntegerNe = mkIntRel2 "ne" (lcomp (/=))-    ( repeat (const True, []) )---- lt--relXsdIntegerLt :: DatatypeRel Integer-relXsdIntegerLt = mkIntRel2 "lt" (lcomp (<))-    ( repeat (const True, []) )---- le--relXsdIntegerLe :: DatatypeRel Integer-relXsdIntegerLe = mkIntRel2 "le" (lcomp (<=))-    ( repeat (const True, []) )---- gt--relXsdIntegerGt :: DatatypeRel Integer-relXsdIntegerGt = mkIntRel2 "gt" (lcomp (>))-    ( repeat (const True, []) )---- ge--relXsdIntegerGe :: DatatypeRel Integer-relXsdIntegerGe = mkIntRel2 "ge" (lcomp (>=))-    ( repeat (const True, []) )---- |modXsdInteger contains variable binding modifiers for xsd:Integer values.------  The functions are selected from those defined by CWM as math:---  properties---  (<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 = makeNSScopedName namespaceXsdInteger "abs"-    , dmModf = [ f0, f1 ]-    , dmAppf = makeVmod11-    }-    where-        f0 vs@[v1,v2] = if v1 == abs v2 then vs else []-        f0 _          = []-        f1 [v2]       = [abs v2]-        f1 _          = []--modXsdIntegerNeg :: RDFDatatypeMod Integer-modXsdIntegerNeg = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "neg"-    , dmModf = [ f0, f1, f1 ]-    , dmAppf = makeVmod11inv-    }-    where-        f0 vs@[v1,v2] = if v1 == negate v2 then vs else []-        f0 _          = []-        f1 [vi]       = [-vi]-        f1 _          = []--modXsdIntegerSum :: RDFDatatypeMod Integer-modXsdIntegerSum = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "sum"-    , dmModf = [ f0, f1, f2, f2 ]-    , dmAppf = makeVmod21inv-    }-    where-        f0 vs@[v1,v2,v3] = if v1 == v2+v3 then vs else []-        f0 _             = []-        f1 [v2,v3]       = [v2+v3]-        f1 _             = []-        f2 [v1,vi]       = [v1-vi]-        f2 _             = []--modXsdIntegerDiff :: RDFDatatypeMod Integer-modXsdIntegerDiff = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "diff"-    , dmModf = [ f0, f1, f2, f3 ]-    , dmAppf = makeVmod21inv-    }-    where-        f0 vs@[v1,v2,v3] = if v1 == v2-v3 then vs else []-        f0 _             = []-        f1 [v2,v3]       = [v2-v3]-        f1 _             = []-        f2 [v1,v3]       = [v1+v3]-        f2 _             = []-        f3 [v1,v2]       = [v2-v1]-        f3 _             = []--modXsdIntegerProd :: RDFDatatypeMod Integer-modXsdIntegerProd = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "prod"-    , dmModf = [ f0, f1, f2, f2 ]-    , dmAppf = makeVmod21inv-    }-    where-        f0 vs@[v1,v2,v3] = if v1 == v2*v3 then vs else []-        f0 _             = []-        f1 [v2,v3]       = [v2*v3]-        f1 _             = []-        f2 [v1,vi]       = if r == 0 then [q] else []-            where (q,r)  = quotRem v1 vi-        f2 _             = []--modXsdIntegerDivMod :: RDFDatatypeMod Integer-modXsdIntegerDivMod = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "divmod"-    , dmModf = [ f0, f1 ]-    , dmAppf = makeVmod22-    }-    where-        f0 vs@[v1,v2,v3,v4] = if (v1,v2) == divMod v3 v4 then vs else []-        f0 _                = []-        f1 [v3,v4]          = [v1,v2] where (v1,v2) = divMod v3 v4-        f1 _                = []--modXsdIntegerPower :: RDFDatatypeMod Integer-modXsdIntegerPower = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger "power"-    , dmModf = [ f0, f1 ]-    , dmAppf = makeVmod21-    }-    where-        f0 vs@[v1,v2,v3] = if Just v1 == intPower v2 v3 then vs else []-        f0 _             = []-        f1 [v2,v3]       = maybeToList (intPower v2 v3)-        f1 _             = []--modXsdIntegerEq, modXsdIntegerNe, modXsdIntegerLt, modXsdIntegerLe, modXsdIntegerGt, modXsdIntegerGe :: RDFDatatypeMod Integer -modXsdIntegerEq = modXsdIntegerCompare "eq" (==)-modXsdIntegerNe = modXsdIntegerCompare "ne" (/=)-modXsdIntegerLt = modXsdIntegerCompare "lt" (<)-modXsdIntegerLe = modXsdIntegerCompare "le" (<=)-modXsdIntegerGt = modXsdIntegerCompare "gt" (>)-modXsdIntegerGe = modXsdIntegerCompare "ge" (>=)--modXsdIntegerCompare ::-    T.Text -> (Integer->Integer->Bool) -> RDFDatatypeMod Integer-modXsdIntegerCompare nam rel = DatatypeMod-    { dmName = makeNSScopedName namespaceXsdInteger nam-    , dmModf = [ f0 ]-    , dmAppf = makeVmod20-    }-    where-        f0 vs@[v1,v2] = if rel v1 v2 then vs else []-        f0 _          = []---- |rulesetXsdInteger contains rules and axioms that allow additional---  deductions when xsd:integer values appear in a graph.------  The rules defined here are concerned with basic integer arithmetic---  operations: +, -, *, div, rem------  makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex----rdfRulesetXsdInteger :: RDFRuleset-rdfRulesetXsdInteger =-    makeRuleset namespaceXsdInteger axiomsXsdInteger rulesXsdInteger--mkPrefix :: Namespace -> B.Builder-mkPrefix = namespaceToBuilder--prefixXsdInteger :: B.Builder-prefixXsdInteger = -  mconcat-  [ mkPrefix namespaceRDF-  , mkPrefix namespaceRDFS-  , mkPrefix namespaceRDFD-  , mkPrefix namespaceXSD-  , mkPrefix namespaceXsdInteger-  ]--mkAxiom :: T.Text -> B.Builder -> RDFFormula-mkAxiom local gr =-    makeRDFFormula namespaceXsdInteger local (prefixXsdInteger `mappend` gr)--axiomsXsdInteger :: [RDFFormula]-axiomsXsdInteger =-    [ mkAxiom "dt"      "xsd:integer rdf:type rdfs:Datatype ."-    ]--rulesXsdInteger :: [RDFRule]-rulesXsdInteger = makeRDFDatatypeRestrictionRules rdfDatatypeValXsdInteger gr-    where-        gr = makeRDFGraphFromN3Builder rulesXsdIntegerBuilder----- I have removed the newline which was added between each line---- to improve the clarity of parser errors.-----rulesXsdIntegerBuilder :: B.Builder-rulesXsdIntegerBuilder = -  mconcat-  [ prefixXsdInteger-    , "xsd_integer:Abs a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:abs ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Neg a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:neg ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Sum a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; "-    , "  rdfd:constraint xsd_integer:sum ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Diff a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; "-    , "  rdfd:constraint xsd_integer:diff ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Prod a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; "-    , "  rdfd:constraint xsd_integer:prod ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:DivMod a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3 rdf:_4) ; "-    , "  rdfd:constraint xsd_integer:divmod ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Power a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2 rdf:_3) ; "-    , "  rdfd:constraint xsd_integer:power ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Eq a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:eq ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Ne a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:ne ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Lt a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:lt ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Le a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:le ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Gt a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:gt ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    , "xsd_integer:Ge a rdfd:GeneralRestriction ; "-    , "  rdfd:onProperties (rdf:_1 rdf:_2) ; "-    , "  rdfd:constraint xsd_integer:ge ; "-    , "  rdfd:maxCardinality \"1\"^^xsd:nonNegativeInteger . "-    ]-  ---------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------