swish 0.6.5.2 → 0.7.0.0

raw patch · 108 files changed

+19525/−19796 lines, 108 filesdep +semigroupsdep ~containersdep ~internPVP ok

version bump matches the API change (PVP)

Dependencies added: semigroups

Dependency ranges changed: containers, intern

API changes (from Hackage documentation)

Files

• src/Data/Interned/URI.hs +14/−5
• src/Data/LookupMap.hs +368/−0
• src/Data/Ord/Partial.hs +367/−0
• src/Data/String/ShowLines.hs +73/−0
• src/Swish.hs +264/−13
• src/Swish/Commands.hs +406/−0
• src/Swish/Datatype.hs +1074/−0
• src/Swish/GraphClass.hs +220/−0
• src/Swish/GraphMatch.hs +675/−0
• src/Swish/GraphMem.hs +172/−0
• src/Swish/GraphPartition.hs +591/−0
• src/Swish/Monad.hs +262/−0
• src/Swish/Namespace.hs +244/−0
• src/Swish/Proof.hs +293/−0
• src/Swish/QName.hs +328/−0
• src/Swish/RDF.hs +6/−5
• src/Swish/RDF/BuiltIn.hs +53/−0
• src/Swish/RDF/BuiltIn/Datatypes.hs +81/−0
• src/Swish/RDF/BuiltIn/Rules.hs +153/−0
• src/Swish/RDF/BuiltInDatatypes.hs +0/−76
• src/Swish/RDF/BuiltInMap.hs +0/−52
• src/Swish/RDF/BuiltInRules.hs +0/−157
• src/Swish/RDF/ClassRestrictionRule.hs +28/−29
• src/Swish/RDF/Datatype.hs +184/−1044
• src/Swish/RDF/Datatype/XSD/Decimal.hs +486/−0
• src/Swish/RDF/Datatype/XSD/Integer.hs +530/−0
• src/Swish/RDF/Datatype/XSD/MapDecimal.hs +72/−0
• src/Swish/RDF/Datatype/XSD/MapInteger.hs +70/−0
• src/Swish/RDF/Datatype/XSD/String.hs +327/−0
• src/Swish/RDF/Formatter/N3.hs +943/−0
• src/Swish/RDF/Formatter/NTriples.hs +233/−0
• src/Swish/RDF/Formatter/Turtle.hs +877/−0
• src/Swish/RDF/Graph.hs +1458/−0
• src/Swish/RDF/GraphClass.hs +0/−248
• src/Swish/RDF/GraphMatch.hs +0/−622
• src/Swish/RDF/GraphMem.hs +0/−166
• src/Swish/RDF/GraphPartition.hs +0/−570
• src/Swish/RDF/GraphShowLines.hs +59/−0
• src/Swish/RDF/MapXsdDecimal.hs +0/−72
• src/Swish/RDF/MapXsdInteger.hs +0/−69
• src/Swish/RDF/N3Formatter.hs +0/−941
• src/Swish/RDF/N3Parser.hs +0/−1145
• src/Swish/RDF/NTFormatter.hs +0/−247
• src/Swish/RDF/NTParser.hs +0/−427
• src/Swish/RDF/Parser/N3.hs +1190/−0
• src/Swish/RDF/Parser/NTriples.hs +410/−0
• src/Swish/RDF/Parser/Turtle.hs +1077/−0
• src/Swish/RDF/Parser/Utils.hs +385/−0
• src/Swish/RDF/Proof.hs +296/−218
• src/Swish/RDF/ProofContext.hs +852/−0
• src/Swish/RDF/Query.hs +651/−0
• src/Swish/RDF/RDFDatatype.hs +0/−202
• src/Swish/RDF/RDFDatatypeXsdDecimal.hs +0/−487
• src/Swish/RDF/RDFDatatypeXsdInteger.hs +0/−539
• src/Swish/RDF/RDFDatatypeXsdString.hs +0/−333
• src/Swish/RDF/RDFGraph.hs +0/−1396
• src/Swish/RDF/RDFGraphShowM.hs +0/−57
• src/Swish/RDF/RDFParser.hs +0/−353
• src/Swish/RDF/RDFProof.hs +0/−380
• src/Swish/RDF/RDFProofContext.hs +0/−848
• src/Swish/RDF/RDFQuery.hs +0/−636
• src/Swish/RDF/RDFRuleset.hs +0/−546
• src/Swish/RDF/RDFVarBinding.hs +0/−187
• src/Swish/RDF/Rule.hs +0/−247
• src/Swish/RDF/Ruleset.hs +475/−108
• src/Swish/RDF/SwishCommands.hs +0/−422
• src/Swish/RDF/SwishMain.hs +0/−291
• src/Swish/RDF/SwishMonad.hs +0/−270
• src/Swish/RDF/SwishScript.hs +0/−1512
• src/Swish/RDF/TurtleFormatter.hs +0/−879
• src/Swish/RDF/TurtleParser.hs +0/−1062
• src/Swish/RDF/VarBinding.hs +109/−468
• src/Swish/RDF/Vocabulary.hs +125/−32
• src/Swish/RDF/Vocabulary/DublinCore.hs +3/−8
• src/Swish/RDF/Vocabulary/FOAF.hs +3/−4
• src/Swish/RDF/Vocabulary/Geo.hs +3/−4
• src/Swish/RDF/Vocabulary/OWL.hs +3/−4
• src/Swish/RDF/Vocabulary/Provenance.hs +3/−4
• src/Swish/RDF/Vocabulary/RDF.hs +14/−6
• src/Swish/RDF/Vocabulary/SIOC.hs +3/−4
• src/Swish/RDF/Vocabulary/XSD.hs +3/−4
• src/Swish/Rule.hs +253/−0
• src/Swish/Ruleset.hs +174/−0
• src/Swish/Script.hs +1500/−0
• src/Swish/Utils/ListHelpers.hs +10/−268
• src/Swish/Utils/LookupMap.hs +0/−454
• src/Swish/Utils/MiscHelpers.hs +0/−69
• src/Swish/Utils/Namespace.hs +0/−222
• src/Swish/Utils/PartOrderedCollection.hs +0/−386
• src/Swish/Utils/QName.hs +0/−277
• src/Swish/Utils/ShowM.hs +0/−75
• src/Swish/VarBinding.hs +544/−0
• swish.cabal +95/−157
• tests/BuiltInMapTest.hs +9/−14
• tests/GraphPartitionTest.hs +105/−91
• tests/GraphTest.hs +52/−34
• tests/LookupMapTest.hs +13/−103
• tests/N3FormatterTest.hs +16/−21
• tests/N3ParserTest.hs +33/−33
• tests/NTTest.hs +20/−21
• tests/QNameTest.hs +16/−11
• tests/RDFDatatypeXsdIntegerTest.hs +39/−32
• tests/RDFGraphTest.hs +59/−54
• tests/RDFProofContextTest.hs +19/−16
• tests/RDFProofTest.hs +13/−20
• tests/RDFQueryTest.hs +23/−23
• tests/RDFRulesetTest.hs +15/−15
• tests/VarBindingTest.hs +1/−1

@@ -1,16 +1,18 @@-{-# LANGUAGE TypeFamilies, FlexibleInstances #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE FlexibleInstances #-}  -------------------------------------------------------------------------------- --  See end of this file for licence information. -------------------------------------------------------------------------------- -- | --  Module      :  URI---  Copyright   :  (c) 2011 Douglas Burke+--  Copyright   :  (c) 2011, 2012 Douglas Burke --  License     :  GPL V2 -- --  Maintainer  :  Douglas Burke --  Stability   :  experimental---  Portability :  TypeFamilies, FlexibleInstances+--  Portability :  CPP, TypeFamilies, FlexibleInstances -- --  Support interning URIs. --@@ -27,7 +29,10 @@  import Network.URI --- Could look at adding UNPACK statements before each component+-- Could look at adding UNPACK statements before the Int component++-- | An interned URI. The hashing is based on the+-- reversed URI (as a string). data InternedURI = InternedURI !Int !URI  instance IsString InternedURI where@@ -50,7 +55,10 @@   data Description InternedURI = DU !URI deriving (Eq) -- DU {-# UNPACK #-} !URI deriving (Eq)    describe = DU   identify = InternedURI+#if MIN_VERSION_intern(0,9,0)+#else   identity (InternedURI i _) = i+#endif   cache = iuCache  instance Uninternable InternedURI where@@ -68,7 +76,8 @@  -------------------------------------------------------------------------------- -----  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke --  All rights reserved. -- --  This file is part of Swish.

@@ -0,0 +1,368 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE DeriveFoldable #-}+{-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveTraversable #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  LookupMap+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  A lot of LANGUAGE extensions...+--+--  This module defines a lookup table format and associated functions+--  used by the graph matching code.+--+--------------------------------------------------------------------------------++------------------------------------------------------------+--  Generic list-of-pairs lookup functions+------------------------------------------------------------++module Data.LookupMap+    ( LookupEntryClass(..), LookupMap(..)+    , emptyLookupMap, makeLookupMap, listLookupMap+    , reverseLookupMap+    , keyOrder+    , mapFind, mapFindMaybe, mapContains+    , mapReplace, mapReplaceAll, mapReplaceMap+    , mapAdd, mapAddIfNew+    , mapDelete, mapDeleteAll+    , mapEq, mapKeys, mapVals+    , mapMerge+    )+    where++import Control.Arrow (first, second)++import Data.Maybe (fromMaybe)+import Data.Function (on)+import Data.Ord (comparing)++import Swish.Utils.ListHelpers (equiv)++import qualified Data.Foldable as F+import qualified Data.Traversable as T+import qualified Data.List as L++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701)+import Data.Tuple (swap)+#else+swap :: (a,b) -> (b,a)+swap (a,b) = (b,a)+#endif++------------------------------------------------------------+--  Class for lookup map entries+------------------------------------------------------------++-- |@LookupEntryClass@ defines essential functions of any datatype+--  that can be used to make a 'LookupMap'.+--+--  Minimal definition: @newEntry@ and @keyVal@+--+class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v+    where+        newEntry    :: (k,v) -> a+        keyVal      :: a -> (k,v)+        +        entryKey    :: a -> k+        entryKey = fst . keyVal+        +        entryVal    :: a -> v+        entryVal = snd . keyVal+                             +        entryEq     :: (Eq v) => a -> a -> Bool+        entryEq e1 e2 = keyVal e1 == keyVal e2+        +        entryShow   :: (Show v) => a -> String+        entryShow e = show k ++ ":" ++ show v where (k,v) = keyVal e+                                                    +        kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2+        kmap f = newEntry . first f . keyVal+        +        vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2+        vmap f = newEntry . second f . keyVal++-- |Predefine a pair of appropriate values as a valid lookup table entry+--  (i.e. an instance of LookupEntryClass).+--+instance (Eq k, Show k) => LookupEntryClass (k,v) k v where+    newEntry = id+    keyVal   = id++--  Note:  the class constraint that a is an instance of 'LookupEntryClass'+--  is not defined here, for good reasons (which I forget right now, but+--  something to do with the method dictionary being superfluous on+--  an algebraic data type).++-- |Define a lookup map based on a list of values.+--+data LookupMap a = LookupMap [a]+  deriving (Functor, F.Foldable, T.Traversable)++{-++To allow this Monoid instance, we would need UndecidableInstances.+Also, mapMerge can error out which is not what we would want.++instance (LookupEntryClass a k v, Eq a, Show a, Ord k) => Monoid (LookupMap a) where+    mempty = LookupMap []+    mappend = mapMerge++We could use the following (perhaps with a L.nub on the result before sticling back+into LookupMap) but it is unclear what the semantics are for repeated keys; it is+likely to be left-biased but would leave duplicate keys in the list which could+cause confusion at a later time (e.g. key removal). Many of the routines assume a single+key (or single key,value) pair.++instance (Eq a) => Monoid (LookupMap a) where+    mempty = LookupMap []+    (LookupMap a) `mappend` (LookupMap b) =+        LookupMap (a `mappend` b))+-}++gLM :: LookupMap a -> [a]+gLM (LookupMap es) = es++-- |Define equality of 'LookupMap' values based on equality of entries.+--+--  (This is possibly a poor definition, as it is dependent on ordering+--  of list members.  But it passes all current test cases, and is used+--  only for testing.)+--+instance (Eq a) => Eq (LookupMap a) where+    (==) = (==) `on` gLM++-- |Define Show instance for LookupMap based on Showing the+-- list of entries.+--+instance (Show a ) => Show (LookupMap a) where+    show (LookupMap es) = "LookupMap " ++ show es++-- |Empty lookup map of arbitrary (i.e. polymorphic) type.+--+emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a+emptyLookupMap = LookupMap []++-- |Function to create a `LookupMap` from a list of entries.+--+makeLookupMap :: +    (LookupEntryClass a k v) +    => [a]  -- ^ This list is not checked for duplicate entries, or+            -- entries with the same key but different values.+    -> LookupMap a+makeLookupMap = LookupMap++-- |Returns a list of lookup map entries.+--+listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a]+listLookupMap = gLM++-- |Given a lookup map entry, return a new entry that can be used+--  in the reverse direction of lookup.  This is used to construct+--  a reverse LookupMap.+--+reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k)+    => a1 -> a2+reverseEntry = newEntry . swap . keyVal++-- |Given a lookup map, return a new map that can be used+--  in the opposite direction of lookup.+--+reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b)+    => LookupMap a1 -> LookupMap a2+reverseLookupMap = fmap reverseEntry++-- |Given a pair of lookup entry values, return the ordering of their+--  key values.+--+keyOrder :: (LookupEntryClass a k v, Ord k)+    =>  a -> a -> Ordering+keyOrder = comparing entryKey++-- |Find key in lookup map and return corresponding value,+--  otherwise return default supplied.+--+mapFind :: +    (LookupEntryClass a k v) +    => v    -- ^ The default value.+    -> k +    -> LookupMap a -> v+mapFind def key = fromMaybe def . mapFindMaybe key++-- |Find key in lookup map and return Just the corresponding value,+--  otherwise return Nothing.+--+mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v+mapFindMaybe key (LookupMap es) = foldr match Nothing es where+    match ent alt+        | key ==  entryKey ent  = Just (entryVal ent)+        | otherwise             = alt++-- |Test to see if key is present in the supplied map+--+mapContains :: (LookupEntryClass a k v) =>+    LookupMap a -> k -> Bool+mapContains (LookupMap es) key  = any match es where+    match ent = key == entryKey ent++-- |Replace the first occurrence of a key a with a new key-value pair,+--  or add a new key-value pair if the supplied key is not already present.+--+mapReplace :: (LookupEntryClass a k v) =>+    LookupMap a -> a -> LookupMap a+mapReplace (LookupMap []) newe      = LookupMap [newe]+mapReplace (LookupMap (e:es)) newe+    | entryKey e == entryKey newe   = LookupMap (newe:es)+    | otherwise                     = mapAdd more e where+        more = mapReplace (LookupMap es) newe++-- |Replace all occurrence of a key a with a new key-value pair.+--+--  The resulting lookup map has the same form as the original in all+--  other respects.+--+mapReplaceAll :: (LookupEntryClass a k v) =>+    LookupMap a -> a -> LookupMap a+mapReplaceAll l@(LookupMap []) _        = l+mapReplaceAll (LookupMap (e:es)) newe   = mapAdd more e' where+    more = mapReplaceAll (LookupMap es) newe+    e'   = if entryKey e == entryKey newe then newe else e++-- |Replace any occurrence of a key in the first argument with a+--  corresponding key-value pair from the second argument, if present.+--+--  This could be implemented by multiple applications of 'mapReplaceAll',+--  but is arranged differently so that only one new @LookupMap@ value is+--  created.+--+--  Note:  keys in the new map that are not present in the old map+--  are not included in the result map+--+mapReplaceMap :: (LookupEntryClass a k v) =>+    LookupMap a -> LookupMap a -> LookupMap a+mapReplaceMap l@(LookupMap []) _ = l+mapReplaceMap (LookupMap (e:es)) newmap = mapAdd more e' where+    more  = mapReplaceMap (LookupMap es) newmap+    e'    = newEntry (k, mapFind v k newmap)+    (k,v) = keyVal e++-- |Add supplied key-value pair to the lookup map.+--+--  This is effectively an optimized case of 'mapReplace' or 'mapAddIfNew',+--  where the caller guarantees to avoid duplicate key values.+--+mapAdd :: LookupMap a -> a -> LookupMap a+mapAdd (LookupMap es) e = LookupMap (e:es)++-- |Add supplied key-value pair to the lookup map,+--  only if the key value is not already present.+--+mapAddIfNew :: (LookupEntryClass a k v) =>+    LookupMap a -> a -> LookupMap a+mapAddIfNew emap e = if mapContains emap (entryKey e)+                        then emap+                        else mapAdd emap e++-- |Delete the first occurrence of the key from the lookup map.+--+--  If the key does not exist in the map then no change is made.+--+mapDelete :: (LookupEntryClass a k v) =>+    LookupMap a -> k -> LookupMap a+mapDelete l@(LookupMap []) _ = l+mapDelete (LookupMap (e:es)) k+    | k == entryKey e   = LookupMap es+    | otherwise         = mapAdd more e where+        more = mapDelete (LookupMap es) k++-- |Delete all occurrences of the key from the lookup map.+--+mapDeleteAll :: (LookupEntryClass a k v) =>+    LookupMap a -> k -> LookupMap a+mapDeleteAll l@(LookupMap []) _ = l+mapDeleteAll (LookupMap (e:es)) k =+    let more = mapDeleteAll (LookupMap es) k+    in if entryKey e == k then more else mapAdd more e+        +-- |Compare two lookup maps for equality.+--+--  Two maps are equal if they have the same set of keys, and if+--  each key maps to an equivalent value. This is only guaranteed+--  if the maps do not contain duplicate entries.+--+mapEq :: (LookupEntryClass a k v, Eq v) =>+    LookupMap a -> LookupMap a -> Bool+mapEq es1 es2 =+    ks1 `equiv` ks2 &&+    and [ mapFindMaybe k es1 == mapFindMaybe k es2 | k <- ks1 ]+    where+        ks1 = mapKeys es1+        ks2 = mapKeys es2++-- |Return the list of distinct keys in a supplied LookupMap+--+mapKeys :: (LookupEntryClass a k v) =>+    LookupMap a -> [k]+mapKeys = L.nub . gLM . fmap entryKey++-- |Return list of distinct values in a supplied LookupMap+--+mapVals :: (Eq v, LookupEntryClass a k v) =>+    LookupMap a -> [v]+mapVals = L.nub . gLM . fmap entryVal++-- |Merge two lookup maps, ensuring that if the same key appears+--  in both maps it is associated with the same value.+--+mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) =>+    LookupMap a -> LookupMap a -> LookupMap a+mapMerge a b = LookupMap $ on merge (L.sortBy keyOrder . gLM) a b+    where+        merge es1 [] = es1+        merge [] es2 = es2+        merge es1@(e1:et1) es2@(e2:et2) =+            case keyOrder e1 e2 of+                LT -> e1 : merge et1 es2+                GT -> e2 : merge es1 et2+                EQ -> if e1 /= e2+                        then error ("mapMerge key conflict: " ++ show e1+                                    ++ " with " ++ show e2)+                        else e1 : merge et1 et2++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

@@ -0,0 +1,367 @@+--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  Partial+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  H98+--+--  This module provides methods to support operations on partially ordered+--  collections.  The partial ordering relationship is represented by+--  'Maybe' 'Ordering'.+--+--  Thanks to members of the haskell-cafe mailing list -+--    Robert (rvollmert-lists\@gmx.net) and+--    Tom Pledger (Tom.Pledger\@peace.com) -+--  who suggested key ideas on which some of the code in this module is based.+--+--------------------------------------------------------------------------------++-- at present the only user of this module is Swish.RDF.ClassRestrictionRule++module Data.Ord.Partial+    ( PartCompare+      -- * Finding the range of a part-ordered list+    , minima+    , maxima+      -- * Comparing part-ordered containers+    , partCompareEq+    , partComparePair+    , partCompareListMaybe+    , partCompareListSubset+    )+    where++import Data.List (foldl')++------------------------------------------------------------+--  Type of partial compare function+------------------------------------------------------------++-- | Partial comparison function.+type PartCompare a = a -> a -> Maybe Ordering++------------------------------------------------------------+--  Functions for minima and maxima of a part-ordered list+------------------------------------------------------------++-- |This function finds the maxima in a list of partially+--  ordered values, preserving the sequence of retained+--  values from the supplied list.+--+--  It returns all those values in the supplied list+--  for which there is no larger element in the list.+--+maxima :: PartCompare a -> [a] -> [a]+maxima cmp = foldl' add [] +    where+        add []     e = [e]+        add ms@(m:mr) e = case cmp m e of+            Nothing -> m : add mr e+            Just GT -> ms+            Just EQ -> ms+            Just LT -> add mr e++-- |This function finds the minima in a list of partially+--  ordered values, preserving the sequence of retained+--  values from the supplied list.+--+--  It returns all those values in the supplied list+--  for which there is no smaller element in the list.+--+minima :: PartCompare a -> [a] -> [a]+minima cmp = maxima (flip cmp)++------------------------------------------------------------+--  Partial ordering comparison functions+------------------------------------------------------------++-- |Partial ordering for Eq values+partCompareEq :: (Eq a) => PartCompare a+partCompareEq a1 a2 = if a1 == a2 then Just EQ else Nothing++-- |Part-ordering comparison on pairs of values,+--  where each has a part-ordering relationship+partComparePair ::+    PartCompare a+    -> PartCompare b+    -> (a,b) +    -> (a,b)+    -> Maybe Ordering+partComparePair cmpa cmpb (a1,b1) (a2,b2) = case (cmpa a1 a2,cmpb b1 b2) of+    (_,Nothing)       -> Nothing+    (jc1,Just EQ)     -> jc1+    (Nothing,_)       -> Nothing+    (Just EQ,jc2)     -> jc2+    (Just c1,Just c2) -> if c1 == c2 then Just c1 else Nothing++-- |Part-ordering comparison on lists of partially ordered values, where:+--+--  [@as==bs@]  if members of as are all equal to corresponding members of bs+--    +--  [@as<=bs@]  if members of as are all less than or equal to corresponding+--          members of bs+--    +--  [@as>=bs@]  if members of as are all greater than or equal to corresponding+--          members of bs+--    +--  [otherwise] as and bs are unrelated+--+--  The comparison is restricted to the common elements in the two lists.+--+partCompareListPartOrd :: PartCompare a -> [a] -> [a] -> Maybe Ordering+partCompareListPartOrd cmp a1s b1s = pcomp a1s b1s EQ+    where+        pcomp (a:as) (b:bs) ordp = case cmp a b of+            Just rel  -> pcomp1 as bs rel ordp+            _         -> Nothing+        pcomp _      _      ordp = Just ordp+        -- pcomp []     []     ordp = Just ordp+        +        pcomp1 as bs ordn EQ   = pcomp as bs ordn+        pcomp1 as bs EQ   ordp = pcomp as bs ordp+        pcomp1 as bs ordn ordp =+            if ordn == ordp then pcomp as bs ordp else Nothing+                                                       +-- |Part-ordering comparison for Maybe values.+partCompareMaybe :: (Eq a) => Maybe a -> Maybe a -> Maybe Ordering+partCompareMaybe Nothing  Nothing  = Just EQ+partCompareMaybe (Just _) Nothing  = Just GT+partCompareMaybe Nothing  (Just _) = Just LT+partCompareMaybe (Just a) (Just b) = if a == b then Just EQ else Nothing++-- |Part-ordering comparison on lists of Maybe values.+partCompareListMaybe :: (Eq a) => [Maybe a] -> [Maybe a] -> Maybe Ordering+partCompareListMaybe = partCompareListPartOrd partCompareMaybe++-- |Part-ordering comparison on lists based on subset relationship+partCompareListSubset :: (Eq a) => [a] -> [a] -> Maybe Ordering+partCompareListSubset a b+    | aeqvb     = Just EQ+    | asubb     = Just LT+    | bsuba     = Just GT+    | otherwise = Nothing+    where+        asubb = a `subset` b+        bsuba = b `subset` a+        aeqvb = asubb && bsuba+        x `subset` y = and [ ma `elem` y | ma <- x ]++------------------------------------------------------------+--  Test cases+------------------------------------------------------------++{-++notTrueFalse  = Nothing :: Maybe Bool++-- partCompareListOrd+test01 = partCompareListOrd [1,2,3] [1,2,3] == Just EQ+test02 = partCompareListOrd [1,2,3] [2,3,4] == Just LT+test03 = partCompareListOrd [1,2,4] [1,2,3] == Just GT+test04 = partCompareListOrd [1,2,3] [2,1,3] == Nothing++-- partCompareMaybe+test11 = partCompareMaybe (Just True)  (Just True)  == Just EQ+test12 = partCompareMaybe (Just True)  (Just False) == Nothing+test13 = partCompareMaybe notTrueFalse (Just False) == Just LT+test14 = partCompareMaybe (Just True)  notTrueFalse == Just GT+test15 = partCompareMaybe notTrueFalse notTrueFalse == Just EQ++-- partCompareListMaybe+test21 = partCompareListMaybe [Just True,Just False]+                              [Just True,Just False]+            == Just EQ+test22 = partCompareListMaybe [Just True,Just False]+                              [Just True,Just True]+            == Nothing+test23 = partCompareListMaybe [Just False,Just True]+                              [Just False,Just True]+            == Just EQ+test24 = partCompareListMaybe [Nothing,   Just True]+                              [Just False,Just True]+            == Just LT+test25 = partCompareListMaybe [Just False,Just True]+                              [Just False,Nothing]+            == Just GT+test26 = partCompareListMaybe [Nothing,   Just True]+                              [Just False,Nothing]+            == Nothing+test27 = partCompareListMaybe [Nothing,Just True]+                              [Nothing,Nothing]+            == Just GT+test28 = partCompareListMaybe [notTrueFalse,notTrueFalse]+                              [notTrueFalse,notTrueFalse]+            == Just EQ++--  minima, maxima+test31a = maxima partCompareListMaybe ds1a == ds1b+test31b = minima partCompareListMaybe ds1a == ds1c+ds1a =+    [ [Just 'a',Just 'b',Just 'c']+    , [Just 'a',Just 'b',Nothing ]+    , [Just 'a',Nothing ,Just 'c']+    , [Just 'a',Nothing ,Nothing ]+    , [Nothing ,Just 'b',Just 'c']+    , [Nothing ,Just 'b',Nothing ]+    , [Nothing ,Nothing ,Just 'c']+    , [Nothing ,Nothing ,Nothing ]+    ]+ds1b =+    [ [Just 'a',Just 'b',Just 'c']+    ]+ds1c =+    [ [Nothing ,Nothing ,Nothing ]+    ]++test32a = maxima partCompareListMaybe ds2a == ds2b+test32b = minima partCompareListMaybe ds2a == ds2c+ds2a =+    [ [Just 'a',Just 'b',Nothing ]+    , [Just 'a',Nothing ,Just 'c']+    , [Just 'a',Nothing ,Nothing ]+    , [Nothing ,Just 'b',Just 'c']+    , [Nothing ,Just 'b',Nothing ]+    , [Nothing ,Nothing ,Just 'c']+    ]+ds2b =+    [ [Just 'a',Just 'b',Nothing ]+    , [Just 'a',Nothing ,Just 'c']+    , [Nothing ,Just 'b',Just 'c']+    ]+ds2c =+    [ [Just 'a',Nothing ,Nothing ]+    , [Nothing ,Just 'b',Nothing ]+    , [Nothing ,Nothing ,Just 'c']+    ]++test33a = maxima partCompareListMaybe ds3a == ds3b+test33b = minima partCompareListMaybe ds3a == ds3c+ds3a =+    [ [Just "a1",Just "b1",Just "c1"]+    , [Just "a2",Just "b2",Nothing  ]+    , [Just "a3",Nothing  ,Just "c3"]+    , [Just "a4",Nothing  ,Nothing  ]+    , [Nothing  ,Just "b5",Just "c5"]+    , [Nothing  ,Just "b6",Nothing  ]+    , [Nothing  ,Nothing  ,Just "c7"]+    ]+ds3b =+    [ [Just "a1",Just "b1",Just "c1"]+    , [Just "a2",Just "b2",Nothing  ]+    , [Just "a3",Nothing  ,Just "c3"]+    , [Just "a4",Nothing  ,Nothing  ]+    , [Nothing  ,Just "b5",Just "c5"]+    , [Nothing  ,Just "b6",Nothing  ]+    , [Nothing  ,Nothing  ,Just "c7"]+    ]+ds3c =+    [ [Just "a1",Just "b1",Just "c1"]+    , [Just "a2",Just "b2",Nothing  ]+    , [Just "a3",Nothing  ,Just "c3"]+    , [Just "a4",Nothing  ,Nothing  ]+    , [Nothing  ,Just "b5",Just "c5"]+    , [Nothing  ,Just "b6",Nothing  ]+    , [Nothing  ,Nothing  ,Just "c7"]+    ]+++test34a = maxima partCompareListMaybe ds4a == ds4b+test34b = minima partCompareListMaybe ds4a == ds4c+ds4a =+    [ [Just 1, Just 1 ]+    , [Just 2, Nothing]+    , [Nothing,Just 3 ]+    , [Nothing,Nothing]+    ]+ds4b =+    [ [Just 1, Just 1 ]+    , [Just 2, Nothing]+    , [Nothing,Just 3 ]+    ]+ds4c =+    [ [Nothing,Nothing]+    ]++-- Check handling of equal values+test35a = maxima partCompareListMaybe ds5a == ds5b+test35b = minima partCompareListMaybe ds5a == ds5c+ds5a =+    [ [Just 1, Just 1 ]+    , [Just 2, Nothing]+    , [Nothing,Just 3 ]+    , [Nothing,Nothing]+    , [Just 1, Just 1 ]+    , [Just 2, Nothing]+    , [Nothing,Just 3 ]+    , [Nothing,Nothing]+    ]+ds5b =+    [ [Just 1, Just 1 ]+    , [Just 2, Nothing]+    , [Nothing,Just 3 ]+    ]+ds5c =+    [ [Nothing,Nothing]+    ]++-- test case 32 with different ordering of values+test36a = maxima partCompareListMaybe ds6a == ds6b+test36b = minima partCompareListMaybe ds6a == ds6c+ds6a =+    [ [Just 'a',Just 'b',Nothing ]+    , [Nothing ,Nothing ,Just 'c']+    , [Nothing ,Just 'b',Nothing ]+    , [Nothing ,Just 'b',Just 'c']+    , [Just 'a',Nothing ,Nothing ]+    , [Just 'a',Nothing ,Just 'c']+    ]+ds6b =+    [ [Just 'a',Just 'b',Nothing ]+    , [Nothing ,Just 'b',Just 'c']+    , [Just 'a',Nothing ,Just 'c']+    ]+ds6c =+    [ [Nothing ,Nothing ,Just 'c']+    , [Nothing ,Just 'b',Nothing ]+    , [Just 'a',Nothing ,Nothing ]+    ]++test = and+    [ test01, test02, test03, test04+    , test11, test12, test13, test14, test15+    , test21, test22, test23, test24, test25, test26, test27, test28+    , test31a, test31b, test32a, test32b, test33a, test33b+    , test34a, test34b, test35a, test35b, test36a, test36b+    ]++-}++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

@@ -0,0 +1,73 @@+--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  ShowLines+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  H98+--+--  This module defines an extension of the 'Show' class for displaying+--  multi-line values.  It serves the following purposes:+--+--  (1) provides a method with greater layout control of multiline values,+--+--  (2) provides a possibility to override the default 'Show' behaviour+--      for programs that use the extended 'ShowLines' interface, and+--+--  (3) uses a 'ShowS' intermediate value to avoid unnecessary+--      concatenation of long strings.+--+--------------------------------------------------------------------------------++module Data.String.ShowLines (ShowLines(..)) where++-- |ShowLines is a type class for values that may be formatted in+--  multi-line displays.+class (Show sh) => ShowLines sh where+    -- |Multi-line value display method+    --+    --  Create a multiline displayable form of a value, returned+    --  as a 'ShowS' value.  The default implementation behaves just+    --  like a normal instance of 'Show'.+    --+    --  This function is intended to allow the calling function some control+    --  of multiline displays by providing:+    --+    --  (1) the first line of the value is not preceded by any text, so+    --      it may be appended to some preceding text on the same line,+    --+    --  (2) the supplied line break string is used to separate lines of the+    --      formatted text, and may include any desired indentation, and+    --+    --  (3) no newline is output following the final line of text.+    showls :: String -> sh -> ShowS+    showls _ = shows++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | --  Module      :  Swish---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke --  License     :  GPL V2 -- --  Maintainer  :  Douglas Burke@@ -25,12 +25,13 @@ --  the lines described in [3]. -- --  The script format used by Swish is described in---  "Swish.RDF.SwishScript".+--  "Swish.Script". -- --  Users wishing to process RDF data directly may prefer to look at---  the following modules; "Swish.RDF", "Swish.RDF.TurtleParser",---  "Swish.RDF.N3Parser", "Swish.RDF.N3Formatter", "Swish.RDF.NTParser"---  and "Swish.RDF.NTFormatter".+--  the following modules; "Swish.RDF", "Swish.RDF.Parser.Turtle",+--  "Swish.RDF.Parser.N3", "Swish.RDF.Parser.NTriples",+--  "Swish.RDF.Formatter.Turtle", "Swish.RDF.Formatter.N3"+--  and "Swish.RDF.Formatter.NTriples". -- --  (1) Semantic web: <http://www.w3.org/2001/sw/> --@@ -44,19 +45,269 @@ -- --  (6) RDF:          <http://www.w3.org/RDF/> --+--  Notes+--+--  I anticipate that this module may be used as a starting point for+--  creating new programs rather then as a complete program in its own+--  right.  The functionality built into this code is selected with a+--  view to testing the Haskell modules for handling RDF rather than+--  for performing any particular application processing (though+--  development as a tool with some broader utility is not ruled out).+--+--  With the following in ghci:+--+-- >>> :m + Swish+-- >>> :set prompt "swish> "+--+-- then we can run a Swish script (format described in "Swish.Script")+-- by saying:+--+-- >>> runSwish "-s=script.ss"+-- ExitSuccess+--+-- or convert a file from Turtle to NTriples format with:+--+-- >>> runSwish "-ttl -i=foo.ttl -nt -o=foo.nt"+-- ExitSuccess+--+-- You can also use `validateCommands` by giving it the individual commands,+-- such as+--+-- >>> let Right cs = validateCommands ["-ttl", "-i=file1.ttl", "-c=file2.ttl"]+-- >>> cs+-- [SwishAction: -ttl,SwishAction: -i=file1.ttl,SwishAction: -c=file2.ttl]+-- >>> st <- runSwishActions cs+-- >>> st+-- The graphs do not compare as equal.+-- -------------------------------------------------------------------------------- -module Swish-       (-         module Swish.RDF.SwishMain-       ) where+module Swish ( SwishStatus(..)+             , SwishAction+             , runSwish+             , runSwishActions+             , displaySwishHelp+             , splitArguments+             , validateCommands+             ) where -import Swish.RDF.SwishMain--- should this re-export Swish.RDF.SwishMain or other components?-       +import Swish.Commands+    ( swishFormat+    , swishBase+    , swishInput+    , swishOutput+    , swishMerge+    , swishCompare+    , swishGraphDiff+    , swishScript+    )++import Swish.Monad (SwishStateIO, SwishState(..), SwishStatus(..)+                   , SwishFormat(..)+                   , emptyState)+import Swish.QName (qnameFromURI)+++import Control.Monad.State (execStateT)+import Control.Monad (liftM)++import Network.URI (parseURI)++import Data.Char (isSpace)+import Data.Either (partitionEithers)++import System.Exit (ExitCode(ExitSuccess, ExitFailure))++------------------------------------------------------------+--  Command line description+------------------------------------------------------------++-- we do not display the version in the help file to avoid having+-- to include the Paths_swish module (so that we can use this from+-- an interactive environment).+--++usageText :: [String]+usageText =+    [ "Swish: Read, merge, write, compare and process RDF graphs."+    , ""+    , "Usage: swish option option ..."+    , ""+    , "where the options are processed from left to right, and may be"+    , "any of the following:"+    , "-h        display this message."+    , "-?        display this message."+    , "-v        display Swish version and quit."+    , "-q        do not display Swish version on start up."+    , "-nt       use Ntriples format for subsequent input and output."+    , "-ttl      use Turtle format for subsequent input and output."+    , "-n3       use Notation3 format for subsequent input and output (default)"+    , "-i[=file] read file in selected format into the graph workspace,"+    , "          replacing any existing graph."+    , "-m[=file] merge file in selected format with the graph workspace."+    , "-c[=file] compare file in selected format with the graph workspace."+    , "-d[=file] show graph differences between the file in selected"+    , "          format and the graph workspace.  Differences are displayed"+    , "          to the standard output stream."+    , "-o[=file] write the graph workspace to a file in the selected format."+    , "-s[=file] read and execute Swish script commands from the named file."+    , "-b[=base] set or clear the base URI. The semantics of this are not"+    , "          fully defined yet."+    , ""+    , "    If an optional filename value is omitted, the standard input"+    , "    or output stream is used, as appropriate."+    , ""+    , "Exit status codes:"+    , "Success - operation completed successfully/graphs compare equal"+    , "1 - graphs compare different"+    , "2 - input data format error"+    , "3 - file access problem"+    , "4 - command line error"+    , "5 - script file execution error"+    , ""+    , "Examples:"+    , ""+    , "swish -i=file"+    , "    read file as Notation3, and report any syntax errors."+    , "swish -i=file1 -o=file2"+    , "    read file1 as Notation3, report any syntax errors, and output the"+    , "    resulting graph as reformatted Notation3 (the output format"+    , "    is not perfect but may be improved)."+    , "swish -nt -i=file -n3 -o"+    , "    read file as NTriples and output as Notation3 to the screen."+    , "swich -i=file1 -c=file2"+    , "    read file1 and file2 as notation3, report any syntax errors, and"+    , "    if both are OK, compare the resulting graphs to indicate whether"+    , "    or not they are equivalent."+    ]++-- | Write out the help for Swish+displaySwishHelp :: IO ()+displaySwishHelp = mapM_ putStrLn usageText++------------------------------------------------------------+--  Swish command line interpreter+------------------------------------------------------------+--+--  This is a composite monad combining some state with an IO+--  Monad.  lift allows a pure IO monad to be used as a step+--  of the computation.+--+        +-- | Return any arguments that need processing immediately, namely                     +-- the \"help\", \"quiet\" and \"version\" options.+--+splitArguments :: [String] -> ([String], [String])+splitArguments = partitionEithers . map splitArgument++splitArgument :: String -> Either String String+splitArgument "-?" = Left "-h"+splitArgument "-h" = Left "-h"+splitArgument "-v" = Left "-v"+splitArgument "-q" = Left "-q"+splitArgument x    = Right x++-- | Represent a Swish action. At present there is no way to create these+-- actions other than 'validateCommands'.+-- +newtype SwishAction = SA (String, SwishStateIO ())++instance Show SwishAction where+  show (SA (lbl,_)) = "SwishAction: " ++ lbl++-- | Given a list of command-line arguments create the list of actions+-- to perform or a string and status value indicating an input error.+validateCommands :: [String] -> Either (String, SwishStatus) [SwishAction]+validateCommands args = +  let (ls, rs) = partitionEithers (map validateCommand args)+  in case ls of+    (e:_) -> Left e+    []    -> Right rs+  +-- This allows you to say "-nt=foo" and currently ignores the values+-- passed through. This may change+--    +validateCommand :: String -> Either (String, SwishStatus) SwishAction+validateCommand cmd =+  let (nam,more) = break (=='=') cmd+      arg        = drop 1 more+      marg       = if null arg then Nothing else Just arg+      +      wrap f = Right $ SA (cmd, f marg)+      wrap1 f = Right $ SA (cmd, f)++  in case nam of+    "-ttl"  -> wrap1 $ swishFormat Turtle+    "-nt"   -> wrap1 $ swishFormat NT+    "-n3"   -> wrap1 $ swishFormat N3+    "-i"    -> wrap swishInput+    "-m"    -> wrap swishMerge+    "-c"    -> wrap swishCompare+    "-d"    -> wrap swishGraphDiff+    "-o"    -> wrap swishOutput+    "-b"    -> validateBase cmd marg+    "-s"    -> wrap swishScript+    _       -> Left ("Invalid command line argument: "++cmd, SwishArgumentError)++-- | Execute the given set of actions.+swishCommands :: [SwishAction] -> SwishStateIO ()+swishCommands = mapM_ swishCommand++-- | Execute an action.+swishCommand :: SwishAction -> SwishStateIO ()+swishCommand (SA (_,act)) = act++validateBase :: String -> Maybe String -> Either (String, SwishStatus) SwishAction+validateBase arg Nothing  = Right $ SA (arg, swishBase Nothing)+validateBase arg (Just b) =+  case parseURI b >>= qnameFromURI of+    j@(Just _) -> Right $ SA (arg, swishBase j)+    _      -> Left ("Invalid base URI <" ++ b ++ ">", SwishArgumentError)+  +------------------------------------------------------------+--  Interactive test function (e.g. for use in ghci)+------------------------------------------------------------++-- this ignores the "flags" options, namely+--    -q / -h / -? / -v++-- | Parse and run the given string as if given at the command+-- line. The \"quiet\", \"version\" and \"help\" options are+-- ignored.+--+runSwish :: String -> IO ExitCode+runSwish cmdline = do+  let args = breakAll isSpace cmdline+      (_, cmds) = splitArguments args+      +  case validateCommands cmds of+    Left (emsg, ecode) -> do+      putStrLn $ "Swish exit: " ++ emsg+      return $ ExitFailure $ fromEnum ecode+      +    Right acts -> do+      ec <- runSwishActions acts+      case ec of+        SwishSuccess -> return ExitSuccess+        _  -> do+          putStrLn $ "Swish exit: " ++ show ec+          return $ ExitFailure $ fromEnum ec++-- |Break list into a list of sublists, separated by element+--  satisfying supplied condition.+breakAll :: (a -> Bool) -> [a] -> [[a]]+breakAll _ [] = []+breakAll p s  = let (h,s') = break p s+                    in h : breakAll p (drop 1 s')++-- | Execute the given set of actions.+runSwishActions :: [SwishAction] -> IO SwishStatus+runSwishActions acts = exitcode `liftM` execStateT (swishCommands acts) emptyState+ -------------------------------------------------------------------------------- -----  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke --  All rights reserved. -- --  This file is part of Swish.

@@ -0,0 +1,406 @@+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  Commands+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  OverloadedStrings+--+--  Functions to deal with indivudual Swish command options.+--+--------------------------------------------------------------------------------++module Swish.Commands+    ( swishFormat+    , swishBase+    -- , swishVerbose+    , swishInput+    , swishOutput+    , swishMerge+    , swishCompare+    , swishGraphDiff+    , swishScript+    )+where++import Swish.GraphClass (LDGraph(..), Label(..))+import Swish.GraphPartition (GraphPartition(..))+import Swish.GraphPartition (partitionGraph, comparePartitions, partitionShowP)+import Swish.Monad (SwishStateIO, SwishState(..)+                   , SwishStatus(..), SwishFormat(..)+                   , setFormat, setBase, setGraph, resetInfo+                   , resetError, setStatus, swishError, reportLine)+import Swish.QName (QName, qnameFromURI, qnameFromFilePath, getQNameURI)+import Swish.Script (parseScriptFromText)++import Swish.RDF.Graph (RDFGraph, merge)++import qualified Swish.RDF.Formatter.Turtle as TTLF+import qualified Swish.RDF.Formatter.N3 as N3F+import qualified Swish.RDF.Formatter.NTriples as NTF++import Swish.RDF.Parser.Turtle (parseTurtle)+import Swish.RDF.Parser.N3 (parseN3)+import Swish.RDF.Parser.NTriples (parseNT)+import Swish.RDF.Parser.Utils (appendURIs)++import System.IO+    ( Handle, IOMode(..)+    , hPutStr, hPutStrLn, hClose+    , hIsReadable, hIsWritable+    , openFile, stdin, stdout+    )++import Network.URI (parseURIReference)++import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.State (modify, gets)+import Control.Monad (liftM, when)++import qualified Data.Text.Lazy as T+import qualified Data.Text.Lazy.IO as IO++import Data.Maybe (isJust, fromMaybe)++import Control.Exception as CE++-- | Set the file format.+--+swishFormat :: SwishFormat -> SwishStateIO ()+swishFormat = modify . setFormat++-- | Set (or clear) the base URI.+swishBase :: Maybe QName -> SwishStateIO ()+swishBase = modify . setBase++-- | Read in a graph and make it the current graph.+swishInput :: +    Maybe String       -- ^ A filename or, if 'Nothing', then use standard input.+    -> SwishStateIO ()+swishInput fnam =+  swishReadGraph fnam >>= maybe (return ()) (modify . setGraph)+  +-- | Read in a graph and merge it with the current graph.+swishMerge :: +    Maybe String       -- ^ A filename or, if 'Nothing', then use standard input.+    -> SwishStateIO ()+swishMerge fnam =+  swishReadGraph fnam >>= maybe (return ()) (modify . mergeGraph)+    +mergeGraph :: RDFGraph -> SwishState -> SwishState+mergeGraph gr state = state { graph = newgr }+    where+        newgr = merge gr (graph state)++-- | Read in a graph and compare it with the current graph.+swishCompare ::+    Maybe String       -- ^ A filename or, if 'Nothing', then use standard input.+    -> SwishStateIO ()+swishCompare fnam =+  swishReadGraph fnam >>= maybe (return ()) compareGraph+    +compareGraph :: RDFGraph -> SwishStateIO ()+compareGraph gr = do+  oldGr <- gets graph+  let exitCode = if gr == oldGr then SwishSuccess else SwishGraphCompareError+  modify $ setStatus exitCode+  +------------------------------------------------------------+--  Display graph differences from named file+------------------------------------------------------------++-- | Read in a graph and display the differences to the current+-- graph to standard output.+swishGraphDiff ::+    Maybe String       -- ^ A filename or, if 'Nothing', then use standard input.+    -> SwishStateIO ()+swishGraphDiff fnam =+  swishReadGraph fnam >>= maybe (return ()) diffGraph++diffGraph :: RDFGraph -> SwishStateIO ()+diffGraph gr = do+  oldGr <- gets graph+  let p1 = partitionGraph (getArcs oldGr)+      p2 = partitionGraph (getArcs gr)+      diffs = comparePartitions p1 p2+      +  swishWriteFile (swishOutputDiffs diffs) Nothing+  +swishOutputDiffs :: (Label lb) =>+    [(Maybe (GraphPartition lb),Maybe (GraphPartition lb))]+    -> Maybe String +    -> Handle+    -> SwishStateIO ()+swishOutputDiffs diffs fnam hnd = do+  lift $ hPutStrLn hnd ("Graph differences: "++show (length diffs))+  mapM_ (swishOutputDiff fnam hnd) (zip [1..] diffs)++swishOutputDiff :: (Label lb) =>+    Maybe String +    -> Handle+    -> (Int,(Maybe (GraphPartition lb),Maybe (GraphPartition lb)))+    -> SwishStateIO ()+swishOutputDiff fnam hnd (diffnum,(part1,part2)) = do+  lift $ hPutStrLn hnd ("---- Difference "++show diffnum++" ----")+  lift $ hPutStr hnd "Graph 1:"+  swishOutputPart fnam hnd part1+  lift $ hPutStr hnd "Graph 2:"+  swishOutputPart fnam hnd part2++swishOutputPart :: (Label lb) =>+    Maybe String +    -> Handle +    -> Maybe (GraphPartition lb) +    -> SwishStateIO ()+swishOutputPart _ hnd part = +  let out = maybe "\n(No arcs)" (partitionShowP "\n") part+  in lift $ hPutStrLn hnd out++------------------------------------------------------------+--  Execute script from named file+------------------------------------------------------------++-- | Read in a script and execute it.+swishScript ::+    Maybe String       -- ^ A filename or, if 'Nothing', then use standard input.+    -> SwishStateIO ()+swishScript fnam = swishReadScript fnam >>= mapM_ swishCheckResult++swishReadScript :: Maybe String -> SwishStateIO [SwishStateIO ()]+swishReadScript = swishReadFile swishParseScript []++{-|+Calculate the base URI to use; it combines the file name+with any user-supplied base.++If both the file name and user-supplied base are Nothing+then the value ++   http://id.ninebynine.org/2003/Swish/++is used.++Needs some work.+-}++defURI :: QName+defURI = "http://id.ninebynine.org/2003/Swish/"++calculateBaseURI ::+  Maybe FilePath -- ^ file name+  -> SwishStateIO QName -- ^ base URI+calculateBaseURI Nothing = fromMaybe defURI `liftM` gets base+calculateBaseURI (Just fnam) =+  case parseURIReference fnam of+    Just furi -> do+      mbase <- gets base+      case mbase of+        Just buri -> case appendURIs (getQNameURI buri) furi of+          Left emsg -> fail emsg -- TODO: think about this ...+          Right res -> return $ fromMaybe defURI (qnameFromURI res)+        Nothing -> lift $ qnameFromFilePath fnam+        +    Nothing -> fail $ "Unable to convert to URI: filepath=" ++ fnam++swishParseScript ::+  Maybe String -- file name (or "stdin" if Nothing)+  -> T.Text    -- script contents+  -> SwishStateIO [SwishStateIO ()]+swishParseScript mfpath inp = do+  buri <- calculateBaseURI mfpath+  case parseScriptFromText (Just buri) inp of+    Left err -> do+      let inName = maybe "standard input" ("file " ++) mfpath+      swishError ("Script syntax error in " ++ inName ++ ": "++err) SwishDataInputError+      return []+              +    Right scs -> return scs++swishCheckResult :: SwishStateIO () -> SwishStateIO ()+swishCheckResult swishcommand = do+  swishcommand+  er <- gets errormsg+  case er of  +    Just x -> swishError x SwishExecutionError >> modify resetError+    _      -> return ()+    +  ms <- gets infomsg+  case ms of+    Just x -> reportLine x >> modify resetInfo+    _      -> return ()++-- | Write out the current graph.+swishOutput :: +    Maybe String       -- ^ A filename or, if 'Nothing', then use standard output.+    -> SwishStateIO ()+swishOutput = swishWriteFile swishOutputGraph+   +swishOutputGraph :: Maybe String -> Handle -> SwishStateIO ()+swishOutputGraph _ hnd = do+  fmt <- gets format+  +  let writeOut formatter = do+        out <- gets $ formatter . graph+        lift $ IO.hPutStrLn hnd out+        +  case fmt of+    N3 -> writeOut N3F.formatGraphAsLazyText+    NT -> writeOut NTF.formatGraphAsLazyText+    Turtle -> writeOut TTLF.formatGraphAsLazyText+    -- _  -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError++------------------------------------------------------------+--  Common input functions+------------------------------------------------------------+--+--  Keep the logic separate for reading file data and+--  parsing it to an RDF graph value.++swishReadGraph :: Maybe String -> SwishStateIO (Maybe RDFGraph)+swishReadGraph = swishReadFile swishParse Nothing++-- | Open a file (or stdin), read its contents, and process them.+--+swishReadFile :: +  (Maybe String -> T.Text -> SwishStateIO a) -- ^ Convert filename and contents into desired value+  -> a -- ^ the value to use if the file can not be read in+  -> Maybe String -- ^ the file name or @stdin@ if @Nothing@+  -> SwishStateIO a+swishReadFile conv errVal fnam = +  let reader (h,f,i) = do+        res <- conv fnam i+        when f $ lift $ hClose h -- given that we use IO.hGetContents not sure the close is needed+        return res+  +  in swishOpenFile fnam >>= maybe (return errVal) reader++-- open a file in the SwishStateIO monad, catching+-- any errors+--+sOpen :: FilePath -> IOMode -> SwishStateIO (Either IOError Handle)+sOpen fp fm = lift . CE.try $ openFile fp fm++-- | Open and read file, returning its handle and content, or Nothing+-- WARNING:  the handle must not be closed until input is fully evaluated+--+swishOpenFile :: Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text))+swishOpenFile Nothing     = readFromHandle stdin Nothing+swishOpenFile (Just fnam) = do+  o <- sOpen fnam ReadMode+  case o of+    Left _    -> do+      swishError ("Cannot open file: "++fnam) SwishDataAccessError+      return Nothing+      +    Right hnd -> readFromHandle hnd $ Just ("file: " ++ fnam)++readFromHandle :: Handle -> Maybe String -> SwishStateIO (Maybe (Handle, Bool, T.Text))+readFromHandle hdl mlbl = do+  hrd <- lift $ hIsReadable hdl+  if hrd+    then do+      fc <- lift $ IO.hGetContents hdl+      return $ Just (hdl, isJust mlbl, fc)+  +    else do+      lbl <- case mlbl of+        Just l  -> lift (hClose hdl) >> return l+        Nothing -> return "standard input"+      swishError ("Cannot read from " ++ lbl) SwishDataAccessError+      return Nothing++swishParse :: +  Maybe String -- ^ filename (if not stdin)+  -> T.Text    -- ^ contents of file+  -> SwishStateIO (Maybe RDFGraph)+swishParse mfpath inp = do+  fmt <- gets format+  buri <- calculateBaseURI mfpath+  +  let toError eMsg =+        swishError (show fmt ++ " syntax error in " ++ inName ++ ": " ++ eMsg) SwishDataInputError +        >> return Nothing+        +      inName = maybe "standard input" ("file " ++) mfpath+  +      readIn reader = case reader inp of+        Left eMsg -> toError eMsg+        Right res -> return $ Just res+             +  case fmt of+    Turtle -> readIn (`parseTurtle` Just (getQNameURI buri))+    N3 -> readIn (`parseN3` Just buri)+    NT -> readIn parseNT+    {-+    _  -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError >>+          return Nothing+    -}+    +swishWriteFile :: +  (Maybe String -> Handle -> SwishStateIO ()) -- ^ given a file name and a handle, write to it+  -> Maybe String+  -> SwishStateIO ()+swishWriteFile conv fnam =  +  let hdlr (h, c) = conv fnam h >> when c (lift $ hClose h)+  in swishCreateWriteableFile fnam >>= maybe (return ()) hdlr+   +-- | Open file for writing, returning its handle, or Nothing+--  Also returned is a flag indicating whether or not the+--  handled should be closed when writing is done (if writing+--  to standard output, the handle should not be closed as the+--  run-time system should deal with that).+swishCreateWriteableFile :: Maybe String -> SwishStateIO (Maybe (Handle,Bool))+swishCreateWriteableFile Nothing = do+  hwt <- lift $ hIsWritable stdout+  if hwt+    then return $ Just (stdout, False)+    else do+      swishError "Cannot write to standard output" SwishDataAccessError+      return Nothing+  +swishCreateWriteableFile (Just fnam) = do+  o <- sOpen fnam WriteMode+  case o of+    Left _ -> do+      swishError ("Cannot open file for writing: " ++ fnam) SwishDataAccessError+      return Nothing+      +    Right hnd -> do+      hwt <- lift $ hIsWritable hnd+      if hwt+        then return $ Just (hnd, True)+        else do+          lift $ hClose hnd+          swishError ("Cannot write to file: "++fnam) SwishDataAccessError+          return Nothing+  +--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke  +--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

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

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

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

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

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

@@ -0,0 +1,262 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}++--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  Monad+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  FlexibleInstances, MultiParamTypeClasses+--+--  Composed state and IO monad for Swish+--+--------------------------------------------------------------------------------++module Swish.Monad+    ( SwishStateIO, SwishState(..), SwishStatus(..)+    , SwishFormat(..)+    , NamedGraph(..)+    , NamedGraphMap+    -- * Create and modify the Swish state+    , emptyState+    , setFormat, setBase, setGraph+    , modGraphs, findGraph, findFormula+    , modRules, findRule+    , modRulesets, findRuleset+    , findOpenVarModify, findDatatype+    , setInfo, resetInfo, setError, resetError+    , setStatus+    -- , setVerbose+    -- * Error handling+    , swishError+    , reportLine+    )+where++import Swish.Namespace (ScopedName, getScopeNamespace)+import Swish.QName (QName)+import Swish.Ruleset (getMaybeContextAxiom, getMaybeContextRule)+import Swish.Rule(Formula(..))++import Swish.RDF.Datatype (RDFDatatype)+import Swish.RDF.Graph (RDFGraph, emptyRDFGraph)+import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleMap, RDFRuleset, RDFRulesetMap)+import Swish.RDF.VarBinding (RDFOpenVarBindingModify)++import Swish.RDF.BuiltIn (findRDFOpenVarBindingModifier, findRDFDatatype, rdfRulesetMap)++import Control.Monad.Trans (MonadTrans(..))+import Control.Monad.State (StateT(..), modify)++import Data.LookupMap (LookupEntryClass(..), LookupMap(..))+import Data.LookupMap (emptyLookupMap, mapFindMaybe, mapVals)++import System.IO (hPutStrLn, stderr)++{-|+The supported input and output formats.+-}+data SwishFormat = +  Turtle  -- ^ Turtle format+  | N3    -- ^ N3 format+  | NT    -- ^ NTriples format+    deriving Eq++instance Show SwishFormat where+  show N3  = "N3"+  show NT  = "Ntriples"+  show Turtle = "Turtle"+  -- show RDF = "RDF/XML"++-- | The State for a Swish \"program\".+  +data SwishState = SwishState+    { format    :: SwishFormat      -- ^ format to use for I/O+    , base      :: Maybe QName      -- ^ base to use rather than file name+    , graph     :: RDFGraph         -- ^ current graph+    , graphs    :: NamedGraphMap    -- ^ script processor named graphs+    , rules     :: RDFRuleMap       -- ^ script processor named rules+    , rulesets  :: RDFRulesetMap    -- ^ script processor rulesets+    , infomsg   :: Maybe String     -- ^ information message, or Nothing+    , errormsg  :: Maybe String     -- ^ error message, or Nothing+    , exitcode  :: SwishStatus      -- ^ current status+    }++-- | Status of the processor+--+data SwishStatus =+  SwishSuccess               -- ^ successful run+  | SwishGraphCompareError   -- ^ graphs do not compare+  | SwishDataInputError      -- ^ input data problem (ie format/syntax)+  | SwishDataAccessError     -- ^ data access error+  | SwishArgumentError       -- ^ command-line argument error+  | SwishExecutionError      -- ^ error executing a Swish script+    deriving (Eq, Enum)++instance Show SwishStatus where+  show SwishSuccess           = "Success."+  show SwishGraphCompareError = "The graphs do not compare as equal."+  show SwishDataInputError    = "There was a format or syntax error in the input data."+  show SwishDataAccessError   = "There was a problem accessing data."+  show SwishArgumentError     = "Argument error: use -h or -? for help."+  show SwishExecutionError    = "There was a problem executing a Swish script."++-- | The state monad used in executing Swish programs.+type SwishStateIO a = StateT SwishState IO a++-- | The default state for Swish: no loaded graphs or rules, and format+-- set to 'N3'.+emptyState :: SwishState+emptyState = SwishState+    { format    = N3+    , base      = Nothing+    , graph     = emptyRDFGraph+    , graphs    = emptyLookupMap+    , rules     = emptyLookupMap+    , rulesets  = rdfRulesetMap+    , infomsg   = Nothing+    , errormsg  = Nothing+    , exitcode  = SwishSuccess+    }++-- | Change the format.+setFormat :: SwishFormat -> SwishState -> SwishState+setFormat   fm state = state { format = fm }++-- | Change (or remove) the base URI.+setBase :: Maybe QName -> SwishState -> SwishState+setBase bs state = state { base = bs }++-- | Change the current graph.+setGraph :: RDFGraph -> SwishState -> SwishState+setGraph    gr state = state { graph = gr }++-- | Modify the named graphs.+modGraphs ::+    ( NamedGraphMap -> NamedGraphMap ) -> SwishState -> SwishState+modGraphs grmod state = state { graphs = grmod (graphs state) }++-- | Find a named graph.+findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph]+findGraph nam state = mapFindMaybe nam (graphs state)++-- | Find a formula. The search is first made in the named graphs+-- and then, if not found, the rulesets.+findFormula :: ScopedName -> SwishState -> Maybe RDFFormula+findFormula nam state = case findGraph nam state of+        Nothing  -> getMaybeContextAxiom nam (mapVals $ rulesets state)+        Just []  -> Just $ Formula nam emptyRDFGraph+        Just grs -> Just $ Formula nam (head grs)++-- | Modify the named rules.+modRules ::+    ( RDFRuleMap -> RDFRuleMap ) -> SwishState -> SwishState+modRules rlmod state = state { rules = rlmod (rules state) }++-- | Find a named rule.+findRule :: ScopedName -> SwishState -> Maybe RDFRule+findRule nam state =+    case mapFindMaybe nam (rules state) of+      Nothing -> getMaybeContextRule nam $ mapVals $ rulesets state+      justlr  -> justlr++-- | Modify the rule sets.+modRulesets ::+    ( RDFRulesetMap -> RDFRulesetMap ) -> SwishState -> SwishState+modRulesets rsmod state = state { rulesets = rsmod (rulesets state) }++-- | Find a rule set.+findRuleset ::+    ScopedName -> SwishState -> Maybe RDFRuleset+findRuleset nam state = mapFindMaybe (getScopeNamespace nam) (rulesets state)++-- | Find a modify rule.+findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify+findOpenVarModify nam _ = findRDFOpenVarBindingModifier nam++-- | Find a data type declaration.+findDatatype :: ScopedName -> SwishState -> Maybe RDFDatatype+findDatatype nam _ = findRDFDatatype nam++-- | Set the information message.+setInfo :: String -> SwishState -> SwishState+setInfo msg state = state { infomsg = Just msg }++-- | Clear the information message.+resetInfo :: SwishState -> SwishState+resetInfo state = state { infomsg = Nothing }++-- | Set the error message.+setError :: String -> SwishState -> SwishState+setError msg state = state { errormsg = Just msg }++-- | Clear the error message.+resetError :: SwishState -> SwishState+resetError state = state { errormsg = Nothing }++-- | Set the status.+setStatus :: SwishStatus -> SwishState -> SwishState+setStatus ec state = state { exitcode = ec }++{-+setVerbose :: Bool -> SwishState -> SwishState+setVerbose f state = state { banner = f }+-}++-- | The graphs dictionary contains named graphs and/or lists+--  of graphs that are created and used by script statements.++data NamedGraph = NamedGraph+    { ngName    :: ScopedName+    , ngGraph   :: [RDFGraph]+    }++instance LookupEntryClass NamedGraph ScopedName [RDFGraph]+    where+        keyVal   (NamedGraph k v) = (k,v)+        newEntry (k,v)            = NamedGraph k v++-- | A LookupMap for the graphs dictionary.+type NamedGraphMap = LookupMap NamedGraph++-- | Report error and set exit status code++swishError :: String -> SwishStatus -> SwishStateIO ()+swishError msg sts = do+  mapM_ reportLine [msg, show sts ++ "\n"]+  modify $ setStatus sts++-- | Output the text to the standard error stream (a new line is+-- added to the output).+reportLine  :: String -> SwishStateIO ()+reportLine = lift . hPutStrLn stderr++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke +--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

@@ -0,0 +1,244 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}++--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  Namespace+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TypeSynonymInstances+--+--  This module defines algebraic datatypes for namespaces and scoped names.+--+--  For these purposes, a namespace is a prefix and URI used to identify+--  a namespace (cf. XML namespaces), and a scoped name is a name that+--  is scoped by a specified namespace.+--+--------------------------------------------------------------------------------++module Swish.Namespace+    ( Namespace+    , makeNamespace, makeNamespaceQName+      , getNamespacePrefix, getNamespaceURI, getNamespaceTuple+    -- , nullNamespace+    , ScopedName+    , getScopeNamespace, getScopeLocal+    , getScopePrefix, getScopeURI+    , getQName, getScopedNameURI+    , matchName+    , makeScopedName+    , makeQNameScopedName+    , makeURIScopedName+    , makeNSScopedName+    , nullScopedName+    , namespaceToBuilder+    )+    where++import Swish.QName (QName, LName, newQName, getLName, emptyLName, getQNameURI, getNamespace, getLocalName)++import Data.LookupMap (LookupEntryClass(..))+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import Data.String (IsString(..))++import Network.URI (URI(..), parseURIReference, nullURI)++import qualified Data.Text as T+import qualified Data.Text.Lazy.Builder as B++------------------------------------------------------------+--  Namespace, having a prefix and a URI+------------------------------------------------------------++-- |A NameSpace value consists of an optional prefix and a corresponding URI.+--++data Namespace = Namespace (Maybe T.Text) URI+-- data Namespace = Namespace (Maybe T.Text) !URI+-- TODO: look at interning the URI+                 +-- | Returns the prefix stored in the name space.                 +getNamespacePrefix :: Namespace -> Maybe T.Text+getNamespacePrefix (Namespace p _) = p++-- | Returns the URI stored in the name space.+getNamespaceURI :: Namespace -> URI+getNamespaceURI (Namespace _ u) = u++-- | Convert the name space to a (prefix, URI) tuple.+getNamespaceTuple :: Namespace -> (Maybe T.Text, URI)+getNamespaceTuple (Namespace p u) = (p, u)++-- | Equality is defined by the URI, not by the prefix+-- (so the same URI with different prefixes will be+-- considered to be equal).+instance Eq Namespace where+  (Namespace _ u1) == (Namespace _ u2) = u1 == u2++instance Show Namespace where+    show (Namespace (Just p) u) = show p ++ ":<" ++ show u ++ ">"+    show (Namespace _ u)        = "<" ++ show u ++ ">"++instance LookupEntryClass Namespace (Maybe T.Text) URI where+    keyVal   (Namespace pre uri) = (pre,uri)+    newEntry (pre,uri)           = Namespace pre uri++-- | Create a name space from a URI and an optional prefix label.+makeNamespace :: +    Maybe T.Text  -- ^ optional prefix.+    -> URI        -- ^ URI.+    -> Namespace+makeNamespace = Namespace++-- | Create a qualified name by combining the URI from+-- the name space with a local component.+makeNamespaceQName :: +    Namespace   -- ^ The name space URI is used in the qualified name+    -> LName    -- ^ local component of the qualified name (can be 'emptyLName')+    -> QName+makeNamespaceQName (Namespace _ uri) = newQName uri++{-+nullNamespace :: Namespace+nullNamespace = Namespace Nothing ""+-}++-- | Utility routine to create a \@prefix line (matching N3/Turtle)+--   grammar for this namespace.+--+namespaceToBuilder :: Namespace -> B.Builder+namespaceToBuilder (Namespace pre uri) =+  mconcat $ map B.fromText +  [ "@prefix ", fromMaybe "" pre, ": <", T.pack (show uri), "> .\n"]++------------------------------------------------------------+--  ScopedName, made from a namespace and a local name+------------------------------------------------------------++-- | A full ScopedName value has a QName prefix, namespace URI+--  and a local part.  ScopedName values may omit the prefix+--  (see 'Namespace') or the local part.+--+--  Some applications may handle null namespace URIs as meaning+--  the local part is relative to some base URI.+--+data ScopedName = ScopedName !QName Namespace LName++-- | Returns the local part.+getScopeLocal :: ScopedName -> LName+getScopeLocal (ScopedName _ _ l) = l++-- | Returns the namespace.+getScopeNamespace :: ScopedName -> Namespace+getScopeNamespace (ScopedName _ ns _) = ns++-- | Returns the prefix of the namespace, if set.+getScopePrefix :: ScopedName -> Maybe T.Text+getScopePrefix = getNamespacePrefix . getScopeNamespace++-- | Returns the URI of the namespace.+getScopeURI :: ScopedName -> URI+getScopeURI = getNamespaceURI . getScopeNamespace++-- | This is not total since it will fail if the input string is not a valid URI.+instance IsString ScopedName where+  fromString s =+    maybe (error ("Unable to convert " ++ s ++ " into a ScopedName"))+          makeURIScopedName (parseURIReference s)+    +-- | Scoped names are equal if their corresponding QNames are equal+instance Eq ScopedName where+  (ScopedName qn1 _ _) == (ScopedName qn2 _ _) = qn1 == qn2++-- | Scoped names are ordered by their QNames+instance Ord ScopedName where+  (ScopedName qn1 _ _) <= (ScopedName qn2 _ _) = qn1 <= qn2++-- | If there is a namespace associated then the Show instance+-- uses @prefix:local@, otherwise @<url>@.+instance Show ScopedName where+    show (ScopedName qn n l) = case getNamespacePrefix n of+      Just pre -> T.unpack $ mconcat [pre, ":", getLName l]+      _        -> show qn -- "<" ++ show (getNamespaceURI n) ++ T.unpack l ++ ">"++-- |Get the QName corresponding to a scoped name.+getQName :: ScopedName -> QName+getQName (ScopedName qn _ _) = qn++-- |Get URI corresponding to a scoped name (using RDF conventions).+getScopedNameURI :: ScopedName -> URI+getScopedNameURI = getQNameURI . getQName++-- |Test if supplied string matches the display form of a+--  scoped name.+matchName :: String -> ScopedName -> Bool+matchName str nam = str == show nam++-- |Construct a ScopedName.+makeScopedName :: +    Maybe T.Text  -- ^ prefix for the namespace+    -> URI        -- ^ namespace+    -> LName      -- ^ local name+    -> ScopedName+makeScopedName pre nsuri local = +    ScopedName (newQName nsuri local)+               (Namespace pre nsuri)+               local++-- |Construct a ScopedName from a QName.+makeQNameScopedName :: +    Maybe T.Text   -- ^ prefix+    -> QName +    -> ScopedName+makeQNameScopedName pre qn = ScopedName qn (Namespace pre (getNamespace qn)) (getLocalName qn)++-- could use qnameFromURI to find a local name if there is one.++-- | Construct a ScopedName for a bare URI (the label is set to \"\").+makeURIScopedName :: URI -> ScopedName+makeURIScopedName uri = makeScopedName Nothing uri emptyLName++-- | Construct a ScopedName.+makeNSScopedName :: +    Namespace     -- ^ namespace+    -> LName      -- ^ local component+    -> ScopedName+makeNSScopedName ns local = +    ScopedName (newQName (getNamespaceURI ns) local) ns local++-- | This should never appear as a valid name+nullScopedName :: ScopedName+nullScopedName = makeURIScopedName nullURI++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

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

@@ -0,0 +1,328 @@+{-# LANGUAGE OverloadedStrings #-}++--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  QName+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  OverloadedStrings+--+--  This module defines an algebraic datatype for qualified names (QNames).+--+--------------------------------------------------------------------------------++-- At present we support using URI references rather than forcing an absolute+-- URI. This is partly to support the existing tests (too lazy to resolve whether+-- the tests really should be using relative URIs in this case).++module Swish.QName+    ( QName+    , LName+    , emptyLName+    , newLName+    , getLName+    , newQName+    , qnameFromURI+    , getNamespace+    , getLocalName+    , getQNameURI+    , qnameFromFilePath+    )+    where++import Control.Monad (liftM)++import Data.String (IsString(..))+import Data.Maybe (fromMaybe)+import Data.Interned (intern, unintern)+import Data.Interned.URI (InternedURI)++import Network.URI (URI(..), URIAuth(..), parseURIReference)++import System.Directory (canonicalizePath)+import System.FilePath (splitFileName)++import qualified Data.Text as T++------------------------------------------------------------+--  Qualified name+------------------------------------------------------------+--+--  These are RDF QNames rather than XML ones (as much as+--  RDF can claim to have them).+--+++{-| A local name, which can be empty.++At present, the local name can not +contain spaces or the \'#\', \':\', or \'/\' characters. This restriction is+experimental.+-}+newtype LName = LName T.Text+    deriving (Eq, Ord)++instance Show LName where+    show (LName t) = show t++-- | This is not total since attempting to convert a string+--   containing invalid characters will cause an error.+instance IsString LName where+    fromString s = +        fromMaybe (error ("Invalid local name: " ++ s)) $+                  newLName (T.pack s)++-- | The empty local name.+emptyLName :: LName+emptyLName = LName ""++-- | Create a local name.+newLName :: T.Text -> Maybe LName+newLName l = if T.any (`elem` " #:/") l then Nothing else Just (LName l)++-- | Extract the local name.+getLName :: LName -> T.Text+getLName (LName l) = l++{-| ++A qualified name, consisting of a namespace URI+and the local part of the identifier, which can be empty.+The serialisation of a QName is formed by concatanating the+two components.++> Prelude> :set prompt "swish> "+> swish> :set -XOverloadedStrings+> swish> :m + Swish.QName+> swish> let qn1 = "http://example.com/" :: QName+> swish> let qn2 = "http://example.com/bob" :: QName+> swish> let qn3 = "http://example.com/bob/fred" :: QName+> swish> let qn4 = "http://example.com/bob/fred#x" :: QName+> swish> map getLocalName [qn1, qn2, qn3, qn4]+> ["","bob","fred","x"]+> swish> getNamespace qn1+> http://example.com+> swish> getNamespace qn2+> http://example.com+> swish> getNamespace qn3+> http://example.com/bob/+> swish> getNamespace qn4+> http://example.com/bob/fred#++-}++{-+For now I have added in storing the actual URI+as well as the namespace component. This may or+may not be a good idea (space vs time saving).+-}++data QName = QName !InternedURI URI LName++-- | This is not total since it will fail if the input string is not a valid URI.+instance IsString QName where+  fromString s = +      fromMaybe (error ("QName conversion given an invalid URI: " ++ s))+      (parseURIReference s >>= qnameFromURI)++-- | Equality is determined by a case sensitive comparison of the               +-- URI.+instance Eq QName where+  -- see qnEq comments below+  (QName u1 _ _) == (QName u2 _ _) = u1 == u2++-- ugly, use show instance OR switch to the ordering of InternedURI++-- | At present the ordering is based on a comparison of the @Show@+-- instance of the URI.+instance Ord QName where+  {-+    (QName u1 l1) <= (QName u2 l2) =+        if up1 /= up2 then up1 <= up2 else (ur1++l1) <= (ur2++l2)+        where+            n   = min (length u1) (length u2)+            (up1,ur1) = splitAt n u1+            (up2,ur2) = splitAt n u2+  -}+  +  -- TODO: which is faster?+  -- Now we have changed to InternedURI, we could use the+  -- Ord instance of it, but it is unclear to me what the+  -- ordering means in that case, and whether the semantics+  -- matter here?+  (QName u1 _ _) <= (QName u2 _ _) = show u1 <= show u2+  +  {-+  (QName _ uri1 l1) <= (QName _ uri2 l2) =+    if up1 /= up2 then up1 <= up2 else (ur1 ++ T.unpack l1) <= (ur2 ++ T.unpack l2)+      where+        u1 = show uri1+        u2 = show uri2+        +        n   = min (length u1) (length u2)+        (up1,ur1) = splitAt n u1+        (up2,ur2) = splitAt n u2+  -}+  +-- | The format used to display the URI is @\<uri\>@.+instance Show QName where+    show (QName u _ _) = "<" ++ show u ++ ">"++{-+The assumption in QName is that the validation done in creating+the local name is sufficient to ensure that the combined +URI is syntactically valid. Is this in fact true?+-}++-- | Create a new qualified name with an explicit local component.+--+newQName ::+    URI            -- ^ Namespace+    -> LName       -- ^ Local component+    -> QName+newQName ns l@(LName local) = +  -- Until profiling shows that this is a time/space issue, we use+  -- the following code rather than trying to deconstruct the URI+  -- directly+  let lstr   = T.unpack local+      uristr = show ns ++ lstr+  in case parseURIReference uristr of+       Just uri -> QName (intern uri) ns l+       _ -> error $ "Unable to combine " ++ show ns ++ " with " ++ lstr+  +{-++old behavior++ splitQname "http://example.org/aaa#bbb" = ("http://example.org/aaa#","bbb")+ splitQname "http://example.org/aaa/bbb" = ("http://example.org/aaa/","bbb")+ splitQname "http://example.org/aaa/"    = ("http://example.org/aaa/","")++Should "urn:foo:bar" have a local name of "" or "foo:bar"? For now go+with the first option.++-}++-- | Create a new qualified name.+qnameFromURI :: +    URI      -- ^ The URI will be deconstructed to find if it contains a local component.+    -> Maybe QName -- ^ The failure case may be removed.+qnameFromURI uri =+  let uf = uriFragment uri+      up = uriPath uri+      q0 = Just $ QName iuri uri emptyLName+      start = QName iuri+      iuri = intern uri+  in case uf of+       "#"    -> q0+       '#':xs -> start (uri {uriFragment = "#"}) `liftM` newLName (T.pack xs)+       ""     -> case break (=='/') (reverse up) of+                   ("",_) -> q0 -- path ends in / or is empty+                   (_,"") -> q0 -- path contains no /+                   (rlname,rpath) -> +                       start (uri {uriPath = reverse rpath}) `liftM` +                       newLName (T.pack (reverse rlname))++       -- e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" +       _ -> Nothing++-- | Return the URI of the namespace stored in the QName.+-- This does not contain the local component.+--+getNamespace :: QName -> URI+getNamespace (QName _ ns _) = ns++-- | Return the local component of the QName.+getLocalName :: QName -> LName+getLocalName (QName _ _ l) = l++-- | Returns the full URI of the QName (ie the combination of the+-- namespace and local components).+getQNameURI :: QName -> URI+getQNameURI (QName u _ _) = unintern u++{-+Original used comparison of concatenated strings,+but that was very inefficient.  The longer version below+does the comparison without constructing new values but is+no longer valid with the namespace being stored as a URI,+so for now just compare the overall URIs and we can+optimize this at a later date if needed.+qnEq :: QName -> QName -> Bool+qnEq (QName u1 _ _) (QName u2 _ _) = u1 == u2++qnEq (QName _ n1 l1) (QName _ n2 l2) = qnEq1 n1 n2 l1 l2+  where+    qnEq1 (c1:ns1) (c2:ns2)  ln1 ln2   = c1==c2 && qnEq1 ns1 ns2 ln1 ln2+    qnEq1 []  ns2  ln1@(_:_) ln2       = qnEq1 ln1 ns2 []  ln2+    qnEq1 ns1 []   ln1       ln2@(_:_) = qnEq1 ns1 ln2 ln1 []+    qnEq1 []  []   []        []        = True+    qnEq1 _   _    _         _         = False+-}++{-|+Convert a filepath to a file: URI stored in a QName. If the+input file path is relative then the current working directory is used+to convert it into an absolute path.++If the input represents a directory then it *must* end in +the directory separator - so for Posix systems use +@\"\/foo\/bar\/\"@ rather than +@\"\/foo\/bar\"@.++This has not been tested on Windows.+-}++{-+NOTE: not sure why I say directories should end in the path+seperator since++ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text"+"/Users/dburke/haskell/swish-text"+ghci> System.Directory.canonicalizePath "/Users/dburke/haskell/swish-text/"+"/Users/dburke/haskell/swish-text"++-}++qnameFromFilePath :: FilePath -> IO QName+qnameFromFilePath fname = do+  ipath <- canonicalizePath fname+  let (dname, lname) = splitFileName ipath+      nsuri = URI "file:" emptyAuth dname "" ""+      uri = URI "file:" emptyAuth ipath "" ""+  case lname of+    "" -> return $ QName (intern nsuri) nsuri emptyLName+    _  -> return $ QName (intern uri) nsuri (LName (T.pack lname))++emptyAuth :: Maybe URIAuth+emptyAuth = Just $ URIAuth "" "" ""++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

@@ -3,7 +3,7 @@ -------------------------------------------------------------------------------- -- | --  Module      :  RDF---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke --  License     :  GPL V2 -- --  Maintainer  :  Douglas Burke@@ -11,17 +11,18 @@ --  Portability :  FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances -- --  This module provides an in-memory RDF Graph (it re-exports---  "Swish.RDF.RDFGraph").+--  "Swish.RDF.Graph"). -- -------------------------------------------------------------------------------- -module Swish.RDF (module Swish.RDF.RDFGraph) where+module Swish.RDF (module Swish.RDF.Graph) where -import Swish.RDF.RDFGraph+import Swish.RDF.Graph  -------------------------------------------------------------------------------- -----  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke --  All rights reserved. -- --  This file is part of Swish.

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

@@ -0,0 +1,81 @@+--------------------------------------------------------------------------------+--  See end of this file for licence information.+--------------------------------------------------------------------------------+-- |+--  Module      :  Datatypes+--  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke+--  License     :  GPL V2+--+--  Maintainer  :  Douglas Burke+--  Stability   :  experimental+--  Portability :  H98+--+--  This module collects references and provides access to all of the+--  datatypes built in to Swish.+--+--------------------------------------------------------------------------------++module Swish.RDF.BuiltIn.Datatypes+       ( allDatatypes, findRDFDatatype )+    where++import Swish.Namespace (ScopedName)++import Swish.RDF.Datatype (RDFDatatype)++import Swish.RDF.Datatype.XSD.String (rdfDatatypeXsdString)+import Swish.RDF.Datatype.XSD.Integer (rdfDatatypeXsdInteger)+import Swish.RDF.Datatype.XSD.Decimal (rdfDatatypeXsdDecimal)++import Data.LookupMap (LookupMap(..), mapFindMaybe)++------------------------------------------------------------+--  Declare datatype map+------------------------------------------------------------++-- | Al the data type declarations built into Swish.+allDatatypes :: [RDFDatatype]+allDatatypes =+    [ rdfDatatypeXsdString+    , rdfDatatypeXsdInteger+    , rdfDatatypeXsdDecimal+    ]++-- | Look up a data type declaration.+findRDFDatatype :: ScopedName -> Maybe RDFDatatype+findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes)++------------------------------------------------------------+--  Declare datatype subtypes map+------------------------------------------------------------++{-+allDatatypeSubtypes :: [xxx]+allDatatypeSubtypes = []+--  [[[details TBD]]]+-}++--------------------------------------------------------------------------------+--+--  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin,+--    2011, 2012 Douglas Burke+--  All rights reserved.+--+--  This file is part of Swish.+--+--  Swish is free software; you can redistribute it and/or modify+--  it under the terms of the GNU General Public License as published by+--  the Free Software Foundation; either version 2 of the License, or+--  (at your option) any later version.+--+--  Swish is distributed in the hope that it will be useful,+--  but WITHOUT ANY WARRANTY; without even the implied warranty of+--  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the+--  GNU General Public License for more details.+--+--  You should have received a copy of the GNU General Public License+--  along with Swish; if not, write to:+--    The Free Software Foundation, Inc.,+--    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA+--+--------------------------------------------------------------------------------

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

@@ -1,76 +0,0 @@------------------------------------------------------------------------------------  See end of this file for licence information.------------------------------------------------------------------------------------ |---  Module      :  BuiltInDatatypes---  Copyright   :  (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  License     :  GPL V2------  Maintainer  :  Douglas Burke---  Stability   :  experimental---  Portability :  H98------  This module collects references and provides access to all of the---  datatypes built in to Swish.--------------------------------------------------------------------------------------module Swish.RDF.BuiltInDatatypes-       ( allDatatypes, findRDFDatatype )-    where--import Swish.RDF.RDFDatatype (RDFDatatype)--import Swish.Utils.LookupMap (LookupMap(..), mapFindMaybe)-import Swish.Utils.Namespace (ScopedName)-import Swish.RDF.RDFDatatypeXsdString (rdfDatatypeXsdString)-import Swish.RDF.RDFDatatypeXsdInteger (rdfDatatypeXsdInteger)-import Swish.RDF.RDFDatatypeXsdDecimal (rdfDatatypeXsdDecimal)-----------------------------------------------------------------  Declare datatype map---------------------------------------------------------------allDatatypes :: [RDFDatatype]-allDatatypes =-    [ rdfDatatypeXsdString-    , rdfDatatypeXsdInteger-    , rdfDatatypeXsdDecimal-    ]--findRDFDatatype :: ScopedName -> Maybe RDFDatatype-findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes)-----------------------------------------------------------------  Declare datatype subtypes map---------------------------------------------------------------{--allDatatypeSubtypes :: [xxx]-allDatatypeSubtypes = []---  [[[details TBD]]]--}----------------------------------------------------------------------------------------  Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke---  All rights reserved.------  This file is part of Swish.------  Swish is free software; you can redistribute it and/or modify---  it under the terms of the GNU General Public License as published by---  the Free Software Foundation; either version 2 of the License, or---  (at your option) any later version.------  Swish is distributed in the hope that it will be useful,---  but WITHOUT ANY WARRANTY; without even the implied warranty of---  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the---  GNU General Public License for more details.------  You should have received a copy of the GNU General Public License---  along with Swish; if not, write to:---    The Free Software Foundation, Inc.,---    59 Temple Place, Suite 330, Boston, MA  02111-1307  USA------------------------------------------------------------------------------------

@@ -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------------------------------------------------------------------------------------