diff --git a/app/SwishApp.hs b/app/SwishApp.hs --- a/app/SwishApp.hs +++ b/app/SwishApp.hs @@ -20,7 +20,7 @@ import Data.Version (showVersion) import System.Environment (getArgs) -import System.Exit (ExitCode(ExitSuccess,ExitFailure), exitWith) +import System.Exit (ExitCode(ExitFailure), exitWith, exitSuccess) import Control.Monad (unless) @@ -47,7 +47,7 @@ doQuiet = "-q" `elem` flags if doHelp || doVersion - then if doHelp then displaySwishHelp else displayVersion >> exitWith ExitSuccess + then if doHelp then displaySwishHelp else displayVersion >> exitSuccess else do unless doQuiet $ displayVersion >> putStrLn "\n" case validateCommands cmds of @@ -58,7 +58,7 @@ Right acts -> do code <- runSwishActions acts case code of - SwishSuccess -> exitWith ExitSuccess + SwishSuccess -> exitSuccess _ -> hPutStrLn stderr ("Swish: "++show code) >> exitWith (ExitFailure $ fromEnum code) diff --git a/src/Data/LookupMap.hs b/src/Data/LookupMap.hs deleted file mode 100644 --- a/src/Data/LookupMap.hs +++ /dev/null @@ -1,368 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} -{-# LANGUAGE OverloadedStrings #-} - --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : LookupMap --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : A lot of LANGUAGE extensions... --- --- This module defines a lookup table format and associated functions --- used by the graph matching code. --- --------------------------------------------------------------------------------- - ------------------------------------------------------------- --- Generic list-of-pairs lookup functions ------------------------------------------------------------- - -module Data.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , emptyLookupMap, makeLookupMap, listLookupMap - , reverseLookupMap - , keyOrder - , mapFind, mapFindMaybe, mapContains - , mapReplace, mapReplaceAll, mapReplaceMap - , mapAdd, mapAddIfNew - , mapDelete, mapDeleteAll - , mapEq, mapKeys, mapVals - , mapMerge - ) - where - -import Control.Arrow (first, second) - -import Data.Maybe (fromMaybe) -import Data.Function (on) -import Data.Ord (comparing) - -import Swish.Utils.ListHelpers (equiv) - -import qualified Data.Foldable as F -import qualified Data.Traversable as T -import qualified Data.List as L - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) -import Data.Tuple (swap) -#else -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) -#endif - ------------------------------------------------------------- --- Class for lookup map entries ------------------------------------------------------------- - --- |@LookupEntryClass@ defines essential functions of any datatype --- that can be used to make a 'LookupMap'. --- --- Minimal definition: @newEntry@ and @keyVal@ --- -class (Eq k, Show k) => LookupEntryClass a k v | a -> k, a -> v - where - newEntry :: (k,v) -> a - keyVal :: a -> (k,v) - - entryKey :: a -> k - entryKey = fst . keyVal - - entryVal :: a -> v - entryVal = snd . keyVal - - entryEq :: (Eq v) => a -> a -> Bool - entryEq e1 e2 = keyVal e1 == keyVal e2 - - entryShow :: (Show v) => a -> String - entryShow e = show k ++ ":" ++ show v where (k,v) = keyVal e - - kmap :: (LookupEntryClass a2 k2 v) => (k -> k2) -> a -> a2 - kmap f = newEntry . first f . keyVal - - vmap :: (LookupEntryClass a2 k v2) => (v -> v2) -> a -> a2 - vmap f = newEntry . second f . keyVal - --- |Predefine a pair of appropriate values as a valid lookup table entry --- (i.e. an instance of LookupEntryClass). --- -instance (Eq k, Show k) => LookupEntryClass (k,v) k v where - newEntry = id - keyVal = id - --- Note: the class constraint that a is an instance of 'LookupEntryClass' --- is not defined here, for good reasons (which I forget right now, but --- something to do with the method dictionary being superfluous on --- an algebraic data type). - --- |Define a lookup map based on a list of values. --- -data LookupMap a = LookupMap [a] - deriving (Functor, F.Foldable, T.Traversable) - -{- - -To allow this Monoid instance, we would need UndecidableInstances. -Also, mapMerge can error out which is not what we would want. - -instance (LookupEntryClass a k v, Eq a, Show a, Ord k) => Monoid (LookupMap a) where - mempty = LookupMap [] - mappend = mapMerge - -We could use the following (perhaps with a L.nub on the result before sticling back -into LookupMap) but it is unclear what the semantics are for repeated keys; it is -likely to be left-biased but would leave duplicate keys in the list which could -cause confusion at a later time (e.g. key removal). Many of the routines assume a single -key (or single key,value) pair. - -instance (Eq a) => Monoid (LookupMap a) where - mempty = LookupMap [] - (LookupMap a) `mappend` (LookupMap b) = - LookupMap (a `mappend` b)) --} - -gLM :: LookupMap a -> [a] -gLM (LookupMap es) = es - --- |Define equality of 'LookupMap' values based on equality of entries. --- --- (This is possibly a poor definition, as it is dependent on ordering --- of list members. But it passes all current test cases, and is used --- only for testing.) --- -instance (Eq a) => Eq (LookupMap a) where - (==) = (==) `on` gLM - --- |Define Show instance for LookupMap based on Showing the --- list of entries. --- -instance (Show a ) => Show (LookupMap a) where - show (LookupMap es) = "LookupMap " ++ show es - --- |Empty lookup map of arbitrary (i.e. polymorphic) type. --- -emptyLookupMap :: (LookupEntryClass a k v) => LookupMap a -emptyLookupMap = LookupMap [] - --- |Function to create a `LookupMap` from a list of entries. --- -makeLookupMap :: - (LookupEntryClass a k v) - => [a] -- ^ This list is not checked for duplicate entries, or - -- entries with the same key but different values. - -> LookupMap a -makeLookupMap = LookupMap - --- |Returns a list of lookup map entries. --- -listLookupMap :: (LookupEntryClass a k v) => LookupMap a -> [a] -listLookupMap = gLM - --- |Given a lookup map entry, return a new entry that can be used --- in the reverse direction of lookup. This is used to construct --- a reverse LookupMap. --- -reverseEntry :: (LookupEntryClass a1 k v, LookupEntryClass a2 v k) - => a1 -> a2 -reverseEntry = newEntry . swap . keyVal - --- |Given a lookup map, return a new map that can be used --- in the opposite direction of lookup. --- -reverseLookupMap :: (LookupEntryClass a1 b c, LookupEntryClass a2 c b) - => LookupMap a1 -> LookupMap a2 -reverseLookupMap = fmap reverseEntry - --- |Given a pair of lookup entry values, return the ordering of their --- key values. --- -keyOrder :: (LookupEntryClass a k v, Ord k) - => a -> a -> Ordering -keyOrder = comparing entryKey - --- |Find key in lookup map and return corresponding value, --- otherwise return default supplied. --- -mapFind :: - (LookupEntryClass a k v) - => v -- ^ The default value. - -> k - -> LookupMap a -> v -mapFind def key = fromMaybe def . mapFindMaybe key - --- |Find key in lookup map and return Just the corresponding value, --- otherwise return Nothing. --- -mapFindMaybe :: (LookupEntryClass a k v) => k -> LookupMap a -> Maybe v -mapFindMaybe key (LookupMap es) = foldr match Nothing es where - match ent alt - | key == entryKey ent = Just (entryVal ent) - | otherwise = alt - --- |Test to see if key is present in the supplied map --- -mapContains :: (LookupEntryClass a k v) => - LookupMap a -> k -> Bool -mapContains (LookupMap es) key = any match es where - match ent = key == entryKey ent - --- |Replace the first occurrence of a key a with a new key-value pair, --- or add a new key-value pair if the supplied key is not already present. --- -mapReplace :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplace (LookupMap []) newe = LookupMap [newe] -mapReplace (LookupMap (e:es)) newe - | entryKey e == entryKey newe = LookupMap (newe:es) - | otherwise = mapAdd more e where - more = mapReplace (LookupMap es) newe - --- |Replace all occurrence of a key a with a new key-value pair. --- --- The resulting lookup map has the same form as the original in all --- other respects. --- -mapReplaceAll :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapReplaceAll l@(LookupMap []) _ = l -mapReplaceAll (LookupMap (e:es)) newe = mapAdd more e' where - more = mapReplaceAll (LookupMap es) newe - e' = if entryKey e == entryKey newe then newe else e - --- |Replace any occurrence of a key in the first argument with a --- corresponding key-value pair from the second argument, if present. --- --- This could be implemented by multiple applications of 'mapReplaceAll', --- but is arranged differently so that only one new @LookupMap@ value is --- created. --- --- Note: keys in the new map that are not present in the old map --- are not included in the result map --- -mapReplaceMap :: (LookupEntryClass a k v) => - LookupMap a -> LookupMap a -> LookupMap a -mapReplaceMap l@(LookupMap []) _ = l -mapReplaceMap (LookupMap (e:es)) newmap = mapAdd more e' where - more = mapReplaceMap (LookupMap es) newmap - e' = newEntry (k, mapFind v k newmap) - (k,v) = keyVal e - --- |Add supplied key-value pair to the lookup map. --- --- This is effectively an optimized case of 'mapReplace' or 'mapAddIfNew', --- where the caller guarantees to avoid duplicate key values. --- -mapAdd :: LookupMap a -> a -> LookupMap a -mapAdd (LookupMap es) e = LookupMap (e:es) - --- |Add supplied key-value pair to the lookup map, --- only if the key value is not already present. --- -mapAddIfNew :: (LookupEntryClass a k v) => - LookupMap a -> a -> LookupMap a -mapAddIfNew emap e = if mapContains emap (entryKey e) - then emap - else mapAdd emap e - --- |Delete the first occurrence of the key from the lookup map. --- --- If the key does not exist in the map then no change is made. --- -mapDelete :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDelete l@(LookupMap []) _ = l -mapDelete (LookupMap (e:es)) k - | k == entryKey e = LookupMap es - | otherwise = mapAdd more e where - more = mapDelete (LookupMap es) k - --- |Delete all occurrences of the key from the lookup map. --- -mapDeleteAll :: (LookupEntryClass a k v) => - LookupMap a -> k -> LookupMap a -mapDeleteAll l@(LookupMap []) _ = l -mapDeleteAll (LookupMap (e:es)) k = - let more = mapDeleteAll (LookupMap es) k - in if entryKey e == k then more else mapAdd more e - --- |Compare two lookup maps for equality. --- --- Two maps are equal if they have the same set of keys, and if --- each key maps to an equivalent value. This is only guaranteed --- if the maps do not contain duplicate entries. --- -mapEq :: (LookupEntryClass a k v, Eq v) => - LookupMap a -> LookupMap a -> Bool -mapEq es1 es2 = - ks1 `equiv` ks2 && - and [ mapFindMaybe k es1 == mapFindMaybe k es2 | k <- ks1 ] - where - ks1 = mapKeys es1 - ks2 = mapKeys es2 - --- |Return the list of distinct keys in a supplied LookupMap --- -mapKeys :: (LookupEntryClass a k v) => - LookupMap a -> [k] -mapKeys = L.nub . gLM . fmap entryKey - --- |Return list of distinct values in a supplied LookupMap --- -mapVals :: (Eq v, LookupEntryClass a k v) => - LookupMap a -> [v] -mapVals = L.nub . gLM . fmap entryVal - --- |Merge two lookup maps, ensuring that if the same key appears --- in both maps it is associated with the same value. --- -mapMerge :: (LookupEntryClass a k v, Eq a, Show a, Ord k) => - LookupMap a -> LookupMap a -> LookupMap a -mapMerge a b = LookupMap $ on merge (L.sortBy keyOrder . gLM) a b - where - merge es1 [] = es1 - merge [] es2 = es2 - merge es1@(e1:et1) es2@(e2:et2) = - case keyOrder e1 e2 of - LT -> e1 : merge et1 es2 - GT -> e2 : merge es1 et2 - EQ -> if e1 /= e2 - then error ("mapMerge key conflict: " ++ show e1 - ++ " with " ++ show e2) - else e1 : merge et1 et2 - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, --- 2011, 2012 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/src/Network/URI/Ord.hs b/src/Network/URI/Ord.hs new file mode 100644 --- /dev/null +++ b/src/Network/URI/Ord.hs @@ -0,0 +1,61 @@ +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Ord +-- Copyright : (c) 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : H98 +-- +-- Provide an ordering for URIs (that is, an 'Ord' instance for +-- 'URI'). +-- +-- This instance is provided so that URIs can be used as the +-- key of a 'Data.Map.Map'. Case is relevant for the ordering, +-- and no attempt is made to decode percent-encoded values (i.e. +-- the comparison does /not/ use a canonical or normalized form). +-- +-------------------------------------------------------------------------------- + +module Network.URI.Ord () where + +import Network.URI (URI(..), URIAuth(..)) + +-- NOTE: we do not say compare = comparing show for the URI +-- instance since the standard show instance for URIs does not +-- include a password if included as part of the authority field. + +instance Ord URI where + URI s1 a1 o1 q1 f1 `compare` URI s2 a2 o2 q2 f2 = + (s1,a1,o1,q1,f1) `compare` (s2,a2,o2,q2,f2) + +instance Ord URIAuth where + URIAuth ui1 rn1 p1 `compare` URIAuth ui2 rn2 p2 = + (ui1,rn1,p1) `compare` (ui2,rn2,p2) + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/Commands.hs b/src/Swish/Commands.hs --- a/src/Swish/Commands.hs +++ b/src/Swish/Commands.hs @@ -63,6 +63,7 @@ import Control.Monad.State (modify, gets) import Control.Monad (liftM, when) +import qualified Data.Set as S import qualified Data.Text.Lazy as T import qualified Data.Text.Lazy.IO as IO @@ -126,8 +127,8 @@ diffGraph :: RDFGraph -> SwishStateIO () diffGraph gr = do oldGr <- gets graph - let p1 = partitionGraph (getArcs oldGr) - p2 = partitionGraph (getArcs gr) + let p1 = partitionGraph (S.toList $ getArcs oldGr) + p2 = partitionGraph (S.toList $ getArcs gr) diffs = comparePartitions p1 p2 swishWriteFile (swishOutputDiffs diffs) Nothing diff --git a/src/Swish/Datatype.hs b/src/Swish/Datatype.hs --- a/src/Swish/Datatype.hs +++ b/src/Swish/Datatype.hs @@ -1,5 +1,4 @@ {-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -7,12 +6,13 @@ -------------------------------------------------------------------------------- -- | -- Module : Datatype --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- 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 +-- Portability : ExistentialQuantification, OverloadedStrings -- -- This module defines the structures used to represent and -- manipulate datatypes. It is designed as a basis for handling datatyped @@ -73,9 +73,9 @@ import Control.Monad (join, liftM) -import Data.LookupMap (LookupEntryClass(..), LookupMap(..), mapFindMaybe) import Data.Maybe (isJust, catMaybes) +import qualified Data.Map as M import qualified Data.Text as T ------------------------------------------------------------ @@ -88,12 +88,6 @@ -- 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 @@ -241,13 +235,15 @@ getDTRel :: ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeRel vt) getDTRel nam dtv = - mapFindMaybe nam (LookupMap (tvalRel dtv)) + let m = M.fromList $ map (\n -> (dtRelName n, n)) (tvalRel dtv) + in M.lookup nam m -- | Return the named datatype value modifier, if it exists. getDTMod :: ScopedName -> DatatypeVal ex vt lb vn -> Maybe (DatatypeMod vt lb vn) getDTMod nam dtv = - mapFindMaybe nam (LookupMap (tvalMod dtv)) + let m = M.fromList $ map (\n -> (dmName n, n)) (tvalMod dtv) + in M.lookup nam m -- |Get the canonical form of a datatype value, or @Nothing@. -- @@ -310,11 +306,6 @@ , 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. @@ -347,12 +338,6 @@ , 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 @@ -417,7 +402,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmod11inv nam [f0,f1,f2] lbs@(~[lb1,lb2]) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -456,7 +441,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmod11 nam [f0,f1] lbs@(~[lb1,_]) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -501,7 +486,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmod21inv nam [f0,f1,f2,f3] lbs@(~[lb1,lb2,lb3]) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -542,7 +527,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmod21 nam [f0,f1] lbs@(~[lb1,_,_]) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -618,7 +603,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmod22 nam [f0,f1] lbs@(~[lb1,lb2,_,_]) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -658,7 +643,7 @@ -- 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 :: (Ord lb, Ord vn) => ApplyModifier lb vn makeVmodN1 nam [f0,f1] lbs@(~(lb1:_)) = VarBindingModify { vbmName = nam , vbmApply = concatMap app1 @@ -685,7 +670,7 @@ -- Add value to variable variable binding, if value is singleton list, -- otherwise return empty list. -addv :: (Eq lb, Show lb, Eq vt, Show vt) +addv :: (Ord lb, Ord vt) => lb -> [vt] -> VarBinding lb vt -> [VarBinding lb vt] addv lb [val] vbind = [addVarBinding lb val vbind] @@ -693,7 +678,7 @@ -- 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) +addv2 :: (Ord lb, Ord vt) => lb -> lb -> [vt] -> VarBinding lb vt -> [VarBinding lb vt] addv2 lb1 lb2 [val1,val2] vbind = [addVarBinding lb1 val1 $ diff --git a/src/Swish/GraphClass.hs b/src/Swish/GraphClass.hs --- a/src/Swish/GraphClass.hs +++ b/src/Swish/GraphClass.hs @@ -8,7 +8,8 @@ -------------------------------------------------------------------------------- -- | -- Module : GraphClass --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -28,16 +29,20 @@ ( LDGraph(..) , Label(..) , Arc(..) + , ArcSet , Selector , arc, arcToTriple, arcFromTriple , hasLabel, arcLabels -- , arcNodes + , getComponents ) where import Data.Hashable (Hashable(..)) -import Data.List (foldl', union, (\\)) +import Data.List (foldl') +import Data.Ord (comparing) import qualified Data.Foldable as F +import qualified Data.Set as S import qualified Data.Traversable as T -- NOTE: I wanted to declare this as a subclass of Functor, but @@ -51,48 +56,58 @@ Minimum required implementation: 'emptyGraph', 'setArcs', and 'getArcs'. -} -class (Eq (lg lb), Eq lb ) => LDGraph lg lb where + +class 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 + setArcs :: lg lb -> ArcSet lb -> lg lb -- | Extract all the arcs from a graph - getArcs :: lg lb -> [Arc lb] + getArcs :: lg lb -> ArcSet lb -- | Extract those arcs that match the given `Selector`. - extract :: Selector lb -> lg lb -> lg lb - extract sel = update (filter sel) + extract :: (Ord lb) => Selector lb -> lg lb -> lg lb + extract sel = update (S.filter sel) -- | Add the two graphs - addGraphs :: lg lb -> lg lb -> lg lb - addGraphs addg = update (union (getArcs addg)) + addGraphs :: (Ord lb) => lg lb -> lg lb -> lg lb + addGraphs addg = update (S.union (getArcs addg)) -- | Remove those arcs in the first graph from the second -- graph - delete :: lg lb -- ^ g1 - -> lg lb -- ^ g2 - -> lg lb -- ^ g2 - g1 -> g3 - delete delg = update (\\ getArcs delg) + delete :: + (Ord lb) => + lg lb -- ^ g1 + -> lg lb -- ^ g2 + -> lg lb -- ^ g2 - g1 -> g3 + delete g1 g2 = setArcs g2 (getArcs g2 `S.difference` getArcs g1) -- | Enumerate the distinct labels contained in a graph; -- that is, any label that appears in the subject, -- predicate or object position of an `Arc`. - labels :: lg lb -> [lb] - labels g = foldl' union [] (map arcLabels (getArcs g)) + labels :: (Ord lb) => lg lb -> S.Set lb + labels = getComponents arcLabels . getArcs -- | Enumerate the distinct nodes contained in a graph; -- that is, any label that appears in the subject -- or object position of an `Arc`. - nodes :: lg lb -> [lb] - nodes g = foldl' union [] (map arcNodes (getArcs g)) + nodes :: (Ord lb) => lg lb -> S.Set lb + nodes = getComponents arcNodes . getArcs -- | Update the arcs in a graph using a supplied function. - update :: ([Arc lb] -> [Arc lb]) -> lg lb -> lg lb + update :: (ArcSet lb -> ArcSet lb) -> lg lb -> lg lb update f g = setArcs g ( f (getArcs g) ) --- | Label class +-- | Extract components from a set. +getComponents :: (Ord a, Ord b) => (a -> [b]) -> S.Set a -> S.Set b +getComponents f = + let ins sgr = foldl' (flip S.insert) sgr . f + in S.foldl' ins S.empty + +-- | Label class. -- -- A label may have a fixed binding, which means that the label identifies (is) a -- particular graph node, and different such labels are always distinct nodes. @@ -105,8 +120,12 @@ -- 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 +-- We do not need Ord/Show constraints here, but it means we can just use +-- Label as a short-form for Ord/Show in code + +class (Ord lb, Show lb) => Label lb where -- | Does this node have a variable binding? labelIsVar :: lb -> Bool @@ -124,9 +143,6 @@ -- | 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@ @@ -139,6 +155,9 @@ } deriving (Eq, Functor, F.Foldable, T.Traversable) +-- | A set - or graph - of arcs. +type ArcSet lb = S.Set (Arc lb) + instance (Hashable lb) => Hashable (Arc lb) where hash (Arc s p o) = hash s `hashWithSalt` p `hashWithSalt` o hashWithSalt salt (Arc s p o) = salt `hashWithSalt` s `hashWithSalt` p `hashWithSalt` o @@ -159,21 +178,7 @@ 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 - -} + compare = comparing arcToTriple instance (Show lb) => Show (Arc lb) where show (Arc lb1 lb2 lb3) = diff --git a/src/Swish/GraphMatch.hs b/src/Swish/GraphMatch.hs --- a/src/Swish/GraphMatch.hs +++ b/src/Swish/GraphMatch.hs @@ -1,5 +1,5 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -------------------------------------------------------------------------------- @@ -12,7 +12,7 @@ -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : FlexibleInstances, TypeSynonymInstances, MultiParamTypeClasses +-- Portability : CPP, FlexibleInstances, MultiParamTypeClasses -- -- This module contains graph-matching logic. -- @@ -33,24 +33,21 @@ graphMatch1, graphMatch2, equivalenceClasses, reclassify ) where -import Swish.GraphClass (Arc(..), Label(..)) -import Swish.GraphClass (arcLabels, hasLabel, arcToTriple) - -import Swish.Utils.ListHelpers (equiv) +import Swish.GraphClass (Arc(..), ArcSet, Label(..)) +import Swish.GraphClass (getComponents, arcLabels, hasLabel, arcToTriple) 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.Function (on) import Data.Hashable (combine) +import Data.List (foldl', sortBy, groupBy, partition) +import Data.Ord (comparing) import Data.Word import qualified Data.List as L +import qualified Data.Map as M +import qualified Data.Set as S -------------------------- -- Label index value type @@ -80,22 +77,19 @@ -- | 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, Show lv) => Show (GenLabelEntry lb lv) where + show (LabelEntry k v) = show k ++ ":" ++ show v -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Show (GenLabelEntry lb lv) where - show = entryShow +instance (Label lb, Eq lv) => Eq (GenLabelEntry lb lv) where + (LabelEntry k1 v1) == (LabelEntry k2 v2) = (k1,v1) == (k2,v2) -instance (Label lb, Eq lb, Show lb, Eq lv, Show lv) - => Eq (GenLabelEntry lb lv) where - (==) = entryEq +instance (Label lb, Show lv, Ord lv) => Ord (GenLabelEntry lb lv) where + (LabelEntry lb1 lv1) `compare` (LabelEntry lb2 lv2) = + (lb1, lv1) `compare` (lb2, lv2) -- | Type for label->index lookup table data (Label lb, Eq lv, Show lv) => GenLabelMap lb lv = - LabelMap Word32 (LookupMap (GenLabelEntry lb lv)) + LabelMap Word32 (M.Map lb lv) -- | A label lookup table specialized to 'LabelIndex' indices. type LabelMap lb = GenLabelMap lb LabelIndex @@ -105,14 +99,11 @@ 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 + (gen1, lmap1) == (gen2, lmap2) -- | The empty label map table. emptyMap :: (Label lb) => LabelMap lb -emptyMap = LabelMap 1 $ makeLookupMap [] +emptyMap = LabelMap 1 M.empty -------------------------- -- Equivalence class type @@ -160,6 +151,8 @@ pairSort :: (Ord a) => [(a,b)] -> [(a,b)] pairSort = sortBy (comparing fst) +-- TODO: use set on input + -- | Group the pairs based on the first argument. pairGroup :: (Ord a) => [(a,b)] -> [(a,[b])] pairGroup = map (factor . unzip) . groupBy eqFirst . pairSort @@ -218,6 +211,8 @@ -- QUS: why doesn't this return Maybe (LabelMap (ScopedLabel lb)) ? +-- TODO: Should this use Set (Arc lb) instead of [Arc lb]? + -- | Graph matching function accepting two lists of arcs and -- returning a node map if successful -- @@ -228,8 +223,8 @@ -- 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 + -> ArcSet lb -- ^ the first graph to be compared + -> ArcSet lb -- ^ the second graph to be compared -> (Bool, LabelMap (ScopedLabel lb)) -- ^ If the first element is `True` then the second element maps each label -- to an equivalence class identifier, otherwise it is just @@ -237,8 +232,8 @@ -- graphMatch matchable gs1 gs2 = let - sgs1 = {- trace "sgs1 " $ -} map (makeScopedArc 1) gs1 - sgs2 = {- trace "sgs2 " $ -} map (makeScopedArc 2) gs2 + sgs1 = {- trace "sgs1 " $ -} S.map (makeScopedArc 1) gs1 + sgs2 = {- trace "sgs2 " $ -} S.map (makeScopedArc 2) gs2 ls1 = {- traceShow "ls1 " $ -} graphLabels sgs1 ls2 = {- traceShow "ls2 " $ -} graphLabels sgs2 lmap = {- traceShow "lmap " $ -} @@ -281,10 +276,10 @@ -- ^ 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] + -> ArcSet lb -- ^ (@gs1@ argument) -- first of two lists of arcs (triples) to be compared - -> [Arc lb] + -> ArcSet lb -- ^ (@gs2@ argument) -- secind of two lists of arcs (triples) to be compared -> LabelMap lb @@ -370,8 +365,10 @@ -- 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)] + -> ArcSet lb + -> ArcSet lb + -> LabelMap lb + -> [(EquivalenceClass lb,EquivalenceClass lb)] -> (Bool,LabelMap lb) graphMatch2 _ _ _ _ [] = error "graphMatch2 sent an empty list" -- To keep -Wall happy graphMatch2 matchable gs1 gs2 lmap ((ec1@(ev1,ls1),ec2@(ev2,ls2)):ecpairs) = @@ -416,12 +413,13 @@ "LabelMap gen="++ Prelude.show gn ++", map="++ foldl' (++) "" (map (("\n "++) . Prelude.show) es) where - es = listLookupMap lmap + es = M.toList lmap --- | Map a label to its corresponding label index value in the supplied LabelMap +-- | 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 +mapLabelIndex (LabelMap _ lxms) lb = M.findWithDefault nullLabelVal lb lxms -- | Confirm that a given pair of labels are matchable, and are -- mapped to the same value by the supplied label map @@ -429,7 +427,7 @@ 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) + matchable l1 l2 && (mapLabelIndex lmap l1 == mapLabelIndex lmap l2) -- | Replace selected values in a label map with new values from the supplied -- list of labels and new label index values. The generation number is @@ -448,7 +446,7 @@ setLabelHash :: (Label lb) => LabelMap lb -> (lb, Word32) -> LabelMap lb setLabelHash (LabelMap g lmap) (lb,lh) = - LabelMap g ( mapReplaceAll lmap $ newEntry (lb,(g,lh)) ) + LabelMap g $ M.insert lb (g,lh) lmap -- | Increment the generation of the label map. -- @@ -468,13 +466,12 @@ -- 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 +assignLabelMap :: (Label lb) => S.Set lb -> LabelMap lb -> LabelMap lb +assignLabelMap ns lmap = S.foldl' (flip assignLabelMap1) lmap ns assignLabelMap1 :: (Label lb) => lb -> LabelMap lb -> LabelMap lb -assignLabelMap1 lab (LabelMap g lvs) = LabelMap g lvs' - where - lvs' = mapAddIfNew lvs $ newEntry (lab,(g,initVal lab)) +assignLabelMap1 lab (LabelMap g lvs) = + LabelMap g $ M.insertWith (flip const) lab (g, initVal lab) lvs -- Calculate initial value for a node @@ -490,11 +487,11 @@ -- using the label map. equivalenceClasses :: (Label lb) - => LabelMap lb -- ^ label map - -> [lb] -- ^ list of nodes to be reclassified + => LabelMap lb -- ^ label map + -> S.Set lb -- ^ nodes to be reclassified -> [EquivalenceClass lb] equivalenceClasses lmap ls = - pairGroup $ map labelPair ls + pairGroup $ S.toList $ S.map labelPair ls where labelPair l = (mapLabelIndex lmap l,l) @@ -510,12 +507,12 @@ -- reclassify :: (Label lb) - => [Arc lb] - -- ^ (the @gs1@ argument) the first of two lists of arcs (triples) to perform a + => ArcSet lb + -- ^ (the @gs1@ argument) the first of two sets of arcs to perform a -- basis for reclassifying the labels in the first equivalence -- class in each pair of @ecpairs@. - -> [Arc lb] - -- ^ (the @gs2@ argument) the second of two lists of arcs (triples) to perform a + -> ArcSet lb + -- ^ (the @gs2@ argument) the second of two sets of arcs to perform a -- basis for reclassifying the labels in the second equivalence -- class in each pair of the @ecpairs@ argument -> LabelMap lb @@ -548,7 +545,8 @@ 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 + + lm' = classifyCombine lm $ M.union lm1 lm2 tmap f (a,b) = (f a, f b) @@ -561,14 +559,24 @@ pairEq = uncurry (==) pairG1 (p1,p2) = p1 > 1 || p2 > 1 remapEc = pairGroup . map (newIndex lm') . pairUngroup - newIndex x (_,lab) = (mapFind nullLabelVal lab x,lab) + newIndex x (_,lab) = (M.findWithDefault nullLabelVal lab x,lab) --- | Calculate a new index value for a supplied list of labels based on the +-- Replace the values in lm1 with those from lm2, but do not copy over new +-- keys from lm2 +classifyCombine :: (Ord a) => M.Map a b -> M.Map a b -> M.Map a b +#if MIN_VERSION_containers(0,5,0) +classifyCombine = M.mergeWithKey (\_ _ v -> Just v) id (const M.empty) +#else +-- rely on the left-biased nature of union +classifyCombine lm1 lm2 = M.intersection lm2 lm1 `M.union` lm1 +#endif + +-- | Calculate a new index value for a supplied set of labels based on the -- supplied label map and adjacency calculations in the supplied graph -- remapLabels :: (Label lb) - => [Arc lb] -- ^ arcs used for adjacency calculations when remapping + => ArcSet lb -- ^ arcs used for adjacency calculations when remapping -> LabelMap lb -- ^ the current label index values -> [lb] -- ^ the graph labels for which new mappings are to be created -> LabelMap lb @@ -576,17 +584,20 @@ -- for the given graph labels. The label map generation number is -- incremented by 1. remapLabels gs lmap@(LabelMap gen _) ls = - LabelMap gen' (LookupMap newEntries) + LabelMap gen' $ M.fromList newEntries where gen' = gen+1 - newEntries = [ newEntry (l, (gen', fromIntegral (newIndex l))) | l <- ls ] + newEntries = [ (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) + gls = S.toList gs + + sigsOver l = select (hasLabel l) gls (arcSignatures lmap gls) + -- |Select is like filter, except that it tests one list to select -- elements from a second list. select :: ( a -> Bool ) -> [a] -> [b] -> [b] @@ -596,17 +607,20 @@ | otherwise = select f l1 l2 select _ _ _ = error "select supplied with different length lists" - --- | Return list of distinct labels used in a graph +-- | Return the set of distinct labels used in the graph. -graphLabels :: (Label lb) => [Arc lb] -> [lb] -graphLabels = nub . concatMap arcLabels +graphLabels :: (Label lb) => ArcSet lb -> S.Set lb +graphLabels = getComponents 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. +-- TODO: should probably return a Set of (Int, Arc lb) or something, +-- as may be useful for the calling code + +-- | Calculate a signature value for each arc that can be used in +-- constructing an adjacency based value for a node. The adjacancy +-- value for a label is obtained by summing the signatures of all +-- statements containing that label. -- arcSignatures :: (Label lb) @@ -632,10 +646,14 @@ -- Used for testing for graph equivalence under a supplied -- label mapping; e.g. -- --- > if ( graphMap nodeMap gs1 ) `equiv` ( graphMap nodeMap gs2 ) then (same) +-- > if ( graphMap nodeMap gs1 ) == ( graphMap nodeMap gs2 ) then (same) -- -graphMap :: (Label lb) => LabelMap lb -> [Arc lb] -> [Arc LabelIndex] -graphMap = map . fmap . mapLabelIndex -- graphMapStmt +graphMap :: + (Label lb) + => LabelMap lb + -> ArcSet lb + -> ArcSet LabelIndex +graphMap = S.map . fmap . mapLabelIndex -- | Compare a pair of graphs for equivalence under a given mapping -- function. @@ -646,8 +664,13 @@ -- 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 +graphMapEq :: + (Label lb) + => LabelMap lb + -> ArcSet lb + -> ArcSet lb + -> Bool +graphMapEq lmap = (==) `on` (graphMap lmap) -------------------------------------------------------------------------------- -- diff --git a/src/Swish/GraphMem.hs b/src/Swish/GraphMem.hs --- a/src/Swish/GraphMem.hs +++ b/src/Swish/GraphMem.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -9,12 +6,13 @@ -------------------------------------------------------------------------------- -- | -- Module : GraphMem --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- 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 +-- Portability : FlexibleInstances, MultiParamTypeClasses -- -- This module defines a simple memory-based graph instance. -- @@ -40,22 +38,23 @@ import Data.Monoid (Monoid(..)) import Data.Ord (comparing) -import qualified Data.Foldable as F -import qualified Data.Traversable as T +import qualified Data.Set as S -- | Simple memory-based graph type. -data GraphMem lb = GraphMem { arcs :: [Arc lb] } - deriving (Functor, F.Foldable, T.Traversable) - +data GraphMem lb = GraphMem { arcs :: ArcSet lb } + instance (Label lb) => LDGraph GraphMem lb where - emptyGraph = GraphMem [] + emptyGraph = GraphMem S.empty getArcs = arcs setArcs g as = g { arcs=as } instance (Label lb) => Eq (GraphMem lb) where (==) = graphEq +instance (Label lb) => Ord (GraphMem lb) where + compare = comparing getArcs + instance (Label lb) => Show (GraphMem lb) where show = graphShow @@ -64,12 +63,7 @@ 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 } --} +graphShow g = "Graph:" ++ S.foldr ((++) . ("\n " ++) . show) "" (arcs g) -- | Return Boolean graph equality @@ -139,12 +133,15 @@ (LV l1) == (LV l2) = l1 == l2 _ == _ = False +instance Ord LabelMem where + (LF l1) `compare` (LF l2) = l1 `compare` l2 + (LV l1) `compare` (LV l2) = l1 `compare` l2 + (LF _) `compare` _ = LT + _ `compare` (LF _) = GT + instance Show LabelMem where show (LF l1) = '!' : l1 show (LV l2) = '?' : l2 - -instance Ord LabelMem where - compare = comparing show -------------------------------------------------------------------------------- -- diff --git a/src/Swish/GraphPartition.hs b/src/Swish/GraphPartition.hs --- a/src/Swish/GraphPartition.hs +++ b/src/Swish/GraphPartition.hs @@ -50,7 +50,7 @@ -- 'PartObj' constructors. data PartitionedGraph lb = PartitionedGraph [GraphPartition lb] - deriving (Eq,Show) + deriving (Eq, Show) -- | Returns all the arcs in the partitioned graph. getArcs :: PartitionedGraph lb -> [Arc lb] @@ -87,6 +87,13 @@ (PartObj o1) == (PartObj o2) = o1 == o2 (PartSub s1 p1) == (PartSub s2 p2) = s1 == s2 && p1 == p2 _ == _ = False + +-- Chose ordering to be "more information" first/smaller (arbitrary choice). +instance (Label lb) => Ord (GraphPartition lb) where + (PartSub s1 p1) `compare` (PartSub s2 p2) = (s1,p1) `compare` (s2,p2) + (PartObj o1) `compare` (PartObj o2) = o1 `compare` o2 + (PartSub _ _) `compare` _ = LT + _ `compare` (PartSub _ _) = GT instance (Label lb) => Show (GraphPartition lb) where show = partitionShow diff --git a/src/Swish/Monad.hs b/src/Swish/Monad.hs --- a/src/Swish/Monad.hs +++ b/src/Swish/Monad.hs @@ -1,17 +1,15 @@ -{-# 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 +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : FlexibleInstances, MultiParamTypeClasses +-- Portability : H98 -- -- Composed state and IO monad for Swish -- @@ -20,7 +18,6 @@ module Swish.Monad ( SwishStateIO, SwishState(..), SwishStatus(..) , SwishFormat(..) - , NamedGraph(..) , NamedGraphMap -- * Create and modify the Swish state , emptyState @@ -31,7 +28,6 @@ , findOpenVarModify, findDatatype , setInfo, resetInfo, setError, resetError , setStatus - -- , setVerbose -- * Error handling , swishError , reportLine @@ -53,11 +49,12 @@ import Control.Monad.Trans (MonadTrans(..)) import Control.Monad.State (StateT(..), modify) -import Data.LookupMap (LookupEntryClass(..), LookupMap(..)) -import Data.LookupMap (emptyLookupMap, mapFindMaybe, mapVals) +import Data.List (nub) import System.IO (hPutStrLn, stderr) +import qualified Data.Map as M + {-| The supported input and output formats. -} @@ -116,8 +113,8 @@ { format = N3 , base = Nothing , graph = emptyRDFGraph - , graphs = emptyLookupMap - , rules = emptyLookupMap + , graphs = M.empty + , rules = M.empty , rulesets = rdfRulesetMap , infomsg = Nothing , errormsg = Nothing @@ -143,13 +140,13 @@ -- | Find a named graph. findGraph :: ScopedName -> SwishState -> Maybe [RDFGraph] -findGraph nam state = mapFindMaybe nam (graphs state) +findGraph nam state = M.lookup nam (graphs state) -- | Find a formula. The search is first made in the named graphs -- and then, if not found, the rulesets. findFormula :: ScopedName -> SwishState -> Maybe RDFFormula findFormula nam state = case findGraph nam state of - Nothing -> getMaybeContextAxiom nam (mapVals $ rulesets state) + Nothing -> getMaybeContextAxiom nam (nub $ M.elems $ rulesets state) Just [] -> Just $ Formula nam emptyRDFGraph Just grs -> Just $ Formula nam (head grs) @@ -161,8 +158,8 @@ -- | Find a named rule. findRule :: ScopedName -> SwishState -> Maybe RDFRule findRule nam state = - case mapFindMaybe nam (rules state) of - Nothing -> getMaybeContextRule nam $ mapVals $ rulesets state + case M.lookup nam (rules state) of + Nothing -> getMaybeContextRule nam $ nub $ M.elems $ rulesets state justlr -> justlr -- | Modify the rule sets. @@ -173,7 +170,7 @@ -- | Find a rule set. findRuleset :: ScopedName -> SwishState -> Maybe RDFRuleset -findRuleset nam state = mapFindMaybe (getScopeNamespace nam) (rulesets state) +findRuleset nam state = M.lookup (getScopeNamespace nam) (rulesets state) -- | Find a modify rule. findOpenVarModify :: ScopedName -> SwishState -> Maybe RDFOpenVarBindingModify @@ -208,6 +205,7 @@ 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. @@ -216,13 +214,10 @@ , 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 +type NamedGraphMap = M.Map ScopedName [RDFGraph] -- | Report error and set exit status code diff --git a/src/Swish/Namespace.hs b/src/Swish/Namespace.hs --- a/src/Swish/Namespace.hs +++ b/src/Swish/Namespace.hs @@ -1,19 +1,17 @@ -{-# 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 +-- 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 +-- Portability : OverloadedStrings -- -- This module defines algebraic datatypes for namespaces and scoped names. -- @@ -44,9 +42,9 @@ 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.Ord (comparing) import Data.String (IsString(..)) import Network.URI (URI(..), parseURIReference, nullURI) @@ -62,6 +60,7 @@ -- data Namespace = Namespace (Maybe T.Text) URI + -- data Namespace = Namespace (Maybe T.Text) !URI -- TODO: look at interning the URI @@ -83,14 +82,15 @@ instance Eq Namespace where (Namespace _ u1) == (Namespace _ u2) = u1 == u2 +instance Ord Namespace where + -- using show for the URI is wasteful + (Namespace a1 b1) `compare` (Namespace a2 b2) = + (a1, show b1) `compare` (a2, show b2) + instance Show Namespace where show (Namespace (Just p) u) = show p ++ ":<" ++ show u ++ ">" show (Namespace _ u) = "<" ++ show u ++ ">" -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. @@ -148,19 +148,19 @@ getScopeURI :: ScopedName -> URI getScopeURI = getNamespaceURI . getScopeNamespace --- | This is not total since it will fail if the input string is not a valid URI. +-- | 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 +-- | Scoped names are equal if their corresponding 'QName' values are equal. instance Eq ScopedName where - (ScopedName qn1 _ _) == (ScopedName qn2 _ _) = qn1 == qn2 + sn1 == sn2 = getQName sn1 == getQName sn2 --- | Scoped names are ordered by their QNames +-- | Scoped names are ordered by their 'QName' components. instance Ord ScopedName where - (ScopedName qn1 _ _) <= (ScopedName qn2 _ _) = qn1 <= qn2 + compare = comparing getQName -- | If there is a namespace associated then the Show instance -- uses @prefix:local@, otherwise @@. diff --git a/src/Swish/Proof.hs b/src/Swish/Proof.hs --- a/src/Swish/Proof.hs +++ b/src/Swish/Proof.hs @@ -28,12 +28,12 @@ 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(..)) +import qualified Data.Set as S + ------------------------------------------------------------ -- Proof framework ------------------------------------------------------------ @@ -76,14 +76,18 @@ -- |Check consistency of given proof. -- The supplied rules and axioms are assumed to be correct. -checkProof :: (Expression ex) => Proof ex -> Bool +checkProof :: + (Expression ex, Ord ex) + => Proof ex -> Bool checkProof pr = checkProof1 (proofRules pr) initExpr (proofChain pr) goalExpr where initExpr = formExpr (proofInput pr) : map formExpr (proofAxioms pr) goalExpr = formExpr $ proofResult pr -checkProof1 :: (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool +checkProof1 :: + (Expression ex, Ord ex) + => [Rule ex] -> [ex] -> [Step ex] -> ex -> Bool checkProof1 _ prev [] res = res `elem` prev checkProof1 rules prev (st:steps) res = checkStep rules prev st && @@ -98,7 +102,7 @@ -- being in correspondence with the name of one of the indicated -- valid rules of inference. checkStep :: - (Expression ex) + (Expression ex, Ord ex) => [Rule ex] -- ^ rules -> [ex] -- ^ antecedants -> Step ex -- ^ the step to validate @@ -148,7 +152,7 @@ -- |Check proof. If there is an error then return information -- about the failing step. explainProof :: - (Expression ex) => Proof ex -> Maybe String + (Expression ex, Ord ex) => Proof ex -> Maybe String explainProof pr = explainProof1 (proofRules pr) initExpr (proofChain pr) goalExpr where @@ -156,7 +160,8 @@ goalExpr = formExpr $ proofResult pr explainProof1 :: - (Expression ex) => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String + (Expression ex, Ord ex) + => [Rule ex] -> [ex] -> [Step ex] -> ex -> Maybe String explainProof1 _ prev [] res = if res `elem` prev then Nothing else Just "Result not demonstrated" explainProof1 rules prev (st:steps) res = @@ -174,7 +179,7 @@ -- valid rules of inference. -- explainStep :: - (Expression ex) + (Expression ex, Ord ex) => [Rule ex] -- ^ rules -> [ex] -- ^ previous -> Step ex -- ^ step @@ -194,7 +199,7 @@ [ require (ruleName srul `elem` map ruleName rules) ("rule "++show (ruleName srul)++" not present") -- Antecedent expressions are all previously accepted expressions - , require (sant `subset` prev) + , require (S.fromList sant `S.isSubsetOf` S.fromList prev) -- (sant `subset` prev) "antecedent not axiom or previous result" -- Inference rule yields consequence from antecedents , require (checkInference srul sant scon) diff --git a/src/Swish/QName.hs b/src/Swish/QName.hs --- a/src/Swish/QName.hs +++ b/src/Swish/QName.hs @@ -46,9 +46,11 @@ import Data.Maybe (fromMaybe) import Data.Interned (intern, unintern) import Data.Interned.URI (InternedURI) +import Data.Ord (comparing) import Data.String (IsString(..)) import Network.URI (URI(..), URIAuth(..), parseURIReference) +import Network.URI.Ord () import System.Directory (canonicalizePath) import System.FilePath (splitFileName) @@ -142,50 +144,25 @@ -- | 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 + u1 == u2 = getQNameURI u1 == getQNameURI u2 --- | At present the ordering is based on a comparison of the @Show@ --- instance of the URI. +-- | In @0.8.0.0@ the ordering now uses the ordering defined in +-- "Network.URI.Ord" rather than the @Show@ +-- instance. This should make no difference unless a password +-- was included in the URI when using basic access authorization. +-- instance Ord QName where - {- - (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 - -} + compare = comparing getQNameURI --- | The format used to display the URI is @\@. +-- | The format used to display the URI is @\@, and does not +-- include the password if using baccess access authorization. instance Show QName where show (QName u _ _) = "<" ++ show u ++ ">" {- The assumption in QName is that the validation done in creating the local name is sufficient to ensure that the combined -URI is syntactically valid. Is this in fact true? +URI is syntactically valid. Is this true? -} -- | Create a new qualified name with an explicit local component. @@ -224,9 +201,8 @@ qnameFromURI uri = let uf = uriFragment uri up = uriPath uri - q0 = Just $ QName iuri uri emptyLName - start = QName iuri - iuri = intern uri + q0 = Just $ start uri emptyLName + start = QName (intern uri) in case uf of "#" -> q0 '#':xs -> start (uri {uriFragment = "#"}) `liftM` newLName (T.pack xs) @@ -254,25 +230,6 @@ -- 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 diff --git a/src/Swish/RDF.hs b/src/Swish/RDF.hs --- a/src/Swish/RDF.hs +++ b/src/Swish/RDF.hs @@ -3,12 +3,13 @@ -------------------------------------------------------------------------------- -- | -- Module : RDF --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances +-- Portability : FlexibleInstances, MultiParamTypeClasses, OverloadedStrings -- -- This module provides an in-memory RDF Graph (it re-exports -- "Swish.RDF.Graph"). diff --git a/src/Swish/RDF/BuiltIn/Datatypes.hs b/src/Swish/RDF/BuiltIn/Datatypes.hs --- a/src/Swish/RDF/BuiltIn/Datatypes.hs +++ b/src/Swish/RDF/BuiltIn/Datatypes.hs @@ -3,7 +3,8 @@ -------------------------------------------------------------------------------- -- | -- Module : Datatypes --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -19,6 +20,7 @@ ( allDatatypes, findRDFDatatype ) where +import Swish.Datatype (typeName) import Swish.Namespace (ScopedName) import Swish.RDF.Datatype (RDFDatatype) @@ -27,7 +29,7 @@ import Swish.RDF.Datatype.XSD.Integer (rdfDatatypeXsdInteger) import Swish.RDF.Datatype.XSD.Decimal (rdfDatatypeXsdDecimal) -import Data.LookupMap (LookupMap(..), mapFindMaybe) +import qualified Data.Map as M ------------------------------------------------------------ -- Declare datatype map @@ -43,7 +45,8 @@ -- | Look up a data type declaration. findRDFDatatype :: ScopedName -> Maybe RDFDatatype -findRDFDatatype nam = mapFindMaybe nam (LookupMap allDatatypes) +findRDFDatatype nam = M.lookup nam $ + M.fromList $ map (\dt -> (typeName dt, dt)) allDatatypes ------------------------------------------------------------ -- Declare datatype subtypes map diff --git a/src/Swish/RDF/BuiltIn/Rules.hs b/src/Swish/RDF/BuiltIn/Rules.hs --- a/src/Swish/RDF/BuiltIn/Rules.hs +++ b/src/Swish/RDF/BuiltIn/Rules.hs @@ -25,7 +25,8 @@ import Swish.Datatype (typeRules, typeMkModifiers) import Swish.Namespace (ScopedName) -import Swish.VarBinding (nullVarBindingModify, makeVarFilterModify, varFilterEQ, varFilterNE) +import Swish.Ruleset (getRulesetNamespace) +import Swish.VarBinding (openVbmName, nullVarBindingModify, makeVarFilterModify, varFilterEQ, varFilterNE) import Swish.RDF.BuiltIn.Datatypes (allDatatypes) import Swish.RDF.Ruleset (RDFRuleset, RDFRulesetMap) @@ -40,7 +41,7 @@ , rdfVarBindingMemberProp ) -import Data.LookupMap (LookupMap(..), mapFindMaybe) +import qualified Data.Map as M ------------------------------------------------------------ -- Declare variable binding filters list @@ -104,7 +105,8 @@ -- | Find the named open variable binding modifier. findRDFOpenVarBindingModifier :: ScopedName -> Maybe RDFOpenVarBindingModify findRDFOpenVarBindingModifier nam = - mapFindMaybe nam (LookupMap allOpenVarBindingModify) + M.lookup nam $ M.fromList $ map (\ovbm -> (openVbmName ovbm, ovbm)) + allOpenVarBindingModify ------------------------------------------------------------ -- Lookup map for built-in rulesets @@ -112,7 +114,7 @@ -- | A 'LookupMap' of 'allRulesets'. rdfRulesetMap :: RDFRulesetMap -rdfRulesetMap = LookupMap allRulesets +rdfRulesetMap = M.fromList $ map (\r -> (getRulesetNamespace r, r)) allRulesets -- | All the rule sets known to Swish. allRulesets :: [RDFRuleset] diff --git a/src/Swish/RDF/ClassRestrictionRule.hs b/src/Swish/RDF/ClassRestrictionRule.hs --- a/src/Swish/RDF/ClassRestrictionRule.hs +++ b/src/Swish/RDF/ClassRestrictionRule.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -6,12 +5,13 @@ -------------------------------------------------------------------------------- -- | -- Module : ClassRestrictionRule --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : MultiParamTypeClasses, OverloadedStrings +-- Portability : OverloadedStrings -- -- This module implements an inference rule based on a restruction on class -- membership of one or more values. @@ -58,12 +58,13 @@ import Control.Monad (liftM) -import Data.List (delete, nub, (\\), subsequences) -import Data.LookupMap (LookupEntryClass(..), LookupMap(..),mapFindMaybe) +import Data.List (delete, nub, subsequences) import Data.Maybe (fromJust, fromMaybe, mapMaybe) import Data.Monoid (Monoid (..)) import Data.Ord.Partial (minima, maxima, partCompareEq, partComparePair, partCompareListMaybe, partCompareListSubset) +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B ------------------------------------------------------------ @@ -87,11 +88,6 @@ instance Show ClassRestriction where show cr = "ClassRestriction:" ++ show (crName cr) -instance LookupEntryClass ClassRestriction ScopedName ClassRestriction - where - newEntry (_,fn) = fn - keyVal cr = (crName cr, cr) - ------------------------------------------------------------ -- Instantiate a class restriction from a datatype relation ------------------------------------------------------------ @@ -175,8 +171,10 @@ cs = filter (>0) $ map fromInteger $ rdfFindPredInt c resRdfdMaxCardinality gr ps = rdfFindList gr p - rn = mapFindMaybe (getScopedName r) (LookupMap crs) + -- TODO: do not need to go via a map since looking through a list + rn = M.lookup (getScopedName r) $ M.fromList $ map (\cr -> (crName cr, cr)) crs + makeRestrictionRule2 :: Maybe ClassRestriction -> RDFLabel -> [RDFLabel] -> [Int] -> Maybe RDFRule @@ -229,9 +227,9 @@ nts :: [[RDFLabel]] nts = mapMaybe sequence sts -- Make new graph from results, including only newly generated arcs - newarcs = nub [Arc ci p v | vs <- nts, (p,v) <- zip props vs ] - \\ getArcs antgr - newgrs = if null newarcs then [] else [toRDFGraph newarcs] + newarcs = S.fromList [Arc ci p v | vs <- nts, (p,v) <- zip props vs ] + `S.difference` getArcs antgr + newgrs = if S.null newarcs then [] else [toRDFGraph newarcs] -- Backward apply class restriction. -- @@ -289,11 +287,14 @@ -- Make new graphs for all alternatives grss :: [[RDFGraph]] grss = map ( makeGraphs . newArcs ) ftss + -- Collect arcs for one alternative newArcs dts = [ Arc ci p v | mvs <- dts, (p,Just v) <- zip props mvs ] + -- Make graphs for one alternative - makeGraphs = map (toRDFGraph . (:[])) . (Arc ci resRdfType cls :) + -- TODO: convert to sets + makeGraphs = map (toRDFGraph . S.fromList . (:[])) . (Arc ci resRdfType cls :) -- Helper function to select sub-tuples from which some of a set of -- values can be derived using a class restriction. diff --git a/src/Swish/RDF/Formatter/Internal.hs b/src/Swish/RDF/Formatter/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Swish/RDF/Formatter/Internal.hs @@ -0,0 +1,253 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : Internal +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : CPP, OverloadedStrings +-- +-- Utility routines. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.Formatter.Internal + ( NodeGenLookupMap + , SubjTree + , PredTree + , LabelContext(..) + , NodeGenState(..) + , emptyNgs + , findMaxBnode + , getCollection + , processArcs + , findPrefix + ) +where + +import Swish.GraphClass (Arc(..), ArcSet) +import Swish.RDF.Graph (RDFGraph, RDFLabel(..), NamespaceMap) +import Swish.RDF.Graph (labels, getArcs, resRdfFirst, resRdfRest, resRdfNil) + +import Data.List (delete, foldl', groupBy) +import Data.Word + +import Network.URI (URI) +import Network.URI.Ord () + +import qualified Data.Map as M +import qualified Data.Set as S + +#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) +import Data.Tuple (swap) +#else +swap :: (a,b) -> (b,a) +swap (a,b) = (b,a) +#endif + +findPrefix :: URI -> M.Map a URI -> Maybe a +findPrefix u = M.lookup u . M.fromList . map swap . M.assocs + +-- | Node name generation state information that carries through +-- and is updated by nested formulae. +type NodeGenLookupMap = M.Map RDFLabel Word32 + +type SubjTree lb = [(lb,PredTree lb)] +type PredTree lb = [(lb,[lb])] + +-- simple context for label creation +-- (may be a temporary solution to the problem +-- of label creation) +-- +data LabelContext = SubjContext | PredContext | ObjContext + deriving (Eq, Show) + +data NodeGenState = Ngs + { prefixes :: NamespaceMap + , nodeMap :: NodeGenLookupMap + , nodeGen :: Word32 + } + +emptyNgs :: NodeGenState +emptyNgs = Ngs + { prefixes = M.empty + , nodeMap = M.empty + , nodeGen = 0 + } + +{-| +Removes the first occurrence of the item from the +association list, returning it's contents and the rest +of the list, if it exists. +-} +removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) +removeItem os x = + let (as, bs) = break (\a -> fst a == x) os + in case bs of + ((_,b):bbs) -> Just (b, as ++ bbs) + [] -> Nothing + +{-| +Given a set of statements and a label, return the details of the +RDF collection referred to by label, or Nothing. + +For label to be considered as representing a collection we require the +following conditions to hold (this is only to support the +serialisation using the '(..)' syntax and does not make any statement +about semantics of the statements with regard to RDF Collections): + + - there must be one rdf_first and one rdfRest statement + - there must be no other predicates for the label + +-} +getCollection :: + SubjTree RDFLabel -- ^ statements organized by subject + -> RDFLabel -- ^ does this label represent a list? + -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) + -- ^ the statements with the elements removed; the + -- content elements of the collection (the objects of the rdf:first + -- predicate) and the nodes that represent the spine of the + -- collection (in reverse order, unlike the actual contents which are in + -- order). +getCollection subjList lbl = go subjList lbl ([],[]) + where + go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) + | otherwise = do + (pList1, sl') <- removeItem sl l + ([pFirst], pList2) <- removeItem pList1 resRdfFirst + ([pNext], []) <- removeItem pList2 resRdfRest + + go sl' pNext (pFirst : cs, l : ss) + +---------------------------------------------------------------------- +-- Graph-related helper functions +---------------------------------------------------------------------- + +processArcs :: RDFGraph -> (SubjTree RDFLabel, [RDFLabel]) +processArcs gr = + let arcs = sortArcs $ getArcs gr + in (arcTree arcs, countBnodes arcs) + +newtype SortedArcs lb = SA [Arc lb] + +sortArcs :: (Ord lb) => ArcSet lb -> SortedArcs lb +sortArcs = SA . S.toAscList + +-- Rearrange a list of arcs into a tree of pairs which group together +-- all statements for a single subject, and similarly for multiple +-- objects of a common predicate. +-- +arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb +arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as + where + spopair (Arc s p o) = (s,(p,o)) + +{- +arcTree as = map spopair $ sort as + where + spopair (Arc s p o) = (s,[(p,[o])]) +-} + +-- Rearrange a list of pairs so that multiple occurrences of the first +-- are commoned up, and the supplied function is applied to each sublist +-- with common first elements to obtain the corresponding second value +commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] +commonFstEq f ps = + [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] + where + fstEq (f1,_) (f2,_) = f1 == f2 + +{- +-- Diagnostic code for checking arcTree logic: +testArcTree = (arcTree testArcTree1) == testArcTree2 +testArcTree1 = + [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" + ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" + ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" + ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" + ] +testArcTree2 = + [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) + ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) + ] +-} + + +findMaxBnode :: RDFGraph -> Word32 +findMaxBnode = S.findMax . S.map getAutoBnodeIndex . labels + +getAutoBnodeIndex :: RDFLabel -> Word32 +getAutoBnodeIndex (Blank ('_':lns)) = res where + -- cf. prelude definition of read s ... + res = case [x | (x,t) <- reads lns, ("","") <- lex t] of + [x] -> x + _ -> 0 +getAutoBnodeIndex _ = 0 + +{- +Find all blank nodes that occur + - any number of times as a subject + - 0 or 1 times as an object + +Such nodes can be output using the "[..]" syntax. To make it simpler +to check we actually store those nodes that can not be expanded. + +Note that we do not try and expand any bNode that is used in +a predicate position. + +Should probably be using the SubjTree RDFLabel structure but this +is easier for now. + +-} + +countBnodes :: SortedArcs RDFLabel -> [RDFLabel] +countBnodes (SA as) = snd (foldl' ctr ([],[]) as) + where + -- first element of tuple are those blank nodes only seen once, + -- second element those blank nodes seen multiple times + -- + inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (l:b1s, bms) + inc b _ = b + + -- if the bNode appears as a predicate we instantly add it to the + -- list of nodes not to expand, even if only used once + incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (b1s, l:bms) + incP b _ = b + + ctr orig (Arc _ p o) = inc (incP orig p) o + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/src/Swish/RDF/Formatter/N3.hs b/src/Swish/RDF/Formatter/N3.hs --- a/src/Swish/RDF/Formatter/N3.hs +++ b/src/Swish/RDF/Formatter/N3.hs @@ -5,7 +5,8 @@ -------------------------------------------------------------------------------- -- | -- Module : N3 --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -59,22 +60,28 @@ ) where -import Swish.GraphClass (Arc(..)) +import Swish.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree + , LabelContext(..) + , NodeGenState(..), emptyNgs + , findMaxBnode + , getCollection + , processArcs + , findPrefix) + import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI) import Swish.QName (getLName) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..), - NamespaceMap, RevNamespaceMap, + NamespaceMap, emptyNamespaceMap, FormulaMap, emptyFormulaMap, - getArcs, labels, setNamespaces, getNamespaces, getFormulae, emptyRDFGraph , quote , quoteT - , resRdfFirst, resRdfRest, resRdfNil + , resRdfFirst, resRdfRest ) import Swish.RDF.Vocabulary ( @@ -89,10 +96,7 @@ import Control.Monad.State (State, modify, get, put, runState) import Data.Char (isDigit) -import Data.List (foldl', delete, groupBy, partition, sort, intersperse) -import Data.LookupMap (LookupEntryClass(..), LookupMap) -import Data.LookupMap (emptyLookupMap, reverseLookupMap, listLookupMap - , mapFind, mapFindMaybe, mapAdd, mapDelete, mapMerge) +import Data.List (partition, intersperse) import Data.Monoid (Monoid(..)) import Data.Word (Word32) @@ -100,6 +104,7 @@ -- wrong; however I have done no profiling to back this -- assumption up! +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B @@ -118,9 +123,6 @@ -- decision is made to include a blank node inline, it can be removed -- from the graph state that remains to be formatted). -type SubjTree lb = [(lb,PredTree lb)] -type PredTree lb = [(lb,[lb])] - data N3FormatterState = N3FS { indent :: B.Builder , lineBreak :: Bool @@ -152,30 +154,6 @@ , traceBuf = [] } --- | Node name generation state information that carries through --- and is updated by nested formulae. -type NodeGenLookupMap = LookupMap (RDFLabel, Word32) - -data NodeGenState = Ngs - { prefixes :: NamespaceMap - , nodeMap :: NodeGenLookupMap - , nodeGen :: Word32 - } - -emptyNgs :: NodeGenState -emptyNgs = Ngs - { prefixes = emptyLookupMap - , nodeMap = emptyLookupMap - , nodeGen = 0 - } - --- simple context for label creation --- (may be a temporary solution to the problem --- of label creation) --- -data LabelContext = SubjContext | PredContext | ObjContext - deriving (Eq, Show) - getIndent :: Formatter B.Builder getIndent = indent `liftM` get @@ -233,13 +211,13 @@ queueFormula fn = do st <- get let fa = formAvail st - newState fv = st { - formAvail = mapDelete fa fn, - formQueue = (fn,fv) : formQueue st - } - case mapFindMaybe fn fa of + _newState fv = st { + formAvail = M.delete fn fa, + formQueue = (fn,fv) : formQueue st + } + case M.lookup fn fa of Nothing -> return () - Just v -> void $ put $ newState v + Just v -> void $ put $ _newState v {- Return the graph associated with the label and delete it @@ -249,11 +227,9 @@ extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) extractFormula fn = do st <- get - let fa = formAvail st - newState = st { formAvail=mapDelete fa fn } - case mapFindMaybe fn fa of - Nothing -> return Nothing - Just fv -> put newState >> return (Just fv) + let (rval, nform) = M.updateLookupWithKey (\_ _ -> Nothing) fn $ formAvail st + put $ st { formAvail = nform } + return rval {- moreFormulae :: Formatter Bool @@ -270,49 +246,6 @@ -} --- list has a length of 1 -len1 :: [a] -> Bool -len1 (_:[]) = True -len1 _ = False - -{-| -Given a set of statements and a label, return the details of the -RDF collection referred to by label, or Nothing. - -For label to be considered as representing a collection we require the -following conditions to hold (this is only to support the -serialisation using the '(..)' syntax and does not make any statement -about semantics of the statements with regard to RDF Collections): - - - there must be one rdf_first and one rdfRest statement - - there must be no other predicates for the label - --} -getCollection :: - SubjTree RDFLabel -- ^ statements organized by subject - -> RDFLabel -- ^ does this label represent a list? - -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) - -- ^ the statements with the elements removed; the - -- content elements of the collection (the objects of the rdf:first - -- predicate) and the nodes that represent the spine of the - -- collection (in reverse order, unlike the actual contents which are in - -- order). -getCollection subjList lbl = go subjList lbl ([],[]) - where - go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) - | otherwise = do - (pList1, sl') <- removeItem sl l - (pFirst, pList2) <- removeItem pList1 resRdfFirst - (pNext, pList3) <- removeItem pList2 resRdfRest - - -- QUS: could I include these checks implicitly in the pattern matches above? - -- ie instrad of (pFirst, pos1) <- .. - -- have ([content], pos1) <- ... - -- ? - if and [len1 pFirst, len1 pNext, null pList3] - then go sl' (head pNext) (head pFirst : cs, l : ss) - else Nothing - {- TODO: @@ -344,18 +277,6 @@ Nothing -> return Nothing -{-| -Removes the first occurrence of the item from the -association list, returning it's contents and the rest -of the list, if it exists. --} -removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) -removeItem os x = - let (as, bs) = break (\a -> fst a == x) os - in case bs of - ((_,b):bbs) -> Just (b, as ++ bbs) - [] -> Nothing - ---------------------------------------------------------------------- -- Define a top-level formatter function: ---------------------------------------------------------------------- @@ -391,7 +312,7 @@ formatGraphDiag indnt flag gr = let fg = formatGraph indnt " .\n" False flag gr ngs = emptyNgs { - prefixes = emptyLookupMap, + prefixes = M.empty, nodeGen = findMaxBnode gr } @@ -428,7 +349,7 @@ formatPrefixes :: NamespaceMap -> Formatter B.Builder formatPrefixes pmap = do - let mls = map (pref . keyVal) (listLookupMap pmap) + let mls = map pref $ M.assocs pmap ls <- sequence mls return $ mconcat ls where @@ -596,39 +517,36 @@ -- Formatting helpers ---------------------------------------------------------------------- -setGraph :: RDFGraph -> Formatter () -setGraph gr = do - st <- get +newState :: RDFGraph -> N3FormatterState -> N3FormatterState +newState gr st = + let ngs0 = nodeGenSt st + pre' = prefixes ngs0 `M.union` getNamespaces gr + ngs' = ngs0 { prefixes = pre' } + (arcSubjs, bNodes) = processArcs gr - let ngs0 = nodeGenSt st - pre' = mapMerge (prefixes ngs0) (getNamespaces gr) - ngs' = ngs0 { prefixes = pre' } - arcs = sortArcs $ getArcs gr - nst = st { graph = gr - , subjs = arcTree arcs - , props = [] - , objs = [] - , formAvail = getFormulae gr - , nodeGenSt = ngs' - , bNodesCheck = countBnodes arcs - } + in st { graph = gr + , subjs = arcSubjs + , props = [] + , objs = [] + , formAvail = getFormulae gr + , nodeGenSt = ngs' + , bNodesCheck = bNodes + } - put nst +setGraph :: RDFGraph -> Formatter () +setGraph = modify . newState hasMore :: (N3FormatterState -> [b]) -> Formatter Bool hasMore lens = (not . null . lens) `liftM` get moreSubjects :: Formatter Bool moreSubjects = hasMore subjs --- moreSubjects = (not . null . subjs) `liftM` get moreProperties :: Formatter Bool moreProperties = hasMore props --- moreProperties = (not . null . props) `liftM` get moreObjects :: Formatter Bool moreObjects = hasMore objs --- moreObjects = (not . null . objs) `liftM` get nextSubject :: Formatter RDFLabel nextSubject = do @@ -737,8 +655,7 @@ pr <- getPrefixes let nsuri = getScopeURI sn local = getLName $ getScopeLocal sn - premap = reverseLookupMap pr :: RevNamespaceMap - prefix = mapFindMaybe nsuri premap + prefix = findPrefix nsuri pr name = case prefix of Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames @@ -798,10 +715,10 @@ ngs <- getNgs let cmap = nodeMap ngs cval = nodeGen ngs - nv <- case mapFind 0 lab cmap of + nv <- case M.findWithDefault 0 lab cmap of 0 -> do let nval = succ cval - nmap = mapAdd cmap (lab, nval) + nmap = M.insert lab nval cmap setNgs $ ngs { nodeGen = nval, nodeMap = nmap } return nval @@ -820,102 +737,6 @@ in quote uri -} showScopedName = quoteB True . show - ----------------------------------------------------------------------- --- Graph-related helper functions ----------------------------------------------------------------------- - -newtype SortedArcs lb = SA [Arc lb] - -sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb -sortArcs = SA . sort - --- Rearrange a list of arcs into a tree of pairs which group together --- all statements for a single subject, and similarly for multiple --- objects of a common predicate. --- -arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb -arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as - where - spopair (Arc s p o) = (s,(p,o)) - -{- -arcTree as = map spopair $ sort as - where - spopair (Arc s p o) = (s,[(p,[o])]) --} - --- Rearrange a list of pairs so that multiple occurrences of the first --- are commoned up, and the supplied function is applied to each sublist --- with common first elements to obtain the corresponding second value -commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] -commonFstEq f ps = - [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] - where - fstEq (f1,_) (f2,_) = f1 == f2 - -{- --- Diagnostic code for checking arcTree logic: -testArcTree = (arcTree testArcTree1) == testArcTree2 -testArcTree1 = - [Arc "s1" "p11" "o111", Arc "s1" "p11" "o112" - ,Arc "s1" "p12" "o121", Arc "s1" "p12" "o122" - ,Arc "s2" "p21" "o211", Arc "s2" "p21" "o212" - ,Arc "s2" "p22" "o221", Arc "s2" "p22" "o222" - ] -testArcTree2 = - [("s1",[("p11",["o111","o112"]),("p12",["o121","o122"])]) - ,("s2",[("p21",["o211","o212"]),("p22",["o221","o222"])]) - ] --} - - -findMaxBnode :: RDFGraph -> Word32 -findMaxBnode = maximum . map getAutoBnodeIndex . labels - -getAutoBnodeIndex :: RDFLabel -> Word32 -getAutoBnodeIndex (Blank ('_':lns)) = res where - -- cf. prelude definition of read s ... - res = case [x | (x,t) <- reads lns, ("","") <- lex t] of - [x] -> x - _ -> 0 -getAutoBnodeIndex _ = 0 - -{- -Find all blank nodes that occur - - any number of times as a subject - - 0 or 1 times as an object - -Such nodes can be output using the "[..]" syntax. To make it simpler -to check we actually store those nodes that can not be expanded. - -Note that we do not try and expand any bNode that is used in -a predicate position. - -Should probably be using the SubjTree RDFLabel structure but this -is easier for now. - --} - -countBnodes :: SortedArcs RDFLabel -> [RDFLabel] -countBnodes (SA as) = snd (foldl' ctr ([],[]) as) - where - -- first element of tuple are those blank nodes only seen once, - -- second element those blank nodes seen multiple times - -- - inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (l:b1s, bms) - inc b _ = b - - -- if the bNode appears as a predicate we instantly add it to the - -- list of nodes not to expand, even if only used once - incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (b1s, l:bms) - incP b _ = b - - ctr orig (Arc _ p o) = inc (incP orig p) o -------------------------------------------------------------------------------- -- diff --git a/src/Swish/RDF/Formatter/NTriples.hs b/src/Swish/RDF/Formatter/NTriples.hs --- a/src/Swish/RDF/Formatter/NTriples.hs +++ b/src/Swish/RDF/Formatter/NTriples.hs @@ -4,7 +4,8 @@ -------------------------------------------------------------------------------- -- | -- Module : NTriples --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -28,6 +29,8 @@ ) where +import Swish.RDF.Formatter.Internal (NodeGenLookupMap) + import Swish.GraphClass (Arc(..)) import Swish.Namespace (ScopedName, getQName) @@ -40,13 +43,15 @@ import Control.Applicative ((<$>)) import Data.Char (ord, intToDigit, toUpper) -import Data.LookupMap (LookupMap, emptyLookupMap, mapFind, mapAdd) import Data.Monoid +import Data.Word (Word32) -- it strikes me that using Lazy Text here is likely to be -- wrong; however I have done no profiling to back this -- assumption up! +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B @@ -57,18 +62,14 @@ -- -- This is a lot simpler than other formatters. --- | Node name generation state information that carries through --- and is updated by nested formulae -type NodeGenLookupMap = LookupMap (RDFLabel,Int) - data NTFormatterState = NTFS { ntfsNodeMap :: NodeGenLookupMap, - ntfsNodeGen :: Int + ntfsNodeGen :: Word32 } deriving Show emptyNTFS :: NTFormatterState emptyNTFS = NTFS { - ntfsNodeMap = emptyLookupMap, + ntfsNodeMap = M.empty, ntfsNodeGen = 0 } @@ -91,7 +92,7 @@ ---------------------------------------------------------------------- formatGraph :: RDFGraph -> Formatter B.Builder -formatGraph gr = mconcat <$> mapM formatArc (getArcs gr) +formatGraph gr = mconcat <$> mapM formatArc (S.toList (getArcs gr)) -- TODO: this reverses the contents but may be faster? -- that is if I've got the order right in the mappend call @@ -146,10 +147,10 @@ let cmap = ntfsNodeMap st cval = ntfsNodeGen st - nv <- case mapFind 0 lab cmap of + nv <- case M.findWithDefault 0 lab cmap of 0 -> do let nval = succ cval - nmap = mapAdd cmap (lab, nval) + nmap = M.insert lab nval cmap put $ st { ntfsNodeMap = nmap, ntfsNodeGen = nval } return nval diff --git a/src/Swish/RDF/Formatter/Turtle.hs b/src/Swish/RDF/Formatter/Turtle.hs --- a/src/Swish/RDF/Formatter/Turtle.hs +++ b/src/Swish/RDF/Formatter/Turtle.hs @@ -5,7 +5,8 @@ -------------------------------------------------------------------------------- -- | -- Module : Turtle --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke @@ -45,24 +46,25 @@ ) where -import Swish.GraphClass (Arc(..)) +import Swish.RDF.Formatter.Internal (NodeGenLookupMap, SubjTree, PredTree + , LabelContext(..) + , NodeGenState(..), emptyNgs + , findMaxBnode + , getCollection + , processArcs + , findPrefix) + import Swish.Namespace (ScopedName, getScopeLocal, getScopeURI) import Swish.QName (getLName) import Swish.RDF.Graph ( RDFGraph, RDFLabel(..) - , NamespaceMap, RevNamespaceMap - -- emptyNamespaceMap, - -- FormulaMap, emptyFormulaMap, - , getArcs - , labels - -- , setNamespaces - , getNamespaces, - -- getFormulae, - emptyRDFGraph + , NamespaceMap + , getNamespaces + , emptyRDFGraph , quote , quoteT - , resRdfFirst, resRdfRest, resRdfNil + , resRdfFirst, resRdfRest ) import Swish.RDF.Vocabulary ( fromLangTag @@ -75,9 +77,7 @@ import Control.Monad.State (State, modify, get, put, runState) import Data.Char (isDigit) -import Data.List (foldl', delete, groupBy, partition, sort, intersperse) -import Data.LookupMap (LookupEntryClass(..), LookupMap) -import Data.LookupMap (emptyLookupMap, reverseLookupMap, listLookupMap, mapFind, mapFindMaybe, mapAdd, mapMerge) +import Data.List (partition, intersperse) import Data.Monoid (Monoid(..)) import Data.Word (Word32) @@ -85,6 +85,7 @@ -- wrong; however I have done no profiling to back this -- assumption up! +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B @@ -103,9 +104,6 @@ -- decision is made to include a blank node inline, it can be removed -- from the graph state that remains to be formatted). -type SubjTree lb = [(lb,PredTree lb)] -type PredTree lb = [(lb,[lb])] - data TurtleFormatterState = TFS { indent :: B.Builder , lineBreak :: Bool @@ -137,29 +135,6 @@ , traceBuf = [] } --- | Node name generation state information. -type NodeGenLookupMap = LookupMap (RDFLabel, Word32) - -data NodeGenState = Ngs - { prefixes :: NamespaceMap - , nodeMap :: NodeGenLookupMap - , nodeGen :: Word32 - } - -emptyNgs :: NodeGenState -emptyNgs = Ngs - { prefixes = emptyLookupMap - , nodeMap = emptyLookupMap - , nodeGen = 0 - } - --- simple context for label creation --- (may be a temporary solution to the problem --- of label creation) --- -data LabelContext = SubjContext | PredContext | ObjContext - deriving (Eq, Show) - getIndent :: Formatter B.Builder getIndent = indent `liftM` get @@ -214,94 +189,6 @@ -} {- -queueFormula :: RDFLabel -> Formatter () -queueFormula fn = do - st <- get - let fa = formAvail st - newState fv = st { - formAvail = mapDelete fa fn, - formQueue = (fn,fv) : formQueue st - } - case mapFindMaybe fn fa of - Nothing -> return () - Just v -> put (newState v) >> return () --} - -{- -Return the graph associated with the label and delete it -from the store, if there is an association, otherwise -return Nothing. - -extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) -extractFormula fn = do - st <- get - let fa = formAvail st - newState = st { formAvail=mapDelete fa fn } - case mapFindMaybe fn fa of - Nothing -> return Nothing - Just fv -> put newState >> return (Just fv) - --} - -{- -moreFormulae :: Formatter Bool -moreFormulae = do - st <- get - return $ not $ null (formQueue st) - -nextFormula :: Formatter (RDFLabel,RDFGraph) -nextFormula = do - st <- get - let (nf : fq) = formQueue st - put $ st { formQueue = fq } - return nf - --} - --- list has a length of 1 -len1 :: [a] -> Bool -len1 (_:[]) = True -len1 _ = False - -{-| -Given a set of statements and a label, return the details of the -RDF collection referred to by label, or Nothing. - -For label to be considered as representing a collection we require the -following conditions to hold (this is only to support the -serialisation using the '(..)' syntax and does not make any statement -about semantics of the statements with regard to RDF Collections): - - - there must be one rdf_first and one rdfRest statement - - there must be no other predicates for the label - --} -getCollection :: - SubjTree RDFLabel -- ^ statements organized by subject - -> RDFLabel -- ^ does this label represent a list? - -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) - -- ^ the statements with the elements removed; the - -- content elements of the collection (the objects of the rdf:first - -- predicate) and the nodes that represent the spine of the - -- collection (in reverse order, unlike the actual contents which are in - -- order). -getCollection subjList lbl = go subjList lbl ([],[]) - where - go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) - | otherwise = do - (pList1, sl') <- removeItem sl l - (pFirst, pList2) <- removeItem pList1 resRdfFirst - (pNext, pList3) <- removeItem pList2 resRdfRest - - -- QUS: could I include these checks implicitly in the pattern matches above? - -- ie instrad of (pFirst, pos1) <- .. - -- have ([content], pos1) <- ... - -- ? - if and [len1 pFirst, len1 pNext, null pList3] - then go sl' (head pNext) (head pFirst : cs, l : ss) - else Nothing - -{- TODO: Should we change the preds/objs entries as well? @@ -332,18 +219,6 @@ Nothing -> return Nothing -{-| -Removes the first occurrence of the item from the -association list, returning it's contents and the rest -of the list, if it exists. --} -removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) -removeItem os x = - let (as, bs) = break (\a -> fst a == x) os - in case bs of - ((_,b):bbs) -> Just (b, as ++ bbs) - [] -> Nothing - ---------------------------------------------------------------------- -- Define a top-level formatter function: ---------------------------------------------------------------------- @@ -379,7 +254,7 @@ formatGraphDiag indnt flag gr = let fg = formatGraph indnt " .\n" False flag gr ngs = emptyNgs { - prefixes = emptyLookupMap, + prefixes = M.empty, nodeGen = findMaxBnode gr } @@ -416,7 +291,7 @@ formatPrefixes :: NamespaceMap -> Formatter B.Builder formatPrefixes pmap = do - let mls = map (pref . keyVal) (listLookupMap pmap) + let mls = map pref $ M.assocs pmap ls <- sequence mls return $ mconcat ls where @@ -571,39 +446,35 @@ -- Formatting helpers ---------------------------------------------------------------------- -setGraph :: RDFGraph -> Formatter () -setGraph gr = do - st <- get +newState :: RDFGraph -> TurtleFormatterState -> TurtleFormatterState +newState gr st = + let ngs0 = nodeGenSt st + pre' = prefixes ngs0 `M.union` getNamespaces gr + ngs' = ngs0 { prefixes = pre' } + (arcSubjs, bNodes) = processArcs gr - let ngs0 = nodeGenSt st - pre' = mapMerge (prefixes ngs0) (getNamespaces gr) - ngs' = ngs0 { prefixes = pre' } - arcs = sortArcs $ getArcs gr - nst = st { graph = gr - , subjs = arcTree arcs - , props = [] - , objs = [] - -- , formAvail = getFormulae gr - , nodeGenSt = ngs' - , bNodesCheck = countBnodes arcs - } + in st { graph = gr + , subjs = arcSubjs + , props = [] + , objs = [] + , nodeGenSt = ngs' + , bNodesCheck = bNodes + } - put nst +setGraph :: RDFGraph -> Formatter () +setGraph = modify . newState hasMore :: (TurtleFormatterState -> [b]) -> Formatter Bool hasMore lens = (not . null . lens) `liftM` get moreSubjects :: Formatter Bool moreSubjects = hasMore subjs --- moreSubjects = (not . null . subjs) `liftM` get moreProperties :: Formatter Bool moreProperties = hasMore props --- moreProperties = (not . null . props) `liftM` get moreObjects :: Formatter Bool moreObjects = hasMore objs --- moreObjects = (not . null . objs) `liftM` get nextSubject :: Formatter RDFLabel nextSubject = do @@ -701,10 +572,7 @@ pr <- getPrefixes let nsuri = getScopeURI sn local = getLName $ getScopeLocal sn - premap = reverseLookupMap pr :: RevNamespaceMap - prefix = mapFindMaybe nsuri premap - - name = case prefix of + name = case findPrefix nsuri pr of Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] @@ -748,10 +616,10 @@ ngs <- getNgs let cmap = nodeMap ngs cval = nodeGen ngs - nv <- case mapFind 0 lab cmap of + nv <- case M.findWithDefault 0 lab cmap of 0 -> do let nval = succ cval - nmap = mapAdd cmap (lab, nval) + nmap = M.insert lab nval cmap setNgs $ ngs { nodeGen = nval, nodeMap = nmap } return nval @@ -770,86 +638,6 @@ in quote uri -} showScopedName = quoteB True . show - ----------------------------------------------------------------------- --- Graph-related helper functions ----------------------------------------------------------------------- - -newtype SortedArcs lb = SA [Arc lb] - -sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb -sortArcs = SA . sort - --- Rearrange a list of arcs into a tree of pairs which group together --- all statements for a single subject, and similarly for multiple --- objects of a common predicate. --- -arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb -arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as - where - spopair (Arc s p o) = (s,(p,o)) - -{- -arcTree as = map spopair $ sort as - where - spopair (Arc s p o) = (s,[(p,[o])]) --} - --- Rearrange a list of pairs so that multiple occurrences of the first --- are commoned up, and the supplied function is applied to each sublist --- with common first elements to obtain the corresponding second value -commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] -commonFstEq f ps = - [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] - where - fstEq (f1,_) (f2,_) = f1 == f2 - -findMaxBnode :: RDFGraph -> Word32 -findMaxBnode = maximum . map getAutoBnodeIndex . labels - -getAutoBnodeIndex :: RDFLabel -> Word32 -getAutoBnodeIndex (Blank ('_':lns)) = res where - -- cf. prelude definition of read s ... - res = case [x | (x,t) <- reads lns, ("","") <- lex t] of - [x] -> x - _ -> 0 -getAutoBnodeIndex _ = 0 - -{- -Find all blank nodes that occur - - any number of times as a subject - - 0 or 1 times as an object - -Such nodes can be output using the "[..]" syntax. To make it simpler -to check we actually store those nodes that can not be expanded. - -Note that we do not try and expand any bNode that is used in -a predicate position. - -Should probably be using the SubjTree RDFLabel structure but this -is easier for now. - --} - -countBnodes :: SortedArcs RDFLabel -> [RDFLabel] -countBnodes (SA as) = snd (foldl' ctr ([],[]) as) - where - -- first element of tuple are those blank nodes only seen once, - -- second element those blank nodes seen multiple times - -- - inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (l:b1s, bms) - inc b _ = b - - -- if the bNode appears as a predicate we instantly add it to the - -- list of nodes not to expand, even if only used once - incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b - | l `elem` b1s = (delete l b1s, l:bms) - | otherwise = (b1s, l:bms) - incP b _ = b - - ctr orig (Arc _ p o) = inc (incP orig p) o -------------------------------------------------------------------------------- -- diff --git a/src/Swish/RDF/Graph.hs b/src/Swish/RDF/Graph.hs --- a/src/Swish/RDF/Graph.hs +++ b/src/Swish/RDF/Graph.hs @@ -1,7 +1,5 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -9,12 +7,13 @@ -------------------------------------------------------------------------------- -- | -- Module : Graph --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011, 2012 Douglas Burke +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, +-- 2011, 2012 Douglas Burke -- License : GPL V2 -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : CPP, FlexibleInstances, MultiParamTypeClasses, TypeSynonymInstances, OverloadedStrings +-- Portability : FlexibleInstances, MultiParamTypeClasses, OverloadedStrings -- -- This module defines a memory-based RDF graph instance. -- @@ -35,12 +34,13 @@ , quoteT -- * RDF Graphs + , RDFArcSet , RDFTriple , toRDFTriple, fromRDFTriple , NSGraph(..) , RDFGraph , toRDFGraph, emptyRDFGraph {-, updateRDFGraph-} - , NamespaceMap, RevNamespaceMap, RevNamespace + , NamespaceMap , emptyNamespaceMap , LookupFormula(..), Formula, FormulaMap, emptyFormulaMap , addArc, merge @@ -48,6 +48,8 @@ , newNode, newNodes , setNamespaces, getNamespaces , setFormulae, getFormulae, setFormula, getFormula + , fmapNSGraph + , traverseNSGraph -- * Re-export from GraphClass -- @@ -151,7 +153,7 @@ where import Swish.Namespace - ( Namespace, makeNamespace, getNamespaceTuple + ( getNamespaceTuple , getScopedNameURI , ScopedName , getScopeLocal, getScopeNamespace @@ -161,28 +163,29 @@ , nullScopedName ) -import Swish.RDF.Vocabulary -{- - ( namespaceRDF - , langTag, isLang - , rdfType - , rdfFirst, rdfRest, rdfNil, rdfXMLLiteral - , rdfsMember - , rdfdGeneralRestriction - , rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality - , owlSameAs, logImplies - , xsdBoolean, xsdDecimal, xsdFloat, xsdDouble, xsdInteger - , xsdDateTime, xsdDate - ) --} +import Swish.RDF.Vocabulary (LanguageTag) +import Swish.RDF.Vocabulary (fromLangTag, xsdBoolean, xsdDate, xsdDateTime, xsdDecimal, xsdDouble, xsdFloat, xsdInteger + , rdfType, rdfList, rdfFirst, rdfRest, rdfNil + , rdfsMember, rdfdGeneralRestriction, rdfdOnProperties, rdfdConstraint, rdfdMaxCardinality + , rdfsSeeAlso, rdfValue, rdfsLabel, rdfsComment, rdfProperty + , rdfsSubPropertyOf, rdfsSubClassOf, rdfsClass, rdfsLiteral + , rdfsDatatype, rdfXMLLiteral, rdfsRange, rdfsDomain, rdfsContainer + , rdfBag, rdfSeq, rdfAlt + , rdfsContainerMembershipProperty, rdfsIsDefinedBy + , rdfsResource, rdfStatement, rdfSubject, rdfPredicate, rdfObject + , rdfRDF, rdfDescription, rdfID, rdfAbout, rdfParseType + , rdfResource, rdfLi, rdfNodeID, rdfDatatype, rdfXMLLiteral + , rdf1, rdf2, rdfn + , owlSameAs, logImplies, namespaceRDF + ) -import Swish.GraphClass (LDGraph(..), Label (..), Arc(..), Selector) -import Swish.GraphClass (arc, arcLabels) +import Swish.GraphClass (LDGraph(..), Label (..), Arc(..), ArcSet, Selector) +import Swish.GraphClass (arc, arcLabels, getComponents) import Swish.GraphMatch (LabelMap, ScopedLabel(..)) import Swish.GraphMatch (graphMatch) import Swish.QName (QName, getLName) -import Control.Applicative (Applicative, liftA, (<$>), (<*>)) +import Control.Applicative (Applicative(pure), (<$>), (<*>)) import Network.URI (URI) @@ -191,9 +194,7 @@ import Data.Char (ord, isDigit) import Data.Hashable (hashWithSalt) import Data.List (intersect, union, foldl') -import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) -import Data.LookupMap (listLookupMap, mapFind, mapFindMaybe, mapReplace, mapAddIfNew, mapVals, mapKeys ) -import Data.Ord (comparing) +-- import Data.Ord (comparing) import Data.Word (Word32) import Data.String (IsString(..)) @@ -203,22 +204,11 @@ import Text.Printf -import qualified Data.Foldable as Foldable -import qualified Data.Traversable as Traversable - +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Read as T --- import qualified Data.Text.Lazy as L --- import Data.Text.Format (format) --- import Data.Text.Buildable --- import Data.Text.Format.Types (Only(..)) - -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 701) -import Data.Tuple (swap) -#else -swap :: (a,b) -> (b,a) -swap (a,b) = (b,a) -#endif +import qualified Data.Traversable as Traversable -- | RDF graph node values -- @@ -290,26 +280,35 @@ show NoNode = "" instance Ord RDFLabel where - -- Optimize some common cases.. - compare (Res sn1) (Res sn2) = compare sn1 sn2 - compare (Blank ln1) (Blank ln2) = compare ln1 ln2 - compare (Res _) (Blank _) = LT - compare (Blank _) (Res _) = GT + -- Order, from lowest to highest is + -- Res, Lit, LangLit, TypedLit, Blank, Var, NoNode + -- + compare (Res sn1) (Res sn2) = compare sn1 sn2 + compare (Res _) _ = LT + compare _ (Res _) = GT - compare (Lit s1) (Lit s2) = compare s1 s2 + compare (Lit s1) (Lit s2) = compare s1 s2 + compare (Lit _) _ = LT + compare _ (Lit _) = GT - -- .. else use show string comparison - compare l1 l2 = comparing show l1 l2 - - {- <= is not used if compare is provided - -- Similarly for <= - (Res qn1) <= (Res qn2) = qn1 <= qn2 - (Blank ln1) <= (Blank ln2) = ln1 <= ln2 - (Res _) <= (Blank _) = True - (Blank _) <= (Res _) = False - l1 <= l2 = show l1 <= show l2 - -} - + compare (LangLit s1 l1) (LangLit s2 l2) = compare (s1,l1) (s2,l2) + compare (LangLit _ _) _ = LT + compare _ (LangLit _ _) = GT + + compare (TypedLit s1 t1) (TypedLit s2 t2) = compare (s1,t1) (s2,t2) + compare (TypedLit _ _) _ = LT + compare _ (TypedLit _ _) = GT + + compare (Blank ln1) (Blank ln2) = compare ln1 ln2 + compare (Blank _) _ = LT + compare _ (Blank _) = GT + + compare (Var ln1) (Var ln2) = compare ln1 ln2 + compare (Var _) NoNode = LT + compare _ (Var _) = GT + + compare NoNode NoNode = EQ + instance Label RDFLabel where labelIsVar (Blank _) = True labelIsVar (Var _) = True @@ -1002,6 +1001,9 @@ -- type RDFTriple = Arc RDFLabel +-- | A set of RDF triples. +type RDFArcSet = ArcSet RDFLabel + -- | Convert 3 RDF labels to a RDF triple. -- -- See also @Swish.RDF.GraphClass.arcFromTriple@. @@ -1028,22 +1030,12 @@ -- | Namespace prefix list entry --- | A 'LookupMap' for name spaces. -type NamespaceMap = LookupMap Namespace - --- | A 'LookupMap' for reversed name spaces. -type RevNamespaceMap = LookupMap RevNamespace - --- | Support for reversed name spaces in a 'LookupMap'. -data RevNamespace = RevNamespace Namespace - -instance LookupEntryClass RevNamespace URI (Maybe T.Text) where - keyVal (RevNamespace ns) = swap $ getNamespaceTuple ns - newEntry (uri,pre) = RevNamespace (makeNamespace pre uri) +-- | A map for name spaces (key is the prefix). +type NamespaceMap = M.Map (Maybe T.Text) URI -- TODO: should val be URI or namespace? -- | Create an empty namespace map. emptyNamespaceMap :: NamespaceMap -emptyNamespaceMap = LookupMap [] +emptyNamespaceMap = M.empty -- | Graph formula entry @@ -1056,50 +1048,63 @@ f1 == f2 = formLabel f1 == formLabel f2 && formGraph f1 == formGraph f2 -instance (Label lb) - => LookupEntryClass (LookupFormula lb (NSGraph lb)) lb (NSGraph lb) - where - keyVal fe = (formLabel fe, formGraph fe) - newEntry (k,v) = Formula { formLabel=k, formGraph=v } - -instance (Label lb) => Show (LookupFormula lb (NSGraph lb)) - where - show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" +instance (Ord lb, Ord gr) => Ord (LookupFormula lb gr) where + (Formula a1 b1) `compare` (Formula a2 b2) = + (a1,b1) `compare` (a2,b2) -- | A named formula. type Formula lb = LookupFormula lb (NSGraph lb) --- | A 'LookupMap' for named formulae. -type FormulaMap lb = LookupMap (LookupFormula lb (NSGraph lb)) +instance (Label lb) => Show (Formula lb) + where + show (Formula l g) = show l ++ " :- { " ++ showArcs " " g ++ " }" +-- | A map for named formulae. +type FormulaMap lb = M.Map lb (NSGraph lb) + -- | Create an empty formula map. emptyFormulaMap :: FormulaMap RDFLabel -emptyFormulaMap = LookupMap [] +emptyFormulaMap = M.empty -{- given up on trying to do Functor for formulae... -instance Functor (LookupFormula (NSGraph lb)) where - fmap f fm = mapTranslateEntries (mapFormulaEntry f) fm +-- fmapFormulaMap :: (Ord a, Ord b) => (a -> b) -> FormulaMap a -> FormulaMap b +fmapFormulaMap :: (Ord a) => (a -> a) -> FormulaMap a -> FormulaMap a +fmapFormulaMap f m = M.fromList $ map (\(k,g) -> (f k, fmapNSGraph f g)) $ M.assocs m + +-- TODO: how to traverse formulamaps now? + +{- +traverseFormulaMap :: + (Applicative f, Ord a, Ord b) + => (a -> f b) -> FormulaMap a -> f (FormulaMap b) -} +traverseFormulaMap :: + (Applicative f, Ord a) + => (a -> f a) -> FormulaMap a -> f (FormulaMap a) +traverseFormulaMap f = Traversable.traverse (traverseFormula f) -formulaeMap :: (lb -> l2) -> FormulaMap lb -> FormulaMap l2 -formulaeMap f = fmap (formulaEntryMap f) +{- +traverseFormula :: + (Applicative f, Ord a, Ord b) + => (a -> f b) -> Formula a -> f (Formula b) +-} +{- +traverseFormula :: + (Applicative f, Ord a) + => (a -> f a) -> Formula a -> f (Formula a) +traverseFormula f (Formula k gr) = Formula <$> f k <*> traverseNSGraph f gr +-} -formulaEntryMap :: - (lb -> l2) - -> Formula lb - -> Formula l2 -formulaEntryMap f (Formula k gr) = Formula (f k) (fmap f gr) +traverseFormula :: + (Applicative f, Ord a) + => (a -> f a) -> NSGraph a -> f (NSGraph a) -formulaeMapA :: Applicative f => (lb -> f l2) -> - FormulaMap lb -> f (FormulaMap l2) -formulaeMapA f = Traversable.traverse (formulaEntryMapA f) +{- +traverseFormula :: + (Applicative f, Ord a, Ord b) + => (a -> f b) -> NSGraph a -> f (NSGraph b) +-} -formulaEntryMapA :: - (Applicative f) => - (lb -> f l2) - -> Formula lb - -> f (Formula l2) -formulaEntryMapA f (Formula k gr) = Formula `liftA` f k <*> Traversable.traverse f gr +traverseFormula = traverseNSGraph {- formulaeMapM :: @@ -1133,13 +1138,14 @@ -} data NSGraph lb = NSGraph - { namespaces :: NamespaceMap -- ^ the namespaces to use - , formulae :: FormulaMap lb -- ^ any associated formulae (a.k.a. sub- or named- graps) - , statements :: [Arc lb] -- ^ the statements in the graph + { namespaces :: NamespaceMap -- ^ the namespaces to use + , formulae :: FormulaMap lb -- ^ any associated formulae + -- (a.k.a. sub- or named- graps) + , statements :: ArcSet lb -- ^ the statements in the graph } instance (Label lb) => LDGraph NSGraph lb where - emptyGraph = NSGraph emptyNamespaceMap (LookupMap []) [] + emptyGraph = NSGraph emptyNamespaceMap M.empty S.empty getArcs = statements setArcs g as = g { statements=as } @@ -1148,20 +1154,42 @@ mempty = emptyGraph mappend = merge -instance Functor NSGraph where - fmap f (NSGraph ns fml stmts) = - NSGraph ns (formulaeMap f fml) ((map $ fmap f) stmts) +-- | 'fmap' for 'NSGraph' instances. +-- fmapNSGraph :: (Ord lb1, Ord lb2) => (lb1 -> lb2) -> NSGraph lb1 -> NSGraph lb2 +fmapNSGraph :: (Ord lb) => (lb -> lb) -> NSGraph lb -> NSGraph lb +fmapNSGraph f (NSGraph ns fml stmts) = + NSGraph ns (fmapFormulaMap f fml) ((S.map $ fmap f) stmts) -instance Foldable.Foldable NSGraph where - foldMap = Traversable.foldMapDefault +-- | 'Data.Traversable.traverse' for 'NSGraph' instances. +{- +traverseNSGraph :: + (Applicative f, Ord a, Ord b) + => (a -> f b) -> NSGraph a -> f (NSGraph b) +-} +traverseNSGraph :: + (Applicative f, Ord a) + => (a -> f a) -> NSGraph a -> f (NSGraph a) +traverseNSGraph f (NSGraph ns fml stmts) = + NSGraph ns <$> traverseFormulaMap f fml <*> (traverseSet $ Traversable.traverse f) stmts -instance Traversable.Traversable NSGraph where - traverse f (NSGraph ns fml stmts) = - NSGraph ns <$> formulaeMapA f fml <*> (Traversable.traverse $ Traversable.traverse f) stmts - +traverseSet :: + (Applicative f, Ord a, Ord b) + => (a -> f b) -> S.Set a -> f (S.Set b) +traverseSet f = S.foldr cons (pure S.empty) + where + cons x s = S.insert <$> f x <*> s + instance (Label lb) => Eq (NSGraph lb) where (==) = grEq +-- The namespaces are not used in the ordering since this could +-- lead to identical graphs not being considered the same when +-- ordering. +-- +instance (Label lb) => Ord (NSGraph lb) where + (NSGraph _ fml1 stmts1) `compare` (NSGraph _ fml2 stmts2) = + (fml1,stmts1) `compare` (fml2,stmts2) + instance (Label lb) => Show (NSGraph lb) where show = grShow "" showList = grShowList "" @@ -1184,11 +1212,13 @@ -- | Find a formula in the graph, if it exists. getFormula :: (Label lb) => NSGraph lb -> lb -> Maybe (NSGraph lb) -getFormula g l = mapFindMaybe l (formulae g) +-- getFormula g l = fmap formGraph $ M.lookup l (formulae g) +getFormula g l = M.lookup l (formulae g) -- | Add (or replace) a formula. setFormula :: (Label lb) => Formula lb -> NSGraph lb -> NSGraph lb -setFormula f g = g { formulae=mapReplace (formulae g) f } +-- setFormula f g = g { formulae = M.insert (formLabel f) f (formulae g) } +setFormula (Formula fn fg) g = g { formulae = M.insert fn fg (formulae g) } {-| Add an arc to the graph. It does not relabel any blank nodes in the input arc, @@ -1196,12 +1226,7 @@ but it does ensure that the arc is unknown before adding it. -} addArc :: (Label lb) => Arc lb -> NSGraph lb -> NSGraph lb -addArc ar gr = gr { statements=addSetElem ar (statements gr) } - --- |Add element to the set. - -addSetElem :: (Eq a) => a -> [a] -> [a] -addSetElem e es = if e `elem` es then es else e:es +addArc ar = update (S.insert ar) grShowList :: (Label lb) => String -> [NSGraph lb] -> String -> String grShowList _ [] = showString "[no graphs]" @@ -1217,11 +1242,11 @@ p ++ "arcs: " ++ showArcs p g where showForm = foldr ((++) . (pp ++) . show) "" fml - fml = listLookupMap (getFormulae g) + fml = map (uncurry Formula) $ M.assocs (getFormulae g) -- NOTE: want to just show 'name :- graph' pp = "\n " ++ p showArcs :: (Label lb) => String -> NSGraph lb -> String -showArcs p g = foldr ((++) . (pp ++) . show) "" (getArcs g) +showArcs p g = S.foldr ((++) . (pp ++) . show) "" (getArcs g) where pp = "\n " ++ p @@ -1238,7 +1263,15 @@ graphMatch matchable (getArcs g1) (getArcs g2) where matchable l1 l2 = mapFormula g1 l1 == mapFormula g2 l2 - mapFormula g l = mapFindMaybe l (getFormulae g) + -- hmmm, if we compare the formula, rather then graph, + -- a lot of tests fail (when the formulae are named by blank + -- nodes). Presumably because the quality check for Formula forces + -- the label to be identical, which it needn't be with bnodes + -- for the match to hold. + -- mapFormula g l = M.lookup l (getFormulae g) + -- mapFormula g l = fmap formGraph $ M.lookup l (getFormulae g) + -- the above discussion is hopefully moot now storing graph directly + mapFormula g l = M.lookup l (getFormulae g) -- |Merge RDF graphs, renaming blank and query variable nodes as -- needed to neep variable nodes from the two graphs distinct in @@ -1249,8 +1282,8 @@ -- merge :: (Label lb) => NSGraph lb -> NSGraph lb -> NSGraph lb merge gr1 gr2 = - let bn1 = allLabels labelIsVar gr1 - bn2 = allLabels labelIsVar gr2 + let bn1 = S.toList $ allLabels labelIsVar gr1 + bn2 = S.toList $ allLabels labelIsVar gr2 dupbn = intersect bn1 bn2 allbn = union bn1 bn2 in addGraphs gr1 (remapLabels dupbn allbn id gr2) @@ -1258,33 +1291,33 @@ -- |Return list of all labels (including properties) in the graph -- satisfying a supplied filter predicate. This routine -- includes the labels in any formulae. -allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allLabels p gr = filter p (unionNodes p (formulaNodes p gr) (labels gr) ) +allLabels :: (Label lb) => (lb -> Bool) -> NSGraph lb -> S.Set lb +allLabels p gr = S.filter p (unionNodes p (formulaNodes p gr) (labels gr) ) {- TODO: is the leading 'filter p' needed in allLabels? -} -- |Return list of all subjects and objects in the graph -- satisfying a supplied filter predicate. -allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] -allNodes p = unionNodes p [] . nodes +allNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> S.Set lb +allNodes p = unionNodes p S.empty . nodes -- | List all nodes in graph formulae satisfying a supplied predicate -formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> [lb] +formulaNodes :: (Label lb) => (lb -> Bool) -> NSGraph lb -> S.Set lb formulaNodes p gr = foldl' (unionNodes p) fkeys (map (allLabels p) fvals) where - -- fm :: (Label lb) => FormulaMap lb - -- LookupMap LookupFormula (NSGraph lb) lb fm = formulae gr - -- fvals :: (Label lb) => [NSGraph lb] - fvals = mapVals fm - -- fkeys :: (Label lb) => [lb] - fkeys = filter p $ mapKeys fm + -- fvals = map formGraph $ M.elems fm + fvals = M.elems fm + -- TODO: can this conversion be improved? + fkeys = S.filter p $ S.fromList $ M.keys fm -- | Helper to filter variable nodes and merge with those found so far -unionNodes :: (Label lb) => (lb -> Bool) -> [lb] -> [lb] -> [lb] -unionNodes p ls1 ls2 = ls1 `union` filter p ls2 +unionNodes :: (Label lb) => (lb -> Bool) -> S.Set lb -> S.Set lb -> S.Set lb +unionNodes p ls1 ls2 = ls1 `S.union` S.filter p ls2 +-- TODO: use S.Set lb rather than [lb] in the following + -- |Remap selected nodes in graph. -- -- This is the node renaming operation that prevents graph-scoped @@ -1300,8 +1333,10 @@ -- RDF query nodes into RDF blank nodes. -> NSGraph lb -- ^ graph in which nodes are to be renamed -> NSGraph lb -remapLabels dupbn allbn cnvbn = fmap (mapnode dupbn allbn cnvbn) +remapLabels dupbn allbn cnvbn = + fmapNSGraph (mapnode dupbn allbn cnvbn) + -- |Externally callable function to construct a list of (old,new) -- values to be used for graph label remapping. -- @@ -1319,7 +1354,7 @@ mapnode :: (Label lb) => [lb] -> [lb] -> (lb -> lb) -> lb -> lb mapnode dupbn allbn cnvbn nv = - mapFind nv nv (LookupMap (maplist dupbn allbn cnvbn [])) + M.findWithDefault nv nv $ M.fromList $ maplist dupbn allbn cnvbn [] -- | Construct a list of (oldnode,newnode) values to be used for -- graph label remapping. The function operates recursively, adding @@ -1387,7 +1422,7 @@ type RDFGraph = NSGraph RDFLabel --- |Create a new RDF graph from a supplied list of arcs. +-- |Create a new RDF graph from a supplied set of arcs. -- -- This version will attempt to fill up the namespace map -- of the graph based on the input labels (including datatypes @@ -1400,19 +1435,20 @@ -- and earlier. -- toRDFGraph :: - [RDFTriple] -- ^ There is no check to remove repeated statements in this list, - -- so it is suggested that you use 'Data.List.nub', or convert via 'Data.Set.Set', - -- if your input may contain such elements. + RDFArcSet -> RDFGraph toRDFGraph arcs = - let lbls = concatMap arcLabels arcs + let lbls = getComponents arcLabels arcs getNS (Res s) = Just s getNS (TypedLit _ dt) = Just dt getNS _ = Nothing - ns = mapMaybe (fmap getScopeNamespace . getNS) lbls - nsmap = foldl' mapAddIfNew emptyNamespaceMap ns + ns = mapMaybe (fmap getScopeNamespace . getNS) $ S.toList lbls + nsmap = foldl' + (\m ins -> let (p,u) = getNamespaceTuple ins + in M.insertWith (flip const) p u m) + emptyNamespaceMap ns in mempty { namespaces = nsmap, statements = arcs } diff --git a/src/Swish/RDF/Parser/N3.hs b/src/Swish/RDF/Parser/N3.hs --- a/src/Swish/RDF/Parser/N3.hs +++ b/src/Swish/RDF/Parser/N3.hs @@ -77,6 +77,7 @@ ( Namespace , ScopedName , makeNamespace + , getNamespaceTuple , getScopeNamespace , getScopedNameURI , getScopeNamespace @@ -138,15 +139,15 @@ import Control.Monad (forM_, foldM) import Data.Char (isSpace, isDigit, ord, isAsciiLower) -import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) -import Data.LookupMap (mapFind, mapFindMaybe, mapAdd, mapReplace) import Data.Maybe (fromMaybe, fromJust) import Data.Word (Word32) import Network.URI (URI(..), parseURIReference) +import Network.URI.Ord () import Text.ParserCombinators.Poly.StateText +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L @@ -170,13 +171,13 @@ setPrefix :: Maybe T.Text -> URI -> N3State -> N3State setPrefix pre uri st = st { prefixUris=p' } where - p' = mapReplace (prefixUris st) (makeNamespace pre uri) + p' = M.insert pre uri (prefixUris st) -- | Set name for special syntax element setSName :: String -> ScopedName -> N3State -> N3State setSName nam snam st = st { syntaxUris=s' } where - s' = mapReplace (syntaxUris st) (nam,snam) + s' = M.insert nam snam (syntaxUris st) setSUri :: String -> URI -> N3State -> N3State setSUri nam = setSName nam . makeURIScopedName @@ -190,14 +191,14 @@ -- | Get name for special syntax element, default null getSName :: N3State -> String -> ScopedName -getSName st nam = mapFind nullScopedName nam (syntaxUris st) +getSName st nam = M.findWithDefault nullScopedName nam $ syntaxUris st getSUri :: N3State -> String -> URI getSUri st nam = getScopedNameURI $ getSName st nam -- Map prefix to URI getPrefixURI :: N3State -> Maybe T.Text -> Maybe URI -getPrefixURI st pre = mapFindMaybe pre (prefixUris st) +getPrefixURI st pre = M.lookup pre (prefixUris st) getKeywordsList :: N3State -> [T.Text] getKeywordsList = keywordsList @@ -251,9 +252,9 @@ Maybe QName -- ^ starting base for the graph -> N3State emptyState mbase = - let pmap = LookupMap [makeNamespace Nothing hashURI] + let pmap = M.singleton Nothing hashURI muri = fmap (makeQNameScopedName Nothing) mbase - smap = LookupMap $ specialTable muri + smap = M.fromList $ specialTable muri in N3State { graphState = emptyRDFGraph , thisNode = NoNode @@ -311,7 +312,10 @@ -} addTestPrefixes :: N3Parser () -addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map +addTestPrefixes = stUpdate $ \st -> st { prefixUris = + M.fromList + $ map getNamespaceTuple prefixTable + } -- should append to existing map {- parsePrefixFromText :: L.Text -> Either String URI @@ -402,22 +406,20 @@ operatorLabel :: ScopedName -> N3Parser RDFLabel operatorLabel snam = do st <- stGet - let sns = getScopeNamespace snam + let (pkey, pval) = getNamespaceTuple $ getScopeNamespace snam opmap = prefixUris st - pkey = entryKey sns - pval = entryVal sns rval = Res snam - -- the lookup and the replacement could be fused - case mapFindMaybe pkey opmap of + -- TODO: the lookup and the replacement could be fused + case M.lookup pkey opmap of Just val | val == pval -> return rval | otherwise -> do - stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } + stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval _ -> do - stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } + stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval {- @@ -440,7 +442,8 @@ let stmt = arc s p o oldp = prefixUris ost ogs = graphState ost - newp = mapReplace oldp (getScopeNamespace dtype) + (ns, uri) = getNamespaceTuple $ getScopeNamespace dtype + newp = M.insert ns uri oldp stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) @@ -780,7 +783,7 @@ findPrefix :: T.Text -> N3Parser Namespace findPrefix pre = do st <- stGet - case mapFindMaybe (Just pre) (prefixUris st) of + case M.lookup (Just pre) (prefixUris st) of Just uri -> return $ makeNamespace (Just pre) uri Nothing -> failBad $ "Prefix '" ++ T.unpack pre ++ ":' not bound." diff --git a/src/Swish/RDF/Parser/Turtle.hs b/src/Swish/RDF/Parser/Turtle.hs --- a/src/Swish/RDF/Parser/Turtle.hs +++ b/src/Swish/RDF/Parser/Turtle.hs @@ -65,7 +65,8 @@ import Swish.GraphClass (arc) import Swish.Namespace (Namespace, ScopedName) -import Swish.Namespace (makeNamespace, getScopeNamespace, getScopedNameURI +import Swish.Namespace (makeNamespace, getNamespaceTuple + , getScopeNamespace, getScopedNameURI , getScopeNamespace, makeURIScopedName, makeNSScopedName) import Swish.QName (newLName, emptyLName) @@ -111,15 +112,15 @@ import Control.Monad (foldM) import Data.Char (chr, ord, isAsciiLower, isAsciiUpper, isDigit) -import Data.LookupMap (LookupMap(..), LookupEntryClass(..)) -import Data.LookupMap (mapFindMaybe, mapAdd, mapReplace) import Data.Maybe (fromMaybe, fromJust) import Data.Word (Word32) import Network.URI (URI(..), parseURIReference) +import Network.URI.Ord () import Text.ParserCombinators.Poly.StateText +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L @@ -140,7 +141,7 @@ setPrefix :: Maybe T.Text -> URI -> TurtleState -> TurtleState setPrefix pre uri st = st { prefixUris=p' } where - p' = mapReplace (prefixUris st) (makeNamespace pre uri) + p' = M.insert pre uri (prefixUris st) -- | Change the base setBase :: URI -> TurtleState -> TurtleState @@ -158,7 +159,7 @@ -- Map prefix to URI (naming needs a scrub here) getPrefixURI :: TurtleState -> Maybe T.Text -> Maybe URI -getPrefixURI st pre = mapFindMaybe pre (prefixUris st) +getPrefixURI st pre = M.lookup pre (prefixUris st) findPrefixNamespace :: Maybe L.Text -> TurtleParser Namespace findPrefixNamespace (Just p) = findPrefix (L.toStrict p) @@ -204,7 +205,7 @@ Maybe URI -- ^ starting base for the graph -> TurtleState emptyState mbase = - let pmap = LookupMap [makeNamespace Nothing hashURI] + let pmap = M.singleton Nothing hashURI buri = fromMaybe (getScopedNameURI defaultBase) mbase in TurtleState { graphState = emptyRDFGraph @@ -278,7 +279,8 @@ let stmt = arc s p o oldp = prefixUris ost ogs = graphState ost - newp = mapReplace oldp (getScopeNamespace dtype) + (nspre, nsuri) = getNamespaceTuple $ getScopeNamespace dtype + newp = M.insert nspre nsuri oldp stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) @@ -313,34 +315,34 @@ - could we use the reverse lookupmap functionality to find if the given namespace URI is in the namespace list? If it is, use it's key otherwise do a - mapReplace for the input namespace. + mapReplace for the input namespace (updated to use the + Data.Map.Map representation). -} operatorLabel :: ScopedName -> TurtleParser RDFLabel operatorLabel snam = do st <- stGet - let sns = getScopeNamespace snam + let (pkey, pval) = getNamespaceTuple $ getScopeNamespace snam opmap = prefixUris st - pkey = entryKey sns - pval = entryVal sns rval = Res snam - -- the lookup and the replacement could be fused - case mapFindMaybe pkey opmap of + -- TODO: the lookup and the replacement could be fused; it may not + -- even make sense to separate now using a Map + case M.lookup pkey opmap of Just val | val == pval -> return rval | otherwise -> do - stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } + stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval _ -> do - stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } + stUpdate $ \s -> s { prefixUris = M.insert pkey pval opmap } return rval findPrefix :: T.Text -> TurtleParser Namespace findPrefix pre = do st <- stGet - case mapFindMaybe (Just pre) (prefixUris st) of + case M.lookup (Just pre) (prefixUris st) of Just uri -> return $ makeNamespace (Just pre) uri Nothing -> failBad $ "Undefined prefix '" ++ T.unpack pre ++ ":'." diff --git a/src/Swish/RDF/Parser/Utils.hs b/src/Swish/RDF/Parser/Utils.hs --- a/src/Swish/RDF/Parser/Utils.hs +++ b/src/Swish/RDF/Parser/Utils.hs @@ -66,13 +66,13 @@ ) import Data.Char (isSpace, isHexDigit, chr) -import Data.LookupMap (LookupMap(..)) import Data.Maybe (fromMaybe, fromJust) import Network.URI (URI(..), relativeTo, parseURIReference) import Text.ParserCombinators.Poly.StateText +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Read as R @@ -94,26 +94,7 @@ _ -> Right uri -- | Type for special name lookup table -type SpecialMap = LookupMap (String, ScopedName) - -{- --- | Lookup prefix in table and return the matching URI. --- --- If the prefix is unknown then we currently error --- out (used to return 'prefix:' or ':' but now using --- URIs I am changing this behavior). This may well be --- backed out. -mapPrefix :: NamespaceMap -> Maybe String -> URI -mapPrefix pmap pfix = - case mapFindMaybe pfix pmap of - Just uri -> uri - Nothing -> error $ "Unable to find prefix: " ++ show pfix -- fromMaybe "" pfix ++ ":" --} - -{- -mapPrefix ps p@(Just pre) = mapFind (pre++":") p ps -mapPrefix ps _ = mapFind ":" Nothing ps --} +type SpecialMap = M.Map String ScopedName -- | Define default table of namespaces prefixTable :: [Namespace] diff --git a/src/Swish/RDF/Proof.hs b/src/Swish/RDF/Proof.hs --- a/src/Swish/RDF/Proof.hs +++ b/src/Swish/RDF/Proof.hs @@ -36,17 +36,19 @@ import Swish.Rule (Expression(..), Rule(..)) import Swish.VarBinding (makeVarBinding) -import Swish.RDF.Graph (RDFLabel(..), RDFGraph) +import Swish.RDF.Graph (RDFLabel(..), RDFGraph, fmapNSGraph) import Swish.RDF.Graph (merge, allLabels, remapLabelList) import Swish.RDF.Query (rdfQueryInstance, rdfQuerySubs) import Swish.RDF.Ruleset (RDFFormula, RDFRule, RDFRuleset) -import Swish.Utils.ListHelpers (subset, flist) +import Swish.Utils.ListHelpers (flist) import Data.List (subsequences) -import Data.LookupMap (makeLookupMap, mapFind) import Data.Monoid (Monoid(..)) +import qualified Data.Map as M +import qualified Data.Set as S + ------------------------------------------------------------ -- Type instantiation of Proof framework for RDFGraph data ------------------------------------------------------------ @@ -65,9 +67,10 @@ -- @Expression@ class, for which proofs can be constructed. -- The empty RDF graph is always @True@ (other enduring -- truths are asserted as axioms). -instance (Label lb, LDGraph lg lb) => Expression (lg lb) where - isValid = null . getArcs +instance (Label lb, LDGraph lg lb, Eq (lg lb)) => Expression (lg lb) where + isValid = S.null . getArcs + ------------------------------------------------------------ -- Define RDF-specific types for proof framework ------------------------------------------------------------ @@ -167,11 +170,13 @@ -- Obtain lists of variable and non-variable nodes -- (was: nonvarNodes = allLabels (not . labelIsVar) mergeGraph) nonvarNodes = vocab - varNodes = allLabels labelIsVar mergeGraph + varNodes = S.toList $ allLabels labelIsVar mergeGraph -- Obtain list of possible remappings for non-variable nodes mapList = remapLabelList nonvarNodes varNodes mapSubLists = (tail . subsequences) mapList - mapGr ls = fmap (\l -> mapFind l l (makeLookupMap ls)) + mapGr ls = fmapNSGraph + (\l -> M.findWithDefault l l + (M.fromList ls)) in -- Return all remappings of the original merged graph flist (map mapGr mapSubLists) mergeGraph @@ -190,7 +195,7 @@ rdfInstanceEntailBwdApply vocab cons = let -- Obtain list of variable nodes - varNodes = allLabels labelIsVar cons + varNodes = S.toList $ allLabels labelIsVar cons -- Generate a substitution for each combination of variable -- and vocabulary node. varBindings = map (makeVarBinding . zip varNodes) vocSequences @@ -298,7 +303,8 @@ else foldl1 merge ante in -- Return all subgraphs of the full graph constructed above - map (setArcs mergeGraph) (init $ tail $ subsequences $ getArcs mergeGraph) + -- TODO: update to use sets as appropriate + map (setArcs mergeGraph . S.fromList) (init $ tail $ subsequences $ S.toList $ getArcs mergeGraph) -- Subgraph entailment inference checker -- @@ -313,7 +319,7 @@ else foldl1 addGraphs ante in -- Check each consequent graph arc is in the antecedent graph - getArcs cons `subset` getArcs fullGraph + getArcs cons `S.isSubsetOf` getArcs fullGraph ------------------------------------------------------------ -- RDF simple entailment inference rule diff --git a/src/Swish/RDF/Query.hs b/src/Swish/RDF/Query.hs --- a/src/Swish/RDF/Query.hs +++ b/src/Swish/RDF/Query.hs @@ -67,6 +67,7 @@ , resRdfFirst , resRdfRest , resRdfNil + , traverseNSGraph ) import Swish.RDF.VarBinding (RDFVarBinding, RDFVarBindingFilter) @@ -85,12 +86,18 @@ import Data.Monoid (Monoid(..)) import qualified Data.Set as S -import qualified Data.Traversable as Traversable ------------------------------------------------------------ -- Primitive RDF graph queries ------------------------------------------------------------ +-- Get a list of arcs from a graph. +-- +-- Can we update the routines to work with sets instead? + +getTriples :: RDFGraph -> [RDFTriple] +getTriples = S.toList . getArcs + -- | Basic graph-query function. -- -- The triples of the query graph are matched sequentially @@ -106,7 +113,7 @@ -- ^ Each element represents a set of variable bindings that make the query graph a -- subgraph of the target graph. The list can be empty. rdfQueryFind = - rdfQueryPrim1 matchQueryVariable nullRDFVarBinding . getArcs + rdfQueryPrim1 matchQueryVariable nullRDFVarBinding . getTriples -- Helper function to match query against a graph. -- A node-query function is supplied to determine how query nodes @@ -119,15 +126,13 @@ -> [RDFVarBinding] rdfQueryPrim1 _ initv [] _ = [initv] rdfQueryPrim1 nodeq initv (qa:qas) tg = - let - qam = fmap (applyVarBinding initv) qa -- subst vars already bound + let qam = fmap (applyVarBinding initv) qa -- subst vars already bound newv = rdfQueryPrim2 nodeq qam tg -- new bindings, or null - in - concat - [ rdfQueryPrim1 nodeq v2 qas tg - | v1 <- newv - , let v2 = joinVarBindings initv v1 - ] + in concat + [ rdfQueryPrim1 nodeq v2 qas tg + | v1 <- newv + , let v2 = joinVarBindings initv v1 + ] -- Match single query term against graph, and return any new sets -- of variable bindings thus defined, or [] if the query term @@ -139,7 +144,7 @@ -> RDFGraph -> [RDFVarBinding] rdfQueryPrim2 nodeq qa tg = - mapMaybe (getBinding nodeq qa) (getArcs tg) + mapMaybe (getBinding nodeq qa) (S.toList $ getArcs tg) -- |RDF query filter. -- @@ -195,9 +200,13 @@ -- An empty outer list is returned if no combination of -- substitutions can infer the supplied target. -- -rdfQueryBack :: RDFGraph -> RDFGraph -> [[RDFVarBinding]] +rdfQueryBack :: + RDFGraph -- ^ Query graph + -> RDFGraph -- ^ Target graph + -> [[RDFVarBinding]] rdfQueryBack qg tg = - rdfQueryBack1 matchQueryVariable [] (getArcs qg) (getArcs tg) + let ga = getTriples + in rdfQueryBack1 matchQueryVariable [] (ga qg) (ga tg) rdfQueryBack1 :: NodeQuery RDFLabel -> [RDFVarBinding] -> [Arc RDFLabel] -> [Arc RDFLabel] @@ -281,7 +290,7 @@ -- has been concluded. rdfQueryInstance :: RDFGraph -> RDFGraph -> [RDFVarBinding] rdfQueryInstance = - rdfQueryPrim1 matchQueryBnode nullRDFVarBinding . getArcs + rdfQueryPrim1 matchQueryBnode nullRDFVarBinding . getTriples ------------------------------------------------------------ -- Primitive RDF graph query support functions @@ -382,7 +391,7 @@ [ remapLabels vs bs makeBlank g | v <- vars , let (g,vs) = rdfQuerySubs2 v gr - , let bs = allLabels isBlank g + , let bs = S.toList $ allLabels isBlank g ] -- |Graph back-substitution function, replacing variables with bnodes. @@ -404,10 +413,10 @@ -- unbound variables. -- -- Adding an empty graph forces elimination of duplicate arcs. -rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph,[RDFLabel]) -rdfQuerySubs2 varb gr = (addGraphs mempty g, S.toList vs) +rdfQuerySubs2 :: RDFVarBinding -> RDFGraph -> (RDFGraph, [RDFLabel]) +rdfQuerySubs2 varb gr = (addGraphs mempty g, S.toList vs) -- the addgraphs part is important, possibly just to remove duplicated entries where - (g,vs) = runState ( Traversable.traverse (mapNode varb) gr ) S.empty + (g,vs) = runState (traverseNSGraph (mapNode varb) gr) S.empty -- Auxiliary monad function for rdfQuerySubs2. -- This returns a state transformer Monad which in turn returns the @@ -477,7 +486,7 @@ -- Custom predicates can also be used. -- rdfFindArcs :: (RDFTriple -> Bool) -> RDFGraph -> [RDFTriple] -rdfFindArcs p = filter p . getArcs +rdfFindArcs p = S.toList . S.filter p . getArcs -- |Test if statement has given subject rdfSubjEq :: RDFLabel -> RDFTriple -> Bool diff --git a/src/Swish/RDF/Ruleset.hs b/src/Swish/RDF/Ruleset.hs --- a/src/Swish/RDF/Ruleset.hs +++ b/src/Swish/RDF/Ruleset.hs @@ -48,7 +48,7 @@ import Swish.Rule (Formula(..), Rule(..), RuleMap) import Swish.Rule (fwdCheckInference, nullSN) import Swish.Ruleset (Ruleset(..), RulesetMap) -import Swish.GraphClass (Label(..), Arc(..), LDGraph(..)) +import Swish.GraphClass (Label(..), ArcSet, LDGraph(..)) import Swish.VarBinding (VarBindingModify(..)) import Swish.VarBinding (makeVarBinding, applyVarBinding, joinVarBindings, vbmCompose, varBindingId) @@ -60,7 +60,7 @@ ) import Swish.RDF.Graph - ( RDFLabel(..), RDFGraph + ( RDFLabel(..), RDFGraph, RDFArcSet , makeBlank, newNodes , merge, allLabels , toRDFGraph) @@ -70,12 +70,13 @@ import Swish.RDF.Vocabulary (swishName, namespaceRDF, namespaceRDFS) -import Swish.Utils.ListHelpers (equiv, flist) +import Swish.Utils.ListHelpers (flist) import Data.List (nub) import Data.Maybe (fromMaybe) import Data.Monoid (Monoid(..)) +import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B ------------------------------------------------------------ @@ -88,7 +89,7 @@ -- | A named inference rule expressed in RDF. type RDFRule = Rule RDFGraph --- | A 'LookupMap' for 'RDFRule' rules. +-- | A map for 'RDFRule' rules. type RDFRuleMap = RuleMap RDFGraph -- | A 'GraphClosure' for RDF statements. @@ -97,7 +98,7 @@ -- | A 'Ruleset' for RDF. type RDFRuleset = Ruleset RDFGraph --- | 'LookupMap' for 'RDFRuleset'. +-- | A map for 'RDFRuleset'. type RDFRulesetMap = RulesetMap RDFGraph ------------------------------------------------------------ @@ -118,9 +119,9 @@ -- |Datatype for constructing a graph closure rule data GraphClosure lb = GraphClosure { nameGraphRule :: ScopedName -- ^ Name of rule for proof display - , ruleAnt :: [Arc lb] -- ^ Antecedent triples pattern + , ruleAnt :: ArcSet lb -- ^ Antecedent triples pattern -- (may include variable nodes) - , ruleCon :: [Arc lb] -- ^ Consequent triples pattern + , ruleCon :: ArcSet lb -- ^ Consequent triples pattern -- (may include variable nodes) , ruleModify :: VarBindingModify lb lb -- ^ Structure that defines additional @@ -133,10 +134,12 @@ -- arising from graph queries. } +-- | Equality is based on the closure rule, anrecedents and +-- consequents. instance (Label lb) => Eq (GraphClosure lb) where c1 == c2 = nameGraphRule c1 == nameGraphRule c2 && - ruleAnt c1 `equiv` ruleAnt c2 && - ruleCon c1 `equiv` ruleCon c2 + ruleAnt c1 == ruleAnt c2 && + ruleCon c1 == ruleCon c2 instance (Label lb) => Show (GraphClosure lb) where show c = "GraphClosure " ++ show (nameGraphRule c) @@ -213,16 +216,16 @@ -- RDF graph query and substitution support functions ------------------------------------------------------------ -queryFind :: [Arc RDFLabel] -> RDFGraph -> [RDFVarBinding] +queryFind :: RDFArcSet -> RDFGraph -> [RDFVarBinding] queryFind qas = rdfQueryFind (toRDFGraph qas) -queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] +queryBack :: RDFArcSet -> RDFGraph -> [[RDFVarBinding]] queryBack qas = rdfQueryBack (toRDFGraph qas) -querySubs :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubs :: [RDFVarBinding] -> RDFArcSet -> [RDFGraph] querySubs vars = rdfQuerySubs vars . toRDFGraph -querySubsBlank :: [RDFVarBinding] -> [Arc RDFLabel] -> [RDFGraph] +querySubsBlank :: [RDFVarBinding] -> RDFArcSet -> [RDFGraph] querySubsBlank vars = rdfQuerySubsBlank vars . toRDFGraph ------------------------------------------------------------ @@ -293,7 +296,7 @@ makeRDFClosureRule sname antgrs congr vmod = makeGraphClosureRule GraphClosure { nameGraphRule = sname - , ruleAnt = concatMap getArcs antgrs + , ruleAnt = S.unions $ map getArcs antgrs , ruleCon = getArcs congr , ruleModify = vmod } @@ -429,7 +432,7 @@ where antgr = makeRDFGraphFromN3Builder ant congr = makeRDFGraphFromN3Builder con - vmod = aloc (allLabels labelIsVar antgr) + vmod = aloc $ S.toList (allLabels labelIsVar antgr) modc = fromMaybe varBindingId $ vbmCompose vmod vflt ------------------------------------------------------------ diff --git a/src/Swish/RDF/VarBinding.hs b/src/Swish/RDF/VarBinding.hs --- a/src/Swish/RDF/VarBinding.hs +++ b/src/Swish/RDF/VarBinding.hs @@ -32,6 +32,7 @@ ) where +import Swish.Namespace (ScopedName) import Swish.VarBinding (VarBinding(..), VarBindingModify(..), OpenVarBindingModify, VarBindingFilter(..)) import Swish.VarBinding (nullVarBinding, applyVarBinding, makeVarTestFilter) @@ -42,7 +43,7 @@ ) import Swish.RDF.Vocabulary (swishName) -import Data.LookupMap (LookupMap(..)) +import qualified Data.Map as M ------------------------------------------------------------ -- Types for RDF query variable bindings and modifiers @@ -64,7 +65,7 @@ type RDFOpenVarBindingModify = OpenVarBindingModify RDFLabel RDFLabel -- |Define type for lookup map of open query binding modifiers -type RDFOpenVarBindingModifyMap = LookupMap RDFOpenVarBindingModify +type RDFOpenVarBindingModifyMap = M.Map ScopedName RDFOpenVarBindingModify -- |@RDFVarBindingFilter@ is a function type that tests to see if -- a query binding satisfies some criterion, and is used to diff --git a/src/Swish/RDF/Vocabulary.hs b/src/Swish/RDF/Vocabulary.hs --- a/src/Swish/RDF/Vocabulary.hs +++ b/src/Swish/RDF/Vocabulary.hs @@ -203,6 +203,9 @@ instance Eq LanguageTag where LanguageTag _ t1 == LanguageTag _ t2 = t1 == t2 +instance Ord LanguageTag where + LanguageTag _ t1 `compare` LanguageTag _ t2 = t1 `compare` t2 + -- | Create a 'LanguageTag' element from the label. -- -- Valid tags follow the ABNF from RCF 3066, which is diff --git a/src/Swish/Rule.hs b/src/Swish/Rule.hs --- a/src/Swish/Rule.hs +++ b/src/Swish/Rule.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------------------- @@ -11,7 +10,7 @@ -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : MultiParamTypeClasses, OverloadedStrings +-- Portability : OverloadedStrings -- -- This module defines a framework for defining inference rules -- over some expression form. It is intended to be used with @@ -32,12 +31,13 @@ import Swish.Namespace (makeNamespace, makeNSScopedName) import Swish.QName (LName) -import Data.LookupMap (LookupEntryClass(..), LookupMap(..)) import Data.Maybe (fromJust) import Data.String.ShowLines (ShowLines(..)) import Network.URI (URI, parseURI) +import qualified Data.Map as M + ------------------------------------------------------------ -- Expressions ------------------------------------------------------------ @@ -67,11 +67,6 @@ instance Ord (Formula ex) where f1 <= f2 = formName f1 <= formName f2 -instance LookupEntryClass (Formula ex) ScopedName (Formula ex) - where - newEntry (_,form) = form - keyVal form = (formName form, form) - -- | The namespace @http:\/\/id.ninebynine.org\/2003\/Ruleset\/null@ with the prefix @null:@. nullScope :: Namespace nullScope = makeNamespace (Just "null") nullScopeURI @@ -175,13 +170,8 @@ instance Show (Rule ex) where show rl = "Rule "++show (ruleName rl) -instance LookupEntryClass (Rule ex) ScopedName (Rule ex) - where - newEntry (_,rule) = rule - keyVal rule = (ruleName rule, rule) - --- | A 'LookupMap' for a 'Rule'. -type RuleMap ex = LookupMap (Rule ex) +-- | A set of rules labelled with their name. +type RuleMap ex = M.Map ScopedName (Rule ex) -- | Checks that consequence is a result of -- applying the rule to the antecedants. diff --git a/src/Swish/Ruleset.hs b/src/Swish/Ruleset.hs --- a/src/Swish/Ruleset.hs +++ b/src/Swish/Ruleset.hs @@ -1,5 +1,3 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -------------------------------------------------------------------------------- -- See end of this file for licence information. -------------------------------------------------------------------------------- @@ -10,7 +8,7 @@ -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : MultiParamTypeClasses +-- Portability : H98 -- -- This module defines a ruleset data type, used to collect information -- about a ruleset that may contribute torwards inferences in RDF; @@ -42,9 +40,10 @@ import Data.List (intercalate) -} -import Data.LookupMap (LookupEntryClass(..), LookupMap(..), mapFindMaybe) import Data.Maybe (fromMaybe, listToMaybe, mapMaybe) +import qualified Data.Map as M + -- | A Rule set. data Ruleset ex = Ruleset @@ -70,13 +69,8 @@ instance Eq (Ruleset ex) where r1 == r2 = rsNamespace r1 == rsNamespace r2 -instance LookupEntryClass (Ruleset ex) Namespace (Ruleset ex) - where - keyVal r@(Ruleset k _ _) = (k,r) - newEntry (_,r) = r - --- | A 'LookupMap' for a 'Ruleset'. -type RulesetMap ex = LookupMap (Ruleset ex) +-- | A set of Rulesets labelled by their Namespace. +type RulesetMap ex = M.Map Namespace (Ruleset ex) -- | Create a ruleset. makeRuleset :: Namespace -> [Formula ex] -> [Rule ex] -> Ruleset ex @@ -101,14 +95,12 @@ -- | Find a named axiom in a ruleset. getRulesetAxiom :: ScopedName -> Ruleset ex -> Maybe (Formula ex) getRulesetAxiom nam rset = - mapFindMaybe nam (LookupMap (getRulesetAxioms rset)) - -- listToMaybe $ filter ( (matchName nam) . formName ) $ getRulesetAxioms rset + M.lookup nam $ M.fromList $ map (\f -> (formName f, f)) (rsAxioms rset) -- | Find a named rule in a ruleset. getRulesetRule :: ScopedName -> Ruleset ex -> Maybe (Rule ex) getRulesetRule nam rset = - mapFindMaybe nam (LookupMap (getRulesetRules rset)) - -- listToMaybe $ filter ( (matchName nam) . ruleName ) $ getRulesetRules rset + M.lookup nam $ M.fromList $ map (\r -> (ruleName r, r)) (rsRules rset) -- | Find a named axiom in a proof context. getContextAxiom :: @@ -117,9 +109,6 @@ -> [Ruleset ex] -- ^ Rulesets to search. -> Formula ex getContextAxiom nam def rsets = fromMaybe def (getMaybeContextAxiom nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetAxiom nam) rsets - -} -- | Find a named axiom in a proof context. getMaybeContextAxiom :: @@ -136,9 +125,6 @@ -> [Ruleset ex] -- ^ Rulesets to search. -> Rule ex getContextRule nam def rsets = fromMaybe def (getMaybeContextRule nam rsets) - {- - foldr (flip fromMaybe) def $ map (getRulesetRule nam) rsets - -} -- | Find a named rule in a proof context. getMaybeContextRule :: diff --git a/src/Swish/Script.hs b/src/Swish/Script.hs --- a/src/Swish/Script.hs +++ b/src/Swish/Script.hs @@ -72,7 +72,7 @@ where import Swish.Datatype (typeMkRules) -import Swish.Monad ( SwishStateIO, SwishStatus(..), NamedGraph(..)) +import Swish.Monad ( SwishStateIO, SwishStatus(..)) import Swish.Monad (modGraphs, findGraph, findFormula , modRules, findRule , modRulesets, findRuleset @@ -80,7 +80,7 @@ , setInfo, setError, setStatus) import Swish.Proof (explainProof, showsProof) import Swish.Rule (Formula(..), Rule(..)) -import Swish.Ruleset (makeRuleset, getRulesetRule, getMaybeContextRule) +import Swish.Ruleset (makeRuleset, getRulesetRule, getRulesetNamespace, getMaybeContextRule) import Swish.VarBinding (composeSequence) import Swish.RDF.Datatype (RDFDatatype) @@ -119,23 +119,24 @@ import Swish.RDF.Formatter.N3 (formatGraphAsBuilder) -import Swish.Utils.ListHelpers (equiv, flist) +import Swish.Utils.ListHelpers (flist) -import qualified Data.Text.Lazy as L -import qualified Data.Text.Lazy.Builder as B -import qualified Data.Text.Lazy.IO as LIO import Text.ParserCombinators.Poly.StateText import Control.Monad (unless, when, liftM, void) import Control.Monad.State (modify, gets, lift) -import Data.LookupMap (mapReplace) import Data.Monoid (Monoid(..)) import Network.URI (URI(..)) -import qualified System.IO.Error as IO import qualified Control.Exception as CE +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B +import qualified Data.Text.Lazy.IO as LIO +import qualified System.IO.Error as IO ------------------------------------------------------------ -- @@ -460,7 +461,7 @@ ; let egs = sequence esg -- Either String [RDFGraph] ; let fgs = case egs of Left er -> setError (errmsg++er) - Right gs -> modGraphs (`mapReplace` NamedGraph nam gs) + Right gs -> modGraphs (M.insert nam gs) ; modify fgs } @@ -547,7 +548,7 @@ ; let fgs = case egs of Left er -> setError (errmsg++er) Right [] -> setError (errmsg++"No graphs to merge") - Right gs -> modGraphs (`mapReplace` NamedGraph nam [g]) + Right gs -> modGraphs (M.insert nam [g]) where g = foldl1 merge gs ; modify fgs } @@ -571,7 +572,7 @@ (Left er,_) -> modify $ setError (comment++er1++"\n "++er) (_,Left er) -> modify $ setError (comment++er1++"\n "++er) (Right gr1,Right gr2) -> - unless (equiv gr1 gr2) $ modify $ + when (S.fromList gr1 /= S.fromList gr2) $ modify $ setError (comment++":\n Graph "++show n1 ++" differs from "++show n2++".") } @@ -629,7 +630,7 @@ newRule = makeRDFClosureRule rn agrs cgr in case composeSequence vbms of - Just vm -> modRules (`mapReplace` newRule vm) + Just vm -> let nr = newRule vm in modRules (M.insert (ruleName nr) nr) Nothing -> setError errmsg4 ; modify frl } @@ -662,7 +663,7 @@ (Left er,_) -> setError (errmsg1++er) (_,Left er) -> setError (errmsg2++er) (Right ags,Right rls) -> - modRulesets (`mapReplace` rs) + modRulesets (M.insert (getRulesetNamespace rs) rs) where rs = makeRuleset (getScopeNamespace sn) ags rls ; modify frs @@ -697,7 +698,7 @@ (Left er,_) -> setError (errmsg1++er) (_,Left er) -> setError (errmsg2++er) (Right cgr,Right dts) -> - modRulesets (`mapReplace` rs) + modRulesets (M.insert (getRulesetNamespace rs) rs) where rs = makeRuleset (getScopeNamespace sn) [] rls rls = concatMap (`typeMkRules` cgr) dts @@ -812,7 +813,7 @@ (Left er,_) -> setError (errmsg1++er) (_,Left er) -> setError (errmsg2++er) (Right rl,Right ags) -> - modGraphs (`mapReplace` NamedGraph cn [cg]) + modGraphs (M.insert cn [cg]) where cg = case fwdApply rl ags of [] -> mempty @@ -857,7 +858,7 @@ (Left er,_) -> setError (errmsg1++er) (_,Left er) -> setError (errmsg2++er) (Right rl,Right cg) -> - modGraphs (`mapReplace` NamedGraph an ags) + modGraphs (M.insert an ags) where ags = map mergegr (bwdApply rl cg) mergegr grs = case grs of diff --git a/src/Swish/Utils/ListHelpers.hs b/src/Swish/Utils/ListHelpers.hs --- a/src/Swish/Utils/ListHelpers.hs +++ b/src/Swish/Utils/ListHelpers.hs @@ -10,41 +10,9 @@ -- Stability : experimental -- Portability : H98 -- --- This module defines some generic list and related helper functions. The plan --- is to move to using functionality from other modules (e.g. containers) where --- possible. --- -------------------------------------------------------------------------------- -module Swish.Utils.ListHelpers - ( -- list of modules the routine is used in - subset -- Proof, RDF.Proof, VarBinding [also defined in Data.Ord.Partial] - , equiv -- GraphMatch, RDF.Ruleset, Script, VarBinding, Data.LookupMap - , flist -- Datatype, RDF.Proof, RDF.Ruleset, Script, VarBinding, ... - - ) -where - ------------------------------------------------------------- --- Set functions --- --- NOTE: to change to Data.Set then Eq a constraint will --- likely need changing to Ord a ------------------------------------------------------------- - --- |Subset test - -subset :: (Eq a) => [a] -> [a] -> Bool -a `subset` b = and [ ma `elem` b | ma <- a ] - --- |Set equivalence test - -equiv :: (Eq a) => [a] -> [a] -> Bool -a `equiv` b = a `subset` b && b `subset` a - ------------------------------------------------------------- --- Functions, lists and monads ------------------------------------------------------------- +module Swish.Utils.ListHelpers (flist) where -- |Apply list of functions to some value, returning list of results. -- It's kind of like an converse map. diff --git a/src/Swish/VarBinding.hs b/src/Swish/VarBinding.hs --- a/src/Swish/VarBinding.hs +++ b/src/Swish/VarBinding.hs @@ -1,5 +1,4 @@ {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -13,7 +12,7 @@ -- -- Maintainer : Douglas Burke -- Stability : experimental --- Portability : FlexibleInstances, MultiParamTypeClasses, OverloadedStrings, TypeSynonymInstances +-- Portability : FlexibleInstances, OverloadedStrings, TypeSynonymInstances -- -- This module defines functions for representing and manipulating query -- binding variable sets. This is the key data that mediates between @@ -29,6 +28,7 @@ , boundVars, subBinding, makeVarBinding , applyVarBinding, joinVarBindings, addVarBinding , VarBindingModify(..), OpenVarBindingModify + , openVbmName , vbmCompatibility, vbmCompose , composeSequence, findCompositions, findComposition , VarBindingFilter(..) @@ -45,73 +45,89 @@ import Swish.RDF.Vocabulary (swishName) -import Swish.Utils.ListHelpers (equiv, subset, flist) +import Swish.Utils.ListHelpers (flist) +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (mplus) + +import Data.Function (on) import Data.List (find, intersect, union, (\\), foldl', permutations) -import Data.LookupMap (LookupEntryClass(..), makeLookupMap, mapFindMaybe) import Data.Maybe (mapMaybe, fromMaybe, isJust, fromJust, listToMaybe) -import Data.Monoid (mconcat) +import Data.Monoid (Monoid(..), mconcat) +import Data.Ord (comparing) +import qualified Data.Map as M +import qualified Data.Set as S + ------------------------------------------------------------ -- Query variable bindings ------------------------------------------------------------ --- TODO: is it worth making a Monoid instance of VarBinding? - -- |VarBinding is the type of an arbitrary variable bindings -- value, where the type of the bound values is not specified. -- data VarBinding a b = VarBinding { vbMap :: a -> Maybe b - , vbEnum :: [(a,b)] + , vbEnum :: S.Set (a,b) , vbNull :: Bool } --- |VarBinding is an instance of class Eq, so that variable --- bindings can be compared for equivalence +-- | The Eq instance is defined as the set equivalence of the +-- pairs of variables in the binding. -- -instance (Eq a, Eq b) => Eq (VarBinding a b) where - vb1 == vb2 = vbEnum vb1 `equiv` vbEnum vb2 +instance (Ord a, Ord b) => Eq (VarBinding a b) where + (==) = (==) `on` vbEnum --- |VarBinding is an instance of class Show, so that variable --- bindings can be displayed +-- | The Ord instance is defined only on the pairs of +-- variables in the binding. +instance (Ord a, Ord b) => Ord (VarBinding a b) where + compare = comparing vbEnum + +-- | When combining instances, if there is an overlapping binding then +-- the value from the first instance is used. +instance (Ord a, Ord b) => Monoid (VarBinding a b) where + mempty = nullVarBinding + mappend = joinVarBindings + +-- | The Show instance only displays the pairs of variables +-- in the binding. -- instance (Show a, Show b) => Show (VarBinding a b) where - show = show . vbEnum + show = show . S.toList . vbEnum --- | maps no query variables. +-- | The null, or empry, binding maps no query variables. +-- This is the 'mempty' instance of the Monoid. -- nullVarBinding :: VarBinding a b nullVarBinding = VarBinding { vbMap = const Nothing - , vbEnum = [] + , vbEnum = S.empty , vbNull = True } -- |Return a list of the variables bound by a supplied variable binding -- -boundVars :: VarBinding a b -> [a] -boundVars = map fst . vbEnum +boundVars :: (Ord a, Ord b) => VarBinding a b -> S.Set a +boundVars = S.map fst . vbEnum -- |VarBinding subset function, tests to see if one query binding -- is a subset of another; i.e. every query variable mapping defined -- by one is also defined by the other. -- -subBinding :: (Eq a, Eq b) => VarBinding a b -> VarBinding a b -> Bool -subBinding vb1 vb2 = vbEnum vb1 `subset` vbEnum vb2 +subBinding :: (Ord a, Ord b) => VarBinding a b -> VarBinding a b -> Bool +subBinding = S.isSubsetOf `on` vbEnum -- |Function to make a variable binding from a list of -- pairs of variable and corresponding assigned value. -- -makeVarBinding :: (Eq a, Show a, Eq b, Show b) => [(a,b)] -> VarBinding a b +makeVarBinding :: (Ord a, Ord b) => [(a,b)] -> VarBinding a b makeVarBinding [] = nullVarBinding makeVarBinding vrbs = - let selectFrom = flip mapFindMaybe . makeLookupMap - in VarBinding - { vbMap = selectFrom vrbs - , vbEnum = vrbs - , vbNull = False - } + VarBinding + { vbMap = flip M.lookup (M.fromList vrbs) + , vbEnum = S.fromList vrbs + , vbNull = False + } -- |Apply query binding to a supplied value, returning the value -- unchanged if no binding is defined @@ -122,35 +138,30 @@ -- |Join a pair of query bindings, returning a new binding that -- maps all variables recognized by either of the input bindings. -- If the bindings should overlap, such overlap is not detected and --- the value from the first binding provided is used arbitrarily. +-- the value from the first binding provided is used. -- -joinVarBindings :: (Eq a) => VarBinding a b -> VarBinding a b -> VarBinding a b +joinVarBindings :: (Ord a, Ord b) => VarBinding a b -> VarBinding a b -> VarBinding a b joinVarBindings vb1 vb2 | vbNull vb1 = vb2 | vbNull vb2 = vb1 | otherwise = VarBinding { vbMap = mv12 - , vbEnum = map (\v -> (v,fromJust (mv12 v))) bv12 + , vbEnum = S.map (\v -> (v,fromJust (mv12 v))) bv12 , vbNull = False } where - mv12 = headOrNothing . filter isJust . flist [ vbMap vb1, vbMap vb2 ] - bv12 = boundVars vb1 `union` boundVars vb2 - --- |Return head of a list of @Maybe@'s, or @Nothing@ if list is empty --- --- Use with @filter isJust@ to select a non-Nothing value from a --- list when such a value is present. --- -headOrNothing :: [Maybe a] -> Maybe a -headOrNothing [] = Nothing -headOrNothing (a:_) = a + mv12 n = vbMap vb1 n `mplus` vbMap vb2 n + bv12 = boundVars vb1 `S.union` boundVars vb2 -- |Add a single new value to a variable binding and return the resulting -- new variable binding. -- -addVarBinding :: (Eq a, Show a, Eq b, Show b) => a -> b -> VarBinding a b +addVarBinding :: + (Ord a, Ord b) + => a + -> b -> VarBinding a b + -> VarBinding a b addVarBinding lb val vbind = joinVarBindings vbind $ makeVarBinding [(lb,val)] ------------------------------------------------------------ @@ -216,14 +227,6 @@ -- variables in @vbmVocab@ are supplied. } --- |Allow a VarBindingModify value to be accessed using a 'LookupMap'. --- -instance LookupEntryClass - (VarBindingModify a b) ScopedName (VarBindingModify a b) - where - keyVal vbm = (vbmName vbm,vbm) - newEntry (_,vbm) = vbm - -- |Type for variable binding modifier that has yet to be instantiated -- with respect to the variables that it operates upon. -- @@ -242,16 +245,7 @@ openVbmName :: OpenVarBindingModify lb vn -> ScopedName openVbmName ovbm = vbmName (ovbm (error "Undefined labels in variable binding")) --- |Allow an @OpenVarBindingModify@ value to be accessed using a @LookupMap@. --- -instance LookupEntryClass - (OpenVarBindingModify a b) ScopedName (OpenVarBindingModify a b) - where - keyVal ovbm = (openVbmName ovbm,ovbm) - newEntry (_,ovbm) = ovbm - --- |Allow an OpenVarBindingModify value to be accessed using a LookupMap. --- +-- | Displays the name of the modifier. instance Show (OpenVarBindingModify a b) where show = show . openVbmName @@ -458,9 +452,7 @@ makeVarTestFilter nam vtest var = VarBindingFilter { vbfName = nam , vbfVocab = [var] - , vbfTest = \vb -> case vbMap vb var of - Just val -> vtest val - _ -> False + , vbfTest = \vb -> maybe False vtest (vbMap vb var) } -- |Make a variable comparison filter for named variables using @@ -470,9 +462,7 @@ makeVarCompareFilter nam vcomp v1 v2 = VarBindingFilter { vbfName = nam , vbfVocab = [v1,v2] - , vbfTest = \vb -> case (vbMap vb v1,vbMap vb v2) of - (Just val1, Just val2) -> vcomp val1 val2 - _ -> False + , vbfTest = \vb -> fromMaybe False (vcomp <$> vbMap vb v1 <*> vbMap vb v2) } ------------------------------------------------------------ diff --git a/swish.cabal b/swish.cabal --- a/swish.cabal +++ b/swish.cabal @@ -1,5 +1,5 @@ Name: swish -Version: 0.7.0.2 +Version: 0.8.0.0 Stability: experimental License: LGPL License-file: LICENSE @@ -44,88 +44,30 @@ . * Complete, ready-to-run, command-line and script-driven programs. . - Changes in version @0.7.0.2@: - . - * The @Swish.QName.LName@ type now requires all characters to be - ASCII. This avoids downstream errors when trying to convert a - @QName@ to a @URI@. - . - Changes in version @0.7.0.1@: - . - * Internal changes to parsing of URI values for NTriples, Turtle, and N3 - parsers (error messages will be slightly different when IRIs are used). - Unfortunately IRIs are still not supported. - . - Changes in version @0.7.0.0@: - . - For code that uses the Swish script language, the main change is to import @Swish@ rather - than @Swish.RDF.SwishMain@, and to note that the other @Swish.RDF.Swish*@ modules are - now called @Swish.*@. - . - For code that uses the graph library, the main changes are that @Swish.RDF.RDFGraph@ - is now called @Swish.RDF.Graph@, the @Lit@ constructor of the @RDFLabel@ has been split - into three (@Lit@, @LangLit@, and @TypedLit@) and a new @LanguageTag@ type introduced, - local names now use the @LName@ type (previously they were just @Text@ values), and the - parsers and formatters have renamed to - @Swish.RDF.Parser.*@ and @Swish.RDF.Formatter.*@. - . - * Moved a number of modules around: generic code directly into @Swish@ - and the @Swish.RDF.RDF*@ forms renamed to @Swish.RDF.*@. Some modules - have been moved out of the @Swish.Utils.*@ namespace. Generic modules - have been placed into the @Data.*@ namespace. The @Swish.RDF.Swish*@ - modules have been moved to @Swish.*@ and @Swish.RDF.SwishMain@ has - been removed; use @Swish@ instead. - . - * Parsing modules are now in the @Swish.RDF.Parser@ hierarchy and - @Swish.RDF.RDFParser@ has been renamed to @Swish.RDF.Parser.Utils@. - . - * Formatting modules are now in the @Swish.RDF.Formatter@ hierarchy. - . - * RDF literals are now stored using the @Lit@, @LangLit@, or @TypedLit@ constructors - (@RDFLabel@) rather than using just @Lit@. Language codes are now represented - by @Swish.RDF.Vocabulary.LanguageTag@ rather than as a @ScopedName@. - . - * Local names are now represented by the @Swish.QName.LName@ type - rather than as a @Text@ value. A few routines now return a @Maybe@ value - rather than error-ing out on invalid input. - . - * Make use of @Data.List.NonEmpty@ in a few cases. - . - * Removed @mkTypedLit@ from @Swish.RDF.RDFParser@; use - @Swish.RDF.RDFDatatype.makeDataTypedLiteral@ instead. - . - * Removed @asubj@, @apred@ and @aobj@ from @Swish.RDF.GraphClass@ and - @Swish.RDF.RDFGraph@; use @arcSubj@, @arcPred@ or @arcObj@ instead. - . - * Removed un-used @containedIn@ element of the @LDGraph@ type class. - The arguments to @setArcs@ have been flipped, @replaceArcs@ removed, - @add@ renamed to @addGraphs@, and @emptyGraph@ added. - . - * Removed un-used exports from @Swish.Utils.PartOrderedCollection@: - @partCompareOrd@, @partCompareMaybe@, @partCompareListOrd@, and - @partCompareListPartOrd@. - . - * Removed the @Swish.Utils.MiscHelpers@ module and moved single-use functionality - out of @Swish.Utils.ListHelpers@. - . - * Removed various exported symbols from a range of modules as they were - unused. + Changes in version @0.8.0.0@: . - * Use @Word32@ rather than @Int@ for label indexes (@Swish.GraphMatch.LabelIndex@) - and in the bnode counts when formatting to N3/Turtle. + * The @LDGraph@ class now uses @Set (Arc lb)@, rather than @[Arc lb]@, + for @setArcs@, @getArcs@, and @update@. Several data types - e.g. + @NSGraph@ - now use sets rather than lists. There are a number of API tweaks - + e.g. the addition of Ord constraints and the removal of Functor, Foldable, + and Traversable instances. Not all list of Arcs have been converted + since a review is needed to see where it makes sense and where it does not. + This definitely speeds up some operations but + a full analysis has not been attempted. . - * Minor clean up of the @LookupMap@ module: @mergeReplaceOrAdd@ and @mergeReplace@ - are now combined into @mergeReplace@; @mapSelect@, @mapApplyToAll@, and - @mapTranslate*@ have been removed; documentation slightly improved; - and a few minor internal clean ups. + * Replaced used of @Data.LookupMap@ with @Data.Map.Map@. This has led to the + removal of a number of language extensions from some modules. . - * Clarified that @Swish.RDF.RDFDatatypeXsdDecimal@ is for @xsd:decimal@ rather - than @xsd:double@. + * Added @Network.URI.Ord@ to provide an ordering for URIs. . - * Support using versions 0.8 or 0.9 of the @intern@ package and version 0.5 of - @containers@. + * A few other minor changes have been made: the removal of @subset@ and + @equiv@ from + @Swish.Utils.ListHelpers@; the ordering used for @RDFLabel@ values has + changed; added a @Monoid@ instance for @VarBinding@; added @Ord@ + instances for a number of containers; removed some un-needed constraints; + added @Network.URI.Ord@. . - * Switch to @Control.Exception.try@ to avoid deprecation warnings from @System.IO.Error.try@. + * The containers upper limit has been increased to support version 0.5. . Changes in previous versions can be found at . . @@ -158,7 +100,7 @@ Build-Depends: base >=3 && < 5, binary == 0.5.*, - containers >= 0.3 && < 0.6, + containers >= 0.4 && < 0.6, directory >= 1.0 && < 1.2, filepath >= 1.1 && < 1.4, hashable == 1.1.*, @@ -176,12 +118,13 @@ Build-Depends: intern >= 0.8 && < 1.0 Hs-Source-Dirs: src/ + Other-Modules: Swish.RDF.Formatter.Internal Exposed-Modules: Data.Interned.URI - Data.LookupMap Data.Ord.Partial Data.String.ShowLines + Network.URI.Ord Swish Swish.Commands Swish.Datatype @@ -250,7 +193,8 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, + base, + containers, HUnit == 1.2.*, swish @@ -264,9 +208,10 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - semigroups >= 0.5 && < 0.9, + base, + containers, + HUnit, + semigroups, swish Test-Suite test-graph @@ -279,8 +224,9 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, + base, + containers, + HUnit, swish Test-Suite test-nt @@ -293,10 +239,11 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, + base, + containers, + HUnit, swish, - text == 0.11.* + text Test-Suite test-n3parser type: exitcode-stdio-1.0 @@ -308,11 +255,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-n3formatter type: exitcode-stdio-1.0 @@ -324,11 +272,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-rdfdatatypexsdinteger type: exitcode-stdio-1.0 @@ -340,11 +289,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-rdfgraph type: exitcode-stdio-1.0 @@ -356,13 +306,14 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, - old-locale == 1.0.*, + base, + containers, + HUnit, + network, + old-locale, swish, - text == 0.11.*, - time >= 1.1 && < 1.5 + text, + time Test-Suite test-rdfproofcontext type: exitcode-stdio-1.0 @@ -374,11 +325,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-rdfproof type: exitcode-stdio-1.0 @@ -390,11 +342,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-rdfquery type: exitcode-stdio-1.0 @@ -406,11 +359,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-rdfruleset type: exitcode-stdio-1.0 @@ -422,11 +376,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text Test-Suite test-varbinding type: exitcode-stdio-1.0 @@ -438,22 +393,9 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - swish - -Test-Suite test-lookupmap - type: exitcode-stdio-1.0 - Hs-Source-Dirs: tests/ - Main-Is: LookupMapTest.hs - Other-Modules: TestHelpers - - ghc-options: - -Wall -fno-warn-orphans - - Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, + base, + containers, + HUnit, swish Test-Suite test-qname @@ -466,11 +408,12 @@ -Wall -fno-warn-orphans Build-Depends: - base >=3 && < 5, - HUnit == 1.2.*, - network >= 2.2 && < 2.4, + base, + containers, + HUnit, + network, swish, - text == 0.11.* + text -- we do not have the data files to run this test Executable SwishTest @@ -505,5 +448,5 @@ ghc-prof-options: -auto-all Build-Depends: - base >=3 && < 5, + base, swish diff --git a/tests/BuiltInMapTest.hs b/tests/BuiltInMapTest.hs --- a/tests/BuiltInMapTest.hs +++ b/tests/BuiltInMapTest.hs @@ -39,98 +39,14 @@ , namespaceXsdType ) -import Data.LookupMap (mapFindMaybe) +import qualified Data.Map as M import Test.HUnit ( Test(TestCase,TestList) , assertEqual ) -import TestHelpers (runTestSuite - , testJust - , testEqv2) - ------------------------------------------------------------- --- Test case helpers ------------------------------------------------------------- - -{- -assertMember :: (Eq a, Show a) => String -> a -> [a] -> Assertion -assertMember preface expected actual = - unless (expected `elem` actual ) (assertFailure msg) - where msg = (if null preface then "" else preface ++ "\n") ++ - "expected: " ++ show expected ++ "\nbut got: " ++ show actual - -test :: String -> Bool -> Test -test lab bv = - TestCase ( assertBool ("test:"++lab) bv ) - -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - -testElem :: (Eq a, Show a) => String -> a -> [a] -> Test -testElem lab a1 as = - TestCase ( assertMember ("testElem:"++lab) a1 as ) - -testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test -testLe lab eq a1 a2 = - TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) - --- Test for Just x or Nothing - -testJust :: String -> Maybe a -> Test -testJust lab av = - TestCase ( assertBool ("testJust:"++lab) (isJust av) ) - -testNothing :: String -> Maybe a -> Test -testNothing lab av = - TestCase ( assertBool ("testNothing:"++lab) (isNothing av) ) - --- Compare lists and lists of lists and Maybe lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testMaker :: (Show b, Eq b) => (a -> b) -> String -> String -> a -> a -> Test -testMaker conv l1 l2 x y = - TestCase (assertEqual ("testEqual:" ++ l1 ++ ":" ++ l2) (conv x) (conv y)) - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv = testMaker ListTest "Eqv" - --} - -testEqvEqv :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqvEqv = testEqv2 --- testEqvEqv = testMaker (ListTest . map ListTest) "EqvEqv" - -{- -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test -testHasEqv lab a1 a2 = - TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) - where - ma1 = ListTest a1 - ma2 = map ListTest a2 - -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv = testMaker MaybeListTest "MaybeEqv" --} +import TestHelpers (runTestSuite, testJust) ------------------------------------------------------------ -- Test finding built-in variable binding modifiers @@ -183,7 +99,7 @@ testRuleset01 :: Test testRuleset01 = testJust "testRuleset01" $ - mapFindMaybe scopeRDF rdfRulesetMap + M.lookup scopeRDF rdfRulesetMap testRulesetSuite :: Test testRulesetSuite = TestList diff --git a/tests/GraphPartitionTest.hs b/tests/GraphPartitionTest.hs --- a/tests/GraphPartitionTest.hs +++ b/tests/GraphPartitionTest.hs @@ -25,58 +25,14 @@ import Swish.GraphClass (Arc(..)) import Swish.GraphMem (LabelMem(..)) -import Swish.Utils.ListHelpers (equiv) - import Data.List.NonEmpty (fromList) -import Test.HUnit (Test(TestCase, TestList), - assertEqual, assertBool) +import Test.HUnit (Test(TestList)) import TestHelpers (runTestSuite , testEq, testNe + , testEqv, testNotEqv ) - ------------------------------------------------------------- --- Test case helpers ------------------------------------------------------------- - -{- -testEq :: (Eq a, Show a) => String -> a -> a -> Test -testEq lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) - -testNe :: (Eq a, Show a) => String -> a -> a -> Test -testNe lab a1 a2 = - TestCase ( assertBool ("testNe:"++lab) (a1 /= a2) ) --} - --- Compare lists and lists of lists and Maybe lists for set equivalence: - -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) - -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 - MaybeListTest Nothing == MaybeListTest Nothing = True - _ == _ = False - -instance (Show a) => Show (MaybeListTest a) where - show (MaybeListTest a) = show a - -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv lab a1 a2 = - TestCase ( assertEqual ("testEqv:"++lab) (ListTest a1) (ListTest a2) ) - -testNotEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testNotEqv lab a1 a2 = - TestCase ( assertBool ("testEqv:"++lab) (ListTest a1 /= ListTest a2) ) ------------------------------------------------------------ -- Basic GraphPartition tests diff --git a/tests/GraphTest.hs b/tests/GraphTest.hs --- a/tests/GraphTest.hs +++ b/tests/GraphTest.hs @@ -14,13 +14,6 @@ -- -------------------------------------------------------------------------------- -{- - -Note: after changing the hash module the order and values of some -of the tests; I have not checked that the new ordering makes sense. - --} - module Main where import qualified Data.Foldable as F @@ -29,11 +22,11 @@ ( Test(TestCase,TestList,TestLabel), assertEqual, assertBool ) -import Swish.GraphClass (Arc(..), LDGraph(..), Label(..)) +import Swish.GraphClass (Arc(..), ArcSet, LDGraph(..), Label(..)) import Swish.GraphClass (arc, arcFromTriple, arcToTriple) import Swish.GraphMem import Swish.GraphMatch - ( LabelMap, GenLabelMap(..), LabelEntry, + ( LabelMap, GenLabelMap(..), EquivalenceClass, ScopedLabel(..), makeScopedLabel, makeScopedArc, LabelIndex, nullLabelVal, emptyMap, @@ -43,17 +36,18 @@ , equivalenceClasses ) -import Swish.Utils.ListHelpers (subset) - -import Data.LookupMap (LookupEntryClass(..), makeLookupMap) +-- import Swish.Utils.ListHelpers (subset) -import TestHelpers (runTestSuite, testEq, testEqv) +import TestHelpers (runTestSuite, testEq) import Data.List (sort, elemIndex) import Data.Maybe (fromJust) import Data.Ord (comparing) import Data.Word (Word32) +import qualified Data.Map as M +import qualified Data.Set as S + default ( Int ) ------------------------------------------------------------ @@ -70,44 +64,23 @@ base4 = "http://id.ninebynine.org/wip/2003/test/graph3/nodebase" ------------------------------------------------------------ --- Set, get graph arcs as lists of triples ------------------------------------------------------------- - -setArcsT :: (LDGraph lg lb) => - [(lb, lb, lb)] -> lg lb -> lg lb -setArcsT a g = setArcs g $ map arcFromTriple a - -getArcsT :: (LDGraph lg lb) => - lg lb -> [(lb, lb, lb)] -getArcsT g = map arcToTriple $ getArcs g - ------------------------------------------------------------- --- Test class helper +-- Set, get graph arcs as sets of triples ------------------------------------------------------------ -testeq :: (Show a, Eq a) => String -> a -> a -> Test -testeq = testEq -{- -testeq lab req got = - TestCase ( assertEqual ("test"++lab) req got ) --} +setArcsT :: (Ord lb, LDGraph lg lb) => + S.Set (lb, lb, lb) -> lg lb -> lg lb +setArcsT a g = setArcs g $ S.map arcFromTriple a -testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test -testeqv = testEqv -{- -testeqv lab req got = - TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) --} +getArcsT :: (Ord lb, LDGraph lg lb) => + lg lb -> S.Set (lb, lb, lb) +getArcsT g = S.map arcToTriple $ getArcs g ------------------------------------------------------------ -- Label map and entry creation helpers ------------------------------------------------------------ tstLabelMap :: (Label lb) => Word32 -> [(lb,LabelIndex)] -> LabelMap lb -tstLabelMap gen lvs = LabelMap gen (makeLookupMap $ makeEntries lvs) - -makeEntries :: (Label lb) => [(lb,LabelIndex)] -> [LabelEntry lb] -makeEntries = map newEntry +tstLabelMap gen = LabelMap gen . M.fromList ------------------------------------------------------------ -- Graph helper function tests @@ -119,7 +92,7 @@ -- other tests still test this routine testSelect :: String -> String -> String -> Test -testSelect lab = testeq ("Select"++lab ) +testSelect lab = testEq ("Select"++lab ) isOne :: Int -> Bool isOne = (1 ==) @@ -144,10 +117,12 @@ -} --- subset +-- subset: hopefully can remove soon +{- + testSubset :: String -> Bool -> [Int] -> [Int] -> Test -testSubset lab res l1s l2s = testeq ("Mapset"++lab ) res (l1s `subset` l2s) +testSubset lab res l1s l2s = testEq ("Mapset"++lab ) res (l1s `subset` l2s) testSubsetSuite :: Test testSubsetSuite = TestList @@ -161,32 +136,34 @@ , testSubset "08" False [1,2,3] [] ] +-} + ------------------------------------------------------------ -- Simple graph label tests ------------------------------------------------------------ testLabSuite :: Test testLabSuite = TestList - [ testeq "Lab01" False (labelIsVar lab1f) - , testeq "Lab02" True (labelIsVar lab1v) - , testeq "Lab03" False (labelIsVar lab2f) - , testeq "Lab04" True (labelIsVar lab2v) + [ testEq "Lab01" False (labelIsVar lab1f) + , testEq "Lab02" True (labelIsVar lab1v) + , testEq "Lab03" False (labelIsVar lab2f) + , testEq "Lab04" True (labelIsVar lab2v) - , testeq "Lab05" 39495998 (labelHash 1 lab1f) - , testeq "Lab06" 45349309 (labelHash 1 lab1v) - , testeq "Lab07" 39495997 (labelHash 1 lab2f) - , testeq "Lab08" 45349310 (labelHash 1 lab2v) + , testEq "Lab05" 39495998 (labelHash 1 lab1f) + , testEq "Lab06" 45349309 (labelHash 1 lab1v) + , testEq "Lab07" 39495997 (labelHash 1 lab2f) + , testEq "Lab08" 45349310 (labelHash 1 lab2v) - , testeq "Lab09" "!lab1" (show lab1f) - , testeq "Lab10" "?lab1" (show lab1v) - , testeq "Lab11" "!lab2" (show lab2f) - , testeq "Lab12" "?lab2" (show lab2v) + , testEq "Lab09" "!lab1" (show lab1f) + , testEq "Lab10" "?lab1" (show lab1v) + , testEq "Lab11" "!lab2" (show lab2f) + , testEq "Lab12" "?lab2" (show lab2v) - , testeq "Lab13" "lab1" (getLocal lab1v) - , testeq "Lab14" "lab2" (getLocal lab2v) - , testeq "Lab15" lab1v (makeLabel "lab1") - , testeq "Lab16" lab2v (makeLabel "lab2") + , testEq "Lab13" "lab1" (getLocal lab1v) + , testEq "Lab14" "lab2" (getLocal lab2v) + , testEq "Lab15" lab1v (makeLabel "lab1") + , testEq "Lab16" lab2v (makeLabel "lab2") ] ------------------------------------------------------------ @@ -199,11 +176,8 @@ lab2f = LF "lab2" lab2v = LV "lab2" -gr1 :: GraphMem LabelMem -gr1 = GraphMem { arcs=[]::[Statement] } - -ga1 :: [(LabelMem, LabelMem, LabelMem)] -ga1 = +ga1 :: S.Set (LabelMem, LabelMem, LabelMem) +ga1 = S.fromList [ (lab1f,lab1f,lab1f), (lab1v,lab1v,lab1v), @@ -222,10 +196,10 @@ gs4 :: Statement -> Bool gs4 (Arc _ _ (LV "lab2")) = True -gs4 (Arc _ _ _ ) = False +gs4 _ = False -ga4 :: [(LabelMem, LabelMem, LabelMem)] -ga4 = +ga4 :: S.Set (LabelMem, LabelMem, LabelMem) +ga4 = S.fromList [ (lab2v,lab2v,lab2v), (lab1f,lab1f,lab2v), @@ -234,11 +208,8 @@ (lab1v,lab2f,lab2v) ] -gr2 :: GraphMem LabelMem -gr2 = GraphMem { arcs=[]::[Statement] } - -ga2 :: [(LabelMem, LabelMem, LabelMem)] -ga2 = +ga2 :: S.Set (LabelMem, LabelMem, LabelMem) +ga2 = S.fromList [ (lab1f,lab1f,lab1f), (lab1v,lab1v,lab1v), @@ -246,11 +217,8 @@ (lab2v,lab2v,lab2v) ] -gr3 :: GraphMem LabelMem -gr3 = GraphMem { arcs=[]::[Statement] } - -ga3 :: [(LabelMem, LabelMem, LabelMem)] -ga3 = +ga3 :: S.Set (LabelMem, LabelMem, LabelMem) +ga3 = S.fromList [ (lab1f,lab1f,lab1v), (lab1f,lab1f,lab2f), @@ -263,14 +231,14 @@ (lab1v,lab2f,lab2v) ] -gl4 :: [LabelMem] -gl4 = [lab1f,lab1v,lab2f,lab2v] +gl4 :: S.Set LabelMem +gl4 = S.fromList [lab1f,lab1v,lab2f,lab2v] gr1a, gr2a, gr3a, gr4a, gr4b, gr4c, gr4d, gr4e, gr4g :: GraphMem LabelMem -gr1a = setArcsT ga1 gr1 -gr2a = setArcsT ga2 gr2 -gr3a = setArcsT ga3 gr3 +gr1a = setArcsT ga1 (GraphMem S.empty) +gr2a = setArcsT ga2 emptyGraph +gr3a = setArcsT ga3 emptyGraph gr4a = addGraphs gr2a gr3a gr4b = addGraphs gr3a gr2a gr4c = delete gr2a gr4a @@ -278,24 +246,26 @@ gr4e = extract gs4 gr4a gr4g = addGraphs gr2a gr4a -gl4f :: [LabelMem] +gl4f :: S.Set LabelMem gl4f = labels gr4a +{- gr4ee :: [Bool] -gr4ee = map gs4 (getArcs gr4a) +gr4ee = map gs4 $ S.toList (getArcs gr4a) +-} testGraphSuite :: Test testGraphSuite = TestList - [ testeq "Graph01" ga1 (getArcsT gr1a) - , testeq "Graph01" ga2 (getArcsT gr2a) - , testeq "Graph03" ga3 (getArcsT gr3a) - , testeqv "Graph04" ga1 (getArcsT gr4a) - , testeqv "Graph05" ga1 (getArcsT gr4b) - , testeqv "Graph06" ga3 (getArcsT gr4c) - , testeqv "Graph07" ga2 (getArcsT gr4d) - , testeqv "Graph08" ga4 (getArcsT gr4e) - , testeqv "Graph09" gl4 gl4f - , testeq "Graph10" ga1 (getArcsT gr4g) + [ testEq "Graph01" ga1 (getArcsT gr1a) + , testEq "Graph01" ga2 (getArcsT gr2a) + , testEq "Graph03" ga3 (getArcsT gr3a) + , testEq "Graph04" ga1 (getArcsT gr4a) + , testEq "Graph05" ga1 (getArcsT gr4b) + , testEq "Graph06" ga3 (getArcsT gr4c) + , testEq "Graph07" ga2 (getArcsT gr4d) + , testEq "Graph08" ga4 (getArcsT gr4e) + , testEq "Graph09" gl4 gl4f + , testEq "Graph10" ga1 (getArcsT gr4g) ] ------------------------------------------------------------ @@ -530,28 +500,28 @@ -- showLabelMap :: (Label lb) => LabelMap lb -> String testShowLabelMap :: Test -testShowLabelMap = testeq "showLabelMap" showMap (show lmap) +testShowLabelMap = testEq "showLabelMap" showMap (show lmap) where showMap = "LabelMap gen=5, map=\n"++ - " !s1:(1,1)\n"++ - " !s2:(2,2)\n"++ - " !s3:(3,3)\n"++ - " !:(4,4)\n"++ - " !o1:(1,1)\n"++ - " !o2:(2,2)\n"++ - " !o3:(3,3)" + " (!,(4,4))\n"++ + " (!o1,(1,1))\n"++ + " (!o2,(2,2))\n"++ + " (!o3,(3,3))\n"++ + " (!s1,(1,1))\n"++ + " (!s2,(2,2))\n"++ + " (!s3,(3,3))" testMapLabelHash00 :: Test -testMapLabelHash00 = testeq "mapLabelHash00" showMap (show lmap1) +testMapLabelHash00 = testEq "mapLabelHash00" showMap (show lmap1) where showMap = "LabelMap gen=5, map=\n"++ - " !s1:(1,1)\n"++ - " !s2:(5,22)\n"++ - " !s3:(3,3)\n"++ - " !:(4,4)\n"++ - " !o1:(1,1)\n"++ - " !o2:(2,2)\n"++ - " !o3:(3,3)" + " (!,(4,4))\n"++ + " (!o1,(1,1))\n"++ + " (!o2,(2,2))\n"++ + " (!o3,(3,3))\n"++ + " (!s1,(1,1))\n"++ + " (!s2,(5,22))\n"++ + " (!s3,(3,3))" -- mapLabelIndex :: (Label lb) => LabelMap lb -> lb -> LabelIndex @@ -560,39 +530,39 @@ [ testShowLabelMap , testMapLabelHash00 - , testeq "testMapLabelIndex01" (1,1) (mapLabelIndex lmap s1 ) - , testeq "testMapLabelIndex02" (2,2) (mapLabelIndex lmap s2 ) - , testeq "testMapLabelIndex03" (3,3) (mapLabelIndex lmap s3 ) - , testeq "testMapLabelIndex04" (4,4) (mapLabelIndex lmap s4 ) - , testeq "testMapLabelIndex05" (1,1) (mapLabelIndex lmap o1 ) - , testeq "testMapLabelIndex06" (4,4) (mapLabelIndex lmap o4 ) - , testeq "testMapLabelIndex07" nullLabelVal (mapLabelIndex lmap o5 ) - , testeq "testMapLabelIndex08" nullLabelVal (mapLabelIndex lmap o6 ) + , testEq "testMapLabelIndex01" (1,1) (mapLabelIndex lmap s1 ) + , testEq "testMapLabelIndex02" (2,2) (mapLabelIndex lmap s2 ) + , testEq "testMapLabelIndex03" (3,3) (mapLabelIndex lmap s3 ) + , testEq "testMapLabelIndex04" (4,4) (mapLabelIndex lmap s4 ) + , testEq "testMapLabelIndex05" (1,1) (mapLabelIndex lmap o1 ) + , testEq "testMapLabelIndex06" (4,4) (mapLabelIndex lmap o4 ) + , testEq "testMapLabelIndex07" nullLabelVal (mapLabelIndex lmap o5 ) + , testEq "testMapLabelIndex08" nullLabelVal (mapLabelIndex lmap o6 ) - , testeq "MapLabelHash01" (1,1) (mapLabelIndex lmap1 s1 ) - , testeq "MapLabelHash02" (5,22) (mapLabelIndex lmap1 s2 ) - , testeq "MapLabelHash03" (3,3) (mapLabelIndex lmap1 s3 ) - , testeq "MapLabelHash04" (4,4) (mapLabelIndex lmap1 s4 ) - , testeq "MapLabelHash05" (1,1) (mapLabelIndex lmap1 o1 ) - , testeq "MapLabelHash06" (4,4) (mapLabelIndex lmap1 o4 ) - , testeq "MapLabelHash07" nullLabelVal (mapLabelIndex lmap1 o5 ) - , testeq "MapLabelHash08" nullLabelVal (mapLabelIndex lmap1 o6 ) + , testEq "MapLabelHash01" (1,1) (mapLabelIndex lmap1 s1 ) + , testEq "MapLabelHash02" (5,22) (mapLabelIndex lmap1 s2 ) + , testEq "MapLabelHash03" (3,3) (mapLabelIndex lmap1 s3 ) + , testEq "MapLabelHash04" (4,4) (mapLabelIndex lmap1 s4 ) + , testEq "MapLabelHash05" (1,1) (mapLabelIndex lmap1 o1 ) + , testEq "MapLabelHash06" (4,4) (mapLabelIndex lmap1 o4 ) + , testEq "MapLabelHash07" nullLabelVal (mapLabelIndex lmap1 o5 ) + , testEq "MapLabelHash08" nullLabelVal (mapLabelIndex lmap1 o6 ) - , testeq "MapLabelHash11" (1,1) (mapLabelIndex lmap2b s1 ) - , testeq "MapLabelHash12" (5,22) (mapLabelIndex lmap2b s2 ) - , testeq "MapLabelHash13" (3,3) (mapLabelIndex lmap2b s3 ) - , testeq "MapLabelHash14" (4,4) (mapLabelIndex lmap2b s4 ) - , testeq "MapLabelHash15" (5,66) (mapLabelIndex lmap2b o1 ) - , testeq "MapLabelHash16" (2,2) (mapLabelIndex lmap2b o2 ) - , testeq "MapLabelHash17" (4,4) (mapLabelIndex lmap2b o4 ) - , testeq "MapLabelHash18" nullLabelVal (mapLabelIndex lmap1 o5 ) + , testEq "MapLabelHash11" (1,1) (mapLabelIndex lmap2b s1 ) + , testEq "MapLabelHash12" (5,22) (mapLabelIndex lmap2b s2 ) + , testEq "MapLabelHash13" (3,3) (mapLabelIndex lmap2b s3 ) + , testEq "MapLabelHash14" (4,4) (mapLabelIndex lmap2b s4 ) + , testEq "MapLabelHash15" (5,66) (mapLabelIndex lmap2b o1 ) + , testEq "MapLabelHash16" (2,2) (mapLabelIndex lmap2b o2 ) + , testEq "MapLabelHash17" (4,4) (mapLabelIndex lmap2b o4 ) + , testEq "MapLabelHash18" nullLabelVal (mapLabelIndex lmap1 o5 ) - , testeq "LabelMap01" (6,61) (mapLabelIndex lmap3 s1 ) - , testeq "LabelMap02" (2,2) (mapLabelIndex lmap3 s2 ) - , testeq "LabelMap03" (6,63) (mapLabelIndex lmap3 s3 ) - , testeq "LabelMap04" (4,4) (mapLabelIndex lmap3 s4 ) - , testeq "LabelMap05" (1,1) (mapLabelIndex lmap3 o1 ) - , testeq "LabelMap06" (6,66) (mapLabelIndex lmap3 o2 ) + , testEq "LabelMap01" (6,61) (mapLabelIndex lmap3 s1 ) + , testEq "LabelMap02" (2,2) (mapLabelIndex lmap3 s2 ) + , testEq "LabelMap03" (6,63) (mapLabelIndex lmap3 s3 ) + , testEq "LabelMap04" (4,4) (mapLabelIndex lmap3 s4 ) + , testEq "LabelMap05" (1,1) (mapLabelIndex lmap3 o1 ) + , testEq "LabelMap06" (6,66) (mapLabelIndex lmap3 o2 ) ] @@ -621,58 +591,56 @@ t21 = arc b3 p2 b4 t22 = arc b4 p3 o1 -as1, as2, as4, as5, as6 :: [Statement] -as1 = [t01] -as2 = [t01,t02,t03,t04,t05,t06] -as4 = [t01,t02,t03,t04,t05,t06,t10,t11,t12] -as5 = [t01,t02,t03,t04,t05,t06,t20,t21,t22] -as6 = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] +as1, as2, as4, as5, as6 :: S.Set Statement +as1 = S.singleton t01 +as2 = S.fromList [t01,t02,t03,t04,t05,t06] +as4 = S.fromList [t01,t02,t03,t04,t05,t06,t10,t11,t12] +as5 = S.fromList [t01,t02,t03,t04,t05,t06,t20,t21,t22] +as6 = S.fromList [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] --- graphLabels :: (Label lb) => [Arc lb] -> [lb] +-- graphLabels :: (Label lb) => ArcSet lb -> S.Set lb -ls4 :: [LabelMem] -ls4 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2] +-- not clear both the 'raw' and 'string' versions are still needed. +ls4, glas4 :: S.Set LabelMem +ls4 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2] +glas4 = graphLabels as4 + testGraphLabels04, testGraphLabels14 :: Test -testGraphLabels04 = testeqv "GraphLabels04" ls4 (graphLabels as4) -testGraphLabels14 = testeq "GraphLabels14" str (show (graphLabels as4)) +testGraphLabels04 = testEq "GraphLabels04" ls4 glas4 +testGraphLabels14 = testEq "GraphLabels14" str (show glas4) where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3]" - -- str = "[!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3]" + str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b1,?b2]" + -- str = show ls4 -ls5 :: [LabelMem] -ls5 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b3,b4] +ls5, glas5 :: S.Set LabelMem +ls5 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b3,b4] +glas5 = graphLabels as5 testGraphLabels05, testGraphLabels15 :: Test -testGraphLabels05 = testeqv "GraphLabels05" ls5 (graphLabels as5) -testGraphLabels15 = testeq "GraphLabels15" str (show (graphLabels as5)) +testGraphLabels05 = testEq "GraphLabels05" ls5 glas5 +testGraphLabels15 = testEq "GraphLabels15" str (show glas5) where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b3,!p2,?b4,!p3]" - -- str = "[!p3,?b4,!p2,?b3,!l10-xml,!l4-type1,!l1,!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3,!l1,!l4-type1,!l10-xml,?b3,!p2,?b4,!p3]" + str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b3,?b4]" + -- str = show ls5 -ls6 :: [LabelMem] -ls6 = [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2,b3,b4] +ls6, glas6 :: S.Set LabelMem +ls6 = S.fromList [s1,s2,s3,p1,p2,p3,o1,o2,o3,l1,l4,l10,b1,b2,b3,b4] +glas6 = graphLabels as6 testGraphLabels06, testGraphLabels16 :: Test -testGraphLabels06 = testeqv "GraphLabels05" ls6 (graphLabels as6) -testGraphLabels16 = testeq "GraphLabels16" str (show (graphLabels as6)) +testGraphLabels06 = testEq "GraphLabels05" ls6 glas6 +testGraphLabels16 = testEq "GraphLabels16" str (show glas6) where - str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3"++ - ",!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3,?b3,?b4]" - -- str = "[?b4,?b3,!p3,?b2,!p2,?b1,!l10-xml,!l4-type1,!l1"++ - -- ",!o3,!s3,!o2,!s2,!o1,!p1,!s1]" + -- str = "[!s1,!p1,!o1,!s2,!o2,!s3,!o3"++ + -- ",!l1,!l4-type1,!l10-xml,?b1,!p2,?b2,!p3,?b3,?b4]" + str = "fromList [!l1,!l10-xml,!l4-type1,!o1,!o2,!o3,!p1,!p2,!p3,!s1,!s2,!s3,?b1,?b2,?b3,?b4]" + -- str = show ls6 -- assignLabels :: (Label lb) => [lb] -> LabelMap lb -> LabelMap lb -lmap5 :: LabelMap LabelMem -{- -lmap5 = tstLabelMap 2 [(s1,(1,142577)),(s2,(1,142578)),(s3,(1,142579)), - (p1,(1,142385)),(p2,(1,142386)),(p3,(1,142387)), - (o1,(1,142321)),(o2,(1,142322)),(o3,(1,142323)), - (l1,(1,142129)),(l4,(1,1709580)),(l10,(1,3766582)), - (b3,(1,262143)),(b4,(1,262143))] --} - bhash :: Word32 bhash = 23 @@ -701,6 +669,7 @@ s2hash = 2720 s3hash = 2721 +lmap5 :: LabelMap LabelMem lmap5 = tstLabelMap 2 [ (b4,(1,bhash)), @@ -720,7 +689,7 @@ ] testAssignLabelMap05 :: Test -testAssignLabelMap05 = testeq "AssignLabels05" lmap5 +testAssignLabelMap05 = testEq "AssignLabels05" lmap5 (newGenerationMap $ assignLabelMap ls5 emptyMap) lmap6 :: LabelMap LabelMem @@ -745,7 +714,7 @@ ] testAssignLabelMap06 :: Test -testAssignLabelMap06 = testeq "AssignLabels06" lmap6 (assignLabelMap ls6 lmap5) +testAssignLabelMap06 = testEq "AssignLabels06" lmap6 (assignLabelMap ls6 lmap5) lmapc :: LabelMap LabelMem lmapc = tstLabelMap 1 [(s1,(1,11)),(s2,(1,12)),(s3,(1,13)), @@ -767,8 +736,8 @@ , testAssignLabelMap05 , testAssignLabelMap06 -- implicitly tested elsewhere but included here for completeness - , testeq "O16-identity" tOrder16 $ sort tOrder16 - , testeq "O16-compare" tOrder16 $ sort [t01,t02,t03,t04,t05,t06] + , testEq "O16-identity" tOrder16 $ sort tOrder16 + , testEq "O16-compare" tOrder16 $ sort [t01,t02,t03,t04,t05,t06] ] ------------------------------------------------------------ @@ -859,9 +828,9 @@ -- Compare graph as6 with self, in steps -as61, as62 :: [Arc (ScopedLabel LabelMem)] -as61 = map (makeScopedArc 1) as6 -as62 = map (makeScopedArc 2) as6 +as61, as62 :: ArcSet (ScopedLabel LabelMem) +as61 = S.map (makeScopedArc 1) as6 +as62 = S.map (makeScopedArc 2) as6 eq1lmap :: LabelMap (ScopedLabel LabelMem) eq1lmap = newGenerationMap $ @@ -906,7 +875,7 @@ ] testEqAssignMap01 :: Test -testEqAssignMap01 = testeq "EqAssignMap01" eq1ltst eq1lmap +testEqAssignMap01 = testEq "EqAssignMap01" eq1ltst eq1lmap eq1hs1, eq1hs2 :: [Arc (ScopedLabel LabelMem)] eq1hs1 = [t10_1,t11_1,t12_1,t20_1,t21_1,t22_1] @@ -956,13 +925,13 @@ ] testEqNewLabelMap07 :: Test -testEqNewLabelMap07 = testeq "EqNewLabelMap07" eq1ltst'' eq1lmap'' +testEqNewLabelMap07 = testEq "EqNewLabelMap07" eq1ltst'' eq1lmap'' -- Repeat same tests for as4... -as41, as42 :: [Arc (ScopedLabel LabelMem)] -as41 = map (makeScopedArc 1) as4 -as42 = map (makeScopedArc 2) as4 +as41, as42 :: ArcSet (ScopedLabel LabelMem) +as41 = S.map (makeScopedArc 1) as4 +as42 = S.map (makeScopedArc 2) as4 eq2lmap :: LabelMap (ScopedLabel LabelMem) eq2lmap = newGenerationMap $ @@ -1003,7 +972,7 @@ ] testEqAssignMap21 :: Test -testEqAssignMap21 = testeq "EqAssignMap21" eq2ltst eq2lmap +testEqAssignMap21 = testEq "EqAssignMap21" eq2ltst eq2lmap eq2hs1, eq2hs2 :: [Arc (ScopedLabel LabelMem)] eq2hs1 = [t10_1,t11_1,t12_1] @@ -1047,21 +1016,21 @@ ] testEqNewLabelMap27 :: Test -testEqNewLabelMap27 = testeq "EqNewLabelMap27" eq2ltst'' eq2lmap'' +testEqNewLabelMap27 = testEq "EqNewLabelMap27" eq2ltst'' eq2lmap'' -- Compare as1 with as2, in steps -as11, as22 :: [Arc (ScopedLabel LabelMem)] -as11 = map (makeScopedArc 1) as1 -as22 = map (makeScopedArc 2) as2 +as11, as22 :: ArcSet (ScopedLabel LabelMem) +as11 = S.map (makeScopedArc 1) as1 +as22 = S.map (makeScopedArc 2) as2 -eq3hs1, eq3hs2 :: [Arc (ScopedLabel LabelMem)] -eq3hs1 = [t01_1] -eq3hs2 = [t01_2,t02_2,t03_2,t04_2,t05_2,t06_2] +eq3hs1, eq3hs2 :: ArcSet (ScopedLabel LabelMem) +eq3hs1 = S.singleton t01_1 +eq3hs2 = S.fromList [t01_2,t02_2,t03_2,t04_2,t05_2,t06_2] testEqGraphMap31_1, testEqGraphMap31_2 :: Test -testEqGraphMap31_1 = testeq "testEqGraphMap31_1" eq3hs1 as11 -testEqGraphMap31_2 = testeq "testEqGraphMap31_2" eq3hs2 as22 +testEqGraphMap31_1 = testEq "testEqGraphMap31_1" eq3hs1 as11 +testEqGraphMap31_2 = testEq "testEqGraphMap31_2" eq3hs2 as22 eq3lmap :: LabelMap (ScopedLabel LabelMem) eq3lmap = newGenerationMap $ @@ -1087,13 +1056,13 @@ ] testEqAssignMap32 :: Test -testEqAssignMap32 = testeq "EqAssignMap32" eq3ltst eq3lmap +testEqAssignMap32 = testEq "EqAssignMap32" eq3ltst eq3lmap type EquivClass = EquivalenceClass (ScopedLabel LabelMem) type EquivArgs = ((Word32, Word32), [ScopedLabel LabelMem]) ec31 :: [EquivClass] -ec31 = equivalenceClasses eq3lmap (graphLabels as11) +ec31 = equivalenceClasses eq3lmap (graphLabels as11) ec31test :: [EquivArgs] ec31test = @@ -1120,8 +1089,8 @@ ] testEquivClass33_1, testEquivClass33_2 :: Test -testEquivClass33_1 = testeq "EquivClass33_1" ec31test ec31 -testEquivClass33_2 = testeq "EquivClass33_2" ec32test ec32 +testEquivClass33_1 = testEq "EquivClass33_1" ec31test ec31 +testEquivClass33_2 = testEq "EquivClass33_2" ec32test ec32 {- as pairSOrt is no-longer exported need to check this code gets tested @@ -1142,7 +1111,7 @@ , ( ((1,142577),[s1_1]), ((1,142577),[s1_2]) ) ] -testEquivClass33_3 = testeq "EquivClass33_3" ec3test ec3pairs +testEquivClass33_3 = testEq "EquivClass33_3" ec3test ec3pairs -} {- pairSort is no longer exported @@ -1168,21 +1137,21 @@ , (p1_2,(1,142385)) , (s1_2,(1,142577)) ] --- testEqAssignMap34 = testeq "EqAssignMap34" (Just eq3ltst1) eq3lmap1 --- testEqAssignMap34 = testeq "EqAssignMap34" Nothing eq3lmap1 +-- testEqAssignMap34 = testEq "EqAssignMap34" (Just eq3ltst1) eq3lmap1 +-- testEqAssignMap34 = testEq "EqAssignMap34" Nothing eq3lmap1 {- pairSort is not exported testEqAssignMap34 :: Test -testEqAssignMap34 = testeq "EqAssignMap34" False (fst eq3lmap1) +testEqAssignMap34 = testEq "EqAssignMap34" False (fst eq3lmap1) -} {- eq3rc1 = reclassify eq3hs1 eq3lmap eq3rctst1 = [] -testEqReclassify35_1 = testeqv "EqReclassify35_1" (makeEntries eq3rctst1) eq3rc1 +testEqReclassify35_1 = testEqv "EqReclassify35_1" (makeEntries eq3rctst1) eq3rc1 eq3rc2 = reclassify eq3hs2 eq3lmap eq3rctst2 = [] -testEqReclassify35_2 = testeqv "EqReclassify35_2" (makeEntries eq3rctst2) eq3rc2 +testEqReclassify35_2 = testEqv "EqReclassify35_2" (makeEntries eq3rctst2) eq3rc2 -} @@ -1213,15 +1182,18 @@ testGraphEq lab eq gg1 gg2 = TestCase ( assertEqual ("testGraphEq:"++lab) eq (gg1==gg2) ) +toG :: [Statement] -> GraphMem LabelMem +toG stmts = GraphMem { arcs = S.fromList stmts } + g1, g2, g3, g4, g5, g6, g7, g8 :: GraphMem LabelMem -g1 = GraphMem { arcs = [t01] } -g2 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06] } -g3 = GraphMem { arcs = [t06,t05,t04,t03,t02,t01] } -g4 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12] } -g5 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t20,t21,t22] } -g6 = GraphMem { arcs = [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] } -g7 = GraphMem { arcs = [t01,t02] } -g8 = GraphMem { arcs = [t02,t01] } +g1 = toG [t01] +g2 = toG [t01,t02,t03,t04,t05,t06] +g3 = toG [t06,t05,t04,t03,t02,t01] +g4 = toG [t01,t02,t03,t04,t05,t06,t10,t11,t12] +g5 = toG [t01,t02,t03,t04,t05,t06,t20,t21,t22] +g6 = toG [t01,t02,t03,t04,t05,t06,t10,t11,t12,t20,t21,t22] +g7 = toG [t01,t02] +g8 = toG [t02,t01] glist :: [(String, GraphMem LabelMem)] glist = @@ -1551,8 +1523,8 @@ -- -arcsToGraph :: [Arc a] -> GraphMem a -arcsToGraph as = GraphMem { arcs = as } +arcsToGraph :: (Ord a) => [Arc a] -> GraphMem a +arcsToGraph as = GraphMem { arcs = S.fromList as } -- Very simple case @@ -1857,8 +1829,8 @@ allTests :: Test allTests = TestList [ -- testSelectSuite - testSubsetSuite - , testLabSuite + -- testSubsetSuite + testLabSuite , testGraphSuite , testLabelEqSuite , testLabelOrdSuite diff --git a/tests/LookupMapTest.hs b/tests/LookupMapTest.hs deleted file mode 100644 --- a/tests/LookupMapTest.hs +++ /dev/null @@ -1,407 +0,0 @@ -{-# LANGUAGE FlexibleInstances, FlexibleContexts, MultiParamTypeClasses #-} --------------------------------------------------------------------------------- --- See end of this file for licence information. --------------------------------------------------------------------------------- --- | --- Module : LookupMapTest --- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- License : GPL V2 --- --- Maintainer : Douglas Burke --- Stability : experimental --- Portability : FlexibleInstances, FlexibleContexts, MultiParamTypeClasses --- --- This Module defines test cases for module Parse parsing functions. --- --------------------------------------------------------------------------------- - -module Main where - -import Data.LookupMap - ( LookupEntryClass(..), LookupMap(..) - , makeLookupMap - , reverseLookupMap - , mapFind, mapContains - , mapReplace, mapReplaceAll, mapReplaceMap - , mapAdd, mapAddIfNew - , mapDelete, mapDeleteAll - , mapEq, mapKeys, mapVals - , mapMerge - ) - -import Data.List ( sort ) - -import Test.HUnit ( Test(TestList) ) - -import TestHelpers (runTestSuite - , testEq - , testEqv - ) - ------------------------------------------------------------- --- Declare lookup entry for testing ------------------------------------------------------------- - -data GenMapEntry a b = E a b - -instance (Eq a, Show a, Eq b, Show b) - => LookupEntryClass (GenMapEntry a b) a b - where - keyVal (E k v) = (k,v) - newEntry (k,v) = E k v - -instance (Eq a, Show a, Eq b, Show b) => Show (GenMapEntry a b) where - show = entryShow - -instance (Eq a, Show a, Eq b, Show b) => Eq (GenMapEntry a b) where - (==) = entryEq - -type TestEntry = GenMapEntry Int String -type TestMap = LookupMap (GenMapEntry Int String) -type RevTestMap = LookupMap (GenMapEntry String Int) -type MayTestMap = Maybe RevTestMap -type StrTestMap = LookupMap (GenMapEntry String String) - ------------------------------------------------------------- --- Test class helper ------------------------------------------------------------- - -testeq :: (Show a, Eq a) => String -> a -> a -> Test -testeq = testEq -{- -testeq lab req got = - TestCase ( assertEqual ("test"++lab) req got ) --} - -testeqv :: (Show a, Eq a) => String -> [a] -> [a] -> Test -testeqv = testEqv -{- -testeqv lab req got = - TestCase ( assertEqual ("test"++lab) True (req `equiv` got) ) --} - ------------------------------------------------------------- --- LookupMap functions ------------------------------------------------------------- - -newMap :: [(Int,String)] -> TestMap -newMap es = makeLookupMap (map newEntry es) - -testLookupMap :: String -> TestMap -> [(Int,String)] -> Test -testLookupMap lab m1 m2 = testeq ("LookupMap"++lab ) (newMap m2) m1 - -testLookupMapFind :: String -> TestMap -> Int -> String -> Test -testLookupMapFind lab lm k res = - testeq ("LookupMapFind"++lab ) res (mapFind "" k lm) - -lm00, lm01, lm02, lm03, lm04, lm05, lm06, lm07, lm08, lm09 :: TestMap -lm00 = newMap [] -lm01 = mapAdd lm00 $ newEntry (1,"aaa") -lm02 = mapAdd lm01 $ newEntry (2,"bbb") -lm03 = mapAdd lm02 $ newEntry (3,"ccc") -lm04 = mapAdd lm03 $ newEntry (2,"bbb") -lm05 = mapReplaceAll lm04 $ newEntry (2,"bbb1") -lm06 = mapReplaceAll lm05 $ newEntry (9,"zzzz") -lm07 = mapReplace lm06 $ newEntry (2,"bbb") -lm08 = mapDelete lm07 3 -lm09 = mapDeleteAll lm08 2 - -lm20, lm21, lm22, lm33, lm34, lm35, lm36 :: TestMap -lm20 = mapReplaceMap lm05 $ newMap [(2,"bbb20"),(3,"ccc20")] -lm21 = mapReplaceMap lm05 $ newMap [] -lm22 = mapReplaceMap lm05 $ newMap [(9,"zzz22"),(1,"aaa22")] -lm33 = mapAddIfNew lm22 $ newEntry (1,"aaa33") -lm34 = mapAddIfNew lm22 $ newEntry (4,"ddd34") -lm35 = mapReplace lm22 (newEntry (1,"aaa35")) -lm36 = mapReplace lm22 (newEntry (4,"ddd36")) - -testLookupMapSuite :: Test -testLookupMapSuite = - TestList - [ testLookupMap "00" lm00 [] - , testLookupMapFind "00" lm00 2 "" - , testLookupMap "01" lm01 [(1,"aaa")] - , testLookupMapFind "01" lm01 2 "" - , testLookupMap "02" lm02 [(2,"bbb"),(1,"aaa")] - , testLookupMapFind "02" lm02 2 "bbb" - , testLookupMap "03" lm03 [(3,"ccc"),(2,"bbb"),(1,"aaa")] - , testLookupMapFind "03" lm03 2 "bbb" - , testLookupMap "04" lm04 [(2,"bbb"),(3,"ccc"),(2,"bbb"),(1,"aaa")] - , testLookupMapFind "04" lm04 2 "bbb" - , testLookupMap "05" lm05 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] - , testLookupMapFind "05" lm05 2 "bbb1" - , testLookupMap "06" lm06 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] - , testLookupMapFind "06" lm06 2 "bbb1" - , testLookupMap "07" lm07 [(2,"bbb"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] - , testLookupMapFind "07" lm07 2 "bbb" - , testLookupMapFind "0x" lm07 9 "" - , testLookupMap "08" lm08 [(2,"bbb"),(2,"bbb1"),(1,"aaa")] - , testLookupMapFind "08" lm08 2 "bbb" - , testLookupMap "09" lm09 [(1,"aaa")] - , testLookupMapFind "09" lm09 2 "" - , testLookupMap "20" lm20 [(2,"bbb20"),(3,"ccc20"),(2,"bbb20"),(1,"aaa")] - , testLookupMapFind "20" lm20 2 "bbb20" - , testLookupMap "21" lm21 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa")] - , testLookupMapFind "21" lm21 2 "bbb1" - , testLookupMap "22" lm22 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] - , testLookupMapFind "22" lm22 1 "aaa22" - , testeq "LookupContains31" True (mapContains lm22 2) - , testeq "LookupContains32" False (mapContains lm22 9) - , testLookupMap "33" lm33 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] - , testLookupMapFind "33a" lm33 1 "aaa22" - , testLookupMapFind "33b" lm33 4 "" - , testLookupMap "34" lm34 [(4,"ddd34"),(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22")] - , testLookupMapFind "34a" lm34 1 "aaa22" - , testLookupMapFind "34b" lm34 4 "ddd34" - , testLookupMap "35" lm35 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa35")] - , testLookupMapFind "35a" lm35 1 "aaa35" - , testLookupMapFind "35b" lm35 4 "" - , testLookupMap "36" lm36 [(2,"bbb1"),(3,"ccc"),(2,"bbb1"),(1,"aaa22"),(4,"ddd36")] - , testLookupMapFind "36a" lm36 1 "aaa22" - , testLookupMapFind "36b" lm36 4 "ddd36" - ] - ------------------------------------------------------------- --- Reverse lookup map test tests ------------------------------------------------------------- - -revdef :: Int -revdef = -1 - -newRevMap :: [(String,Int)] -> RevTestMap -newRevMap es = makeLookupMap (map newEntry es) - -testRevLookupMap :: String -> RevTestMap -> [(String,Int)] -> Test -testRevLookupMap lab m1 m2 = - testeq ("RevLookupMap"++lab) (newRevMap m2) m1 - -testRevLookupMapFind :: String -> RevTestMap -> String -> Int -> Test -testRevLookupMapFind lab lm k res = - testeq ("RevLookupMapFind"++lab) res (mapFind revdef k lm) - -rlm00 :: RevTestMap -rlm00 = reverseLookupMap lm00 - -rlm01 :: RevTestMap -rlm01 = reverseLookupMap lm01 - -rlm02 :: RevTestMap -rlm02 = reverseLookupMap lm02 - -rlm03 :: RevTestMap -rlm03 = reverseLookupMap lm03 - -rlm04 :: RevTestMap -rlm04 = reverseLookupMap lm04 - -rlm05 :: RevTestMap -rlm05 = reverseLookupMap lm05 - -rlm06 :: RevTestMap -rlm06 = reverseLookupMap lm06 - -rlm07 :: RevTestMap -rlm07 = reverseLookupMap lm07 - -rlm08 :: RevTestMap -rlm08 = reverseLookupMap lm08 - -rlm09 :: RevTestMap -rlm09 = reverseLookupMap lm09 - -testRevLookupMapSuite :: Test -testRevLookupMapSuite = - TestList - [ testRevLookupMap "00" rlm00 [] - , testRevLookupMapFind "00" rlm00 "" revdef - , testRevLookupMap "01" rlm01 [("aaa",1)] - , testRevLookupMapFind "01" rlm01 "bbb" revdef - , testRevLookupMap "02" rlm02 [("bbb",2),("aaa",1)] - , testRevLookupMapFind "02" rlm02 "bbb" 2 - , testRevLookupMap "03" rlm03 [("ccc",3),("bbb",2),("aaa",1)] - , testRevLookupMapFind "03" rlm03 "bbb" 2 - , testRevLookupMap "04" rlm04 [("bbb",2),("ccc",3),("bbb",2),("aaa",1)] - , testRevLookupMapFind "04" rlm04 "bbb" 2 - , testRevLookupMap "05" rlm05 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] - , testRevLookupMapFind "05" rlm05 "bbb1" 2 - , testRevLookupMap "06" rlm06 [("bbb1",2),("ccc",3),("bbb1",2),("aaa",1)] - , testRevLookupMapFind "06" rlm06 "bbb1" 2 - , testRevLookupMap "07" rlm07 [("bbb",2),("ccc",3),("bbb1",2),("aaa",1)] - , testRevLookupMapFind "07" rlm07 "bbb" 2 - , testRevLookupMapFind "07" rlm07 "bbb1" 2 - , testRevLookupMapFind "0x" rlm07 "*" revdef - , testRevLookupMap "08" rlm08 [("bbb",2),("bbb1",2),("aaa",1)] - , testRevLookupMapFind "08" rlm08 "bbb" 2 - , testRevLookupMap "09" rlm09 [("aaa",1)] - , testRevLookupMapFind "09" rlm09 "" revdef - ] - ------------------------------------------------------------- --- mapKeys ------------------------------------------------------------- - -testMapKeys :: String -> TestMap -> [Int] -> Test -testMapKeys lab m1 mk = - testeq ("testMapKeys:"++lab) mk (sort $ mapKeys m1) - -testMapKeysSuite :: Test -testMapKeysSuite = - TestList - [ testMapKeys "00" lm00 [] - , testMapKeys "01" lm01 [1] - , testMapKeys "02" lm02 [1,2] - , testMapKeys "03" lm03 [1,2,3] - , testMapKeys "04" lm04 [1,2,3] - , testMapKeys "05" lm05 [1,2,3] - , testMapKeys "06" lm06 [1,2,3] - , testMapKeys "07" lm07 [1,2,3] - , testMapKeys "08" lm08 [1,2] - , testMapKeys "09" lm09 [1] - ] - ------------------------------------------------------------- --- mapVals ------------------------------------------------------------- - -testMapVals :: String -> TestMap -> [String] -> Test -testMapVals lab m1 mv = - testeq ("MapVals:"++lab) mv (sort $ mapVals m1) - -testMapValsSuite :: Test -testMapValsSuite = - TestList - [ testMapVals "00" lm00 [] - , testMapVals "01" lm01 ["aaa"] - , testMapVals "02" lm02 ["aaa","bbb"] - , testMapVals "03" lm03 ["aaa","bbb","ccc"] - , testMapVals "04" lm04 ["aaa","bbb","ccc"] - , testMapVals "05" lm05 ["aaa","bbb1","ccc"] - , testMapVals "06" lm06 ["aaa","bbb1","ccc"] - , testMapVals "07" lm07 ["aaa","bbb","bbb1","ccc"] - , testMapVals "08" lm08 ["aaa","bbb","bbb1"] - , testMapVals "09" lm09 ["aaa"] - ] - ------------------------------------------------------------- --- mapEq ------------------------------------------------------------- - -maplist :: [(String, TestMap)] -maplist = - [ ("lm00",lm00) - , ("lm01",lm01) - , ("lm02",lm02) - , ("lm03",lm03) - , ("lm04",lm04) - , ("lm05",lm05) - , ("lm06",lm06) - , ("lm07",lm07) - , ("lm08",lm08) - , ("lm09",lm09) - ] - -mapeqlist :: [(String, String)] -mapeqlist = - [ ("lm01","lm09") - , ("lm02","lm08") - , ("lm03","lm04") - , ("lm03","lm07") - , ("lm04","lm07") - , ("lm05","lm06") - ] - -testMapEq :: String -> Bool -> TestMap -> TestMap -> Test -testMapEq lab eq m1 m2 = - testeq ("testMapEq:"++lab) eq (mapEq m1 m2) - -testMapEqSuite :: Test -testMapEqSuite = TestList - [ testMapEq (testLab l1 l2) (nodeTest l1 l2) m1 m2 - | (l1,m1) <- maplist , (l2,m2) <- maplist ] - where - testLab l1 l2 = l1 ++ "-" ++ l2 - nodeTest l1 l2 = (l1 == l2) || - (l1,l2) `elem` mapeqlist || - (l2,l1) `elem` mapeqlist - ------------------------------------------------------------- --- mapSelect and mapMerge ------------------------------------------------------------- - -lm101, lm102, lm103, lm104 :: TestMap -lm101 = mapAdd lm03 $ newEntry (4,"ddd") -{- -lm102 = mapSelect lm101 [1,3] -lm103 = mapSelect lm101 [2,4] -lm104 = mapSelect lm101 [2,3] --} - -lm102 = mapAdd (mapAdd (newMap []) (newEntry (1,"aaa"))) $ newEntry (3,"ccc") -lm103 = mapAdd (mapAdd (newMap []) (newEntry (2,"bbb"))) $ newEntry (4,"ddd") -lm104 = mapAdd (mapAdd (newMap []) (newEntry (2,"bbb"))) $ newEntry (3,"ccc") - -lm105, lm106, lm107, lm108 :: TestMap -lm105 = mapMerge lm102 lm103 -lm106 = mapMerge lm102 lm104 -lm107 = mapMerge lm103 lm104 -lm108 = mapMerge lm101 lm102 - -mapMergeSuite :: Test -mapMergeSuite = - TestList - [ testLookupMap "101" lm101 [(4,"ddd"),(3,"ccc"),(2,"bbb"),(1,"aaa")] - , testLookupMap "105" lm105 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] - , testLookupMap "106" lm106 [(1,"aaa"),(2,"bbb"),(3,"ccc")] - , testLookupMap "107" lm107 [(2,"bbb"),(3,"ccc"),(4,"ddd")] - , testLookupMap "108" lm108 [(1,"aaa"),(2,"bbb"),(3,"ccc"),(4,"ddd")] - ] - ------------------------------------------------------------- --- All tests ------------------------------------------------------------- - -allTests :: Test -allTests = TestList - [ testLookupMapSuite - , testRevLookupMapSuite - , testMapKeysSuite - , testMapValsSuite - , testMapEqSuite - , mapMergeSuite - ] - -main :: IO () -main = runTestSuite allTests - -{- -runTestFile t = do - h <- openFile "a.tmp" WriteMode - runTestText (putTextToHandle h False) t - hClose h -tf = runTestFile -tt = runTestTT --} - --------------------------------------------------------------------------------- --- --- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke --- All rights reserved. --- --- This file is part of Swish. --- --- Swish is free software; you can redistribute it and/or modify --- it under the terms of the GNU General Public License as published by --- the Free Software Foundation; either version 2 of the License, or --- (at your option) any later version. --- --- Swish is distributed in the hope that it will be useful, --- but WITHOUT ANY WARRANTY; without even the implied warranty of --- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the --- GNU General Public License for more details. --- --- You should have received a copy of the GNU General Public License --- along with Swish; if not, write to: --- The Free Software Foundation, Inc., --- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA --- --------------------------------------------------------------------------------- diff --git a/tests/N3FormatterTest.hs b/tests/N3FormatterTest.hs --- a/tests/N3FormatterTest.hs +++ b/tests/N3FormatterTest.hs @@ -19,7 +19,7 @@ module Main where import Swish.GraphClass (Arc, arc) -import Swish.Namespace (Namespace, makeNamespace, makeNSScopedName, namespaceToBuilder) +import Swish.Namespace (Namespace, makeNamespace, getNamespaceTuple, makeNSScopedName, namespaceToBuilder) import Swish.QName (LName) import Swish.RDF.Formatter.N3 (formatGraphAsLazyText, formatGraphDiag) @@ -30,14 +30,11 @@ , RDFLabel(..), ToRDFLabel , NSGraph(..) , NamespaceMap - , LookupFormula(..) , emptyRDFGraph, toRDFGraph, toRDFTriple , resRdfType, resRdfFirst, resRdfRest, resRdfNil , resOwlSameAs ) -import Data.LookupMap (LookupMap(..), emptyLookupMap, makeLookupMap) - import Swish.RDF.Vocabulary (toLangTag, namespaceRDF, namespaceXSD) import Network.URI (URI, parseURI) @@ -47,6 +44,8 @@ import Data.String (IsString(..)) +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B @@ -183,7 +182,7 @@ t07 = arc s3 p2 l3 nslist :: NamespaceMap -nslist = makeLookupMap +nslist = M.fromList $ map getNamespaceTuple [ base1 , base2 , base3 @@ -191,10 +190,11 @@ ] g1np :: RDFGraph -g1np = emptyRDFGraph { namespaces = makeLookupMap [base1], statements = [t01] } +g1np = emptyRDFGraph { namespaces = uncurry M.singleton (getNamespaceTuple base1) + , statements = S.singleton t01 } toGraph :: [Arc RDFLabel] -> RDFGraph -toGraph arcs = (toRDFGraph arcs) {namespaces = nslist} +toGraph arcs = (toRDFGraph (S.fromList arcs)) {namespaces = nslist} g1, g1b1, g1b3, g1a1, g1l1, g1l2 :: RDFGraph g1 = toGraph [t01] @@ -207,44 +207,39 @@ {- g1f1 = NSGraph { namespaces = nslist - , formulae = formo1g1 + , formulae = M.singleton o1 (Formula o1g1) , statements = [f01] } where f01 = arc s1 p1 o1 - formo1g1 = LookupMap [Formula o1 g1] -} g1f2, g1f3 :: RDFGraph g1f2 = NSGraph { namespaces = nslist - , formulae = formb2g1 - , statements = [f02] + , formulae = M.singleton b2 g1 -- $ Formula b2 g1 + , statements = S.singleton $ arc s1 p1 b2 } - where - f02 = arc s1 p1 b2 - formb2g1 = LookupMap [Formula b2 g1] g1f3 = NSGraph { namespaces = nslist - , formulae = formb3g1f2 - , statements = [f02] + , formulae = M.singleton b3 g1f2 -- $ Formula b3 g1f2 + , statements = S.singleton $ arc s1 p1 b3 } - where - f02 = arc s1 p1 b3 - formb3g1f2 = LookupMap [Formula b3 g1f2] g1fu1 :: RDFGraph g1fu1 = mempty - { namespaces = makeLookupMap [basem, makeNamespace Nothing (toURI "file:///home/swish/photos/")] - , statements = [arc sf meDepicts meMe, arc sf meHasURN su] + { namespaces = + M.fromList $ map getNamespaceTuple + [basem, makeNamespace Nothing (toURI "file:///home/swish/photos/")] + , statements = S.fromList [arc sf meDepicts meMe, arc sf meHasURN su] } ---- g2, g3, g4, g5, g6, g7 :: RDFGraph -g2 = toRDFGraph [t01,t02,t03] +g2 = toRDFGraph $ S.fromList [t01,t02,t03] g3 = toGraph [t01,t04] g4 = toGraph [t01,t05] g5 = toGraph [t01,t02,t03,t04,t05] @@ -440,22 +435,22 @@ x7 :: RDFGraph x7 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 g2] - , statements = [arc b1 p2 f2] + , formulae = M.singleton b1 g2 -- $ Formula b1 g2 + , statements = S.singleton $ arc b1 p2 f2 } x8 :: RDFGraph x8 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula f1 g2] - , statements = [arc f1 p2 f2] + , formulae = M.singleton f1 g2 -- $ Formula f1 g2 + , statements = S.singleton $ arc f1 p2 f2 } x9 :: RDFGraph x9 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula f1 g1] - , statements = [arc f1 p2 f2] + , formulae = M.singleton f1 g1 -- $ Formula f1 g1 + , statements = S.singleton $ arc f1 p2 f2 } -- Test allocation of bnodes carries over a nested formula @@ -463,8 +458,9 @@ x12, x12fg :: RDFGraph x12 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b2 x12fg] - , statements = [ arc s1 p1 b1 + , formulae = M.singleton b2 x12fg -- $ Formula b2 x12fg + , statements = S.fromList + [ arc s1 p1 b1 , arc b1 p1 o1 , arc b2 p2 f2 , arc s3 p3 b3 @@ -472,7 +468,8 @@ ] } -x12fg = toRDFGraph [ arc s2 p2 b4 +x12fg = toRDFGraph $ S.fromList + [ arc s2 p2 b4 , arc b4 p2 o2 ] @@ -643,22 +640,22 @@ graph_b1, graph_b1rev, graph_b2, graph_b2rev, graph_b3, graph_b4, graph_b5 :: RDFGraph -graph_b1 = toRDFGraph [arc s1 p1 b1] -graph_b1rev = toRDFGraph [arc b1 p1 o1] -graph_b2 = toRDFGraph [arc s1 p1 b1, +graph_b1 = toRDFGraph $ S.singleton $ arc s1 p1 b1 +graph_b1rev = toRDFGraph $ S.singleton $ arc b1 p1 o1 +graph_b2 = toRDFGraph $ S.fromList [arc s1 p1 b1, arc b1 p2 l1, arc b1 o2 o3] -graph_b2rev = toRDFGraph [arc b1 p2 l1, +graph_b2rev = toRDFGraph $ S.fromList [arc b1 p2 l1, arc b1 o2 o3, arc b1 p1 o1] -graph_b3 = toRDFGraph [arc s1 p1 b1, +graph_b3 = toRDFGraph $ S.fromList [arc s1 p1 b1, arc b1 p2 l2, arc b1 o2 o3, arc s1 p2 b2, arc s2 p2 o2] -graph_b4 = toRDFGraph [arc b1 resRdfType o1, +graph_b4 = toRDFGraph $ S.fromList [arc b1 resRdfType o1, arc b2 resRdfType o2] -graph_b5 = toRDFGraph [arc b1 resRdfType o1, +graph_b5 = toRDFGraph $ S.fromList [arc b1 resRdfType o1, arc b2 p2 o2, arc b3 resRdfType o3] @@ -683,9 +680,12 @@ ] {- gtmp = toRDFGraph arcs - in gtmp { namespaces = mapAdd (namespaces gtmp) (Namespace "xsd" "http://www.w3.org/2001/XMLSchema#") } + in gtmp { namespaces = + M.insert (Just "xsd") ("http://www.w3.org/2001/XMLSchema#") + (namespaces gtmp) + } -} - in toRDFGraph arcs + in toRDFGraph $ S.fromList arcs graph_l4 = toGraph [ toRDFTriple s1 p1 ("A string with \"quotes\"" :: RDFLabel) , toRDFTriple s2 p2 (TypedLit "A typed string with \"quotes\"" (fromString "urn:a#b")) @@ -711,7 +711,7 @@ diagTest lab gr out = TestList [ TestCase ( assertEqual ("diag:text:"++lab) out resTxt ) - , TestCase ( assertEqual ("diag:map:"++lab) emptyLookupMap nmap ) + , TestCase ( assertEqual ("diag:map:"++lab) M.empty nmap ) , TestCase ( assertEqual ("diag:gen:"++lab) 0 ngen ) , TestCase ( assertEqual ("diag:trc:"++lab) [] trc ) ] @@ -829,8 +829,8 @@ simpleN3Graph_g1_fu1 :: B.Builder simpleN3Graph_g1_fu1 = mconcat - [ "@prefix me: .\n" - , "@prefix : .\n" + [ "@prefix : .\n" + , "@prefix me: .\n" -- , ":me.png me:depicts me:me ;\n" , " me:depicts me:me ;\n" , " me:hasURN .\n" @@ -915,18 +915,18 @@ simpleN3Graph_b2 :: B.Builder simpleN3Graph_b2 = - commonPrefixesN [2,1,0] `mappend` + commonPrefixesN [0,1,2] `mappend` "base1:s1 base1:p1 [\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" simpleN3Graph_b2rev :: B.Builder simpleN3Graph_b2rev = - commonPrefixesN [0,2,1] `mappend` + commonPrefixesN [0,1,2] `mappend` "[\n base1:p1 base1:o1 ;\n base2:o2 base3:o3 ;\n base2:p2 \"l1\"\n] .\n" simpleN3Graph_b3 :: B.Builder simpleN3Graph_b3 = mconcat - [ commonPrefixesN [2,1,0] + [ commonPrefixesN [0,1,2] , "base1:s1 base1:p1 [\n base2:o2 base3:o3 ;\n base2:p2 \"\"\"", l2txt, "\"\"\"\n] ;\n" , " base2:p2 [] .\n" , "base2:s2 base2:p2 base2:o2 .\n" ] @@ -934,14 +934,14 @@ simpleN3Graph_b4 :: B.Builder simpleN3Graph_b4 = mconcat - [ commonPrefixesN [1,0,4] + [ commonPrefixesN [0,1,4] , "[\n a base1:o1\n] .\n" , "[\n a base2:o2\n] .\n" ] simpleN3Graph_b5 :: B.Builder simpleN3Graph_b5 = mconcat - [ commonPrefixesN [2,1,0,4] + [ commonPrefixesN [0,1,2,4] , "[\n a base1:o1\n] .\n" , "[\n base2:p2 base2:o2\n] .\n" , "[\n a base3:o3\n] .\n" ] @@ -963,16 +963,11 @@ simpleN3Graph_l3 :: B.Builder simpleN3Graph_l3 = mconcat - [ commonPrefixesN [5,0] + [ commonPrefixesN [0, 5] , "\n" -- TODO: why do we need this newline? - , "base1:s1 base1:p1 \"2.34E1\"^^xsd:float,\n" - , " -2.304e-108,\n" - , " 12, true .\n" ] - -{- - " -2.304e-108,\n" ++ - " 12, true .\n" --} + , "base1:s1 base1:p1 -2.304e-108,\n" + , " 12,\n" + , " \"2.34E1\"^^xsd:float, true .\n" ] simpleN3Graph_l4 :: B.Builder simpleN3Graph_l4 = diff --git a/tests/N3ParserTest.hs b/tests/N3ParserTest.hs --- a/tests/N3ParserTest.hs +++ b/tests/N3ParserTest.hs @@ -20,12 +20,11 @@ import Swish.GraphClass (Arc, arc) import Swish.Namespace ( - Namespace, makeNamespace, getNamespaceURI + Namespace, makeNamespace, getNamespaceURI, getNamespaceTuple , ScopedName , makeScopedName , makeNSScopedName , nullScopedName - -- , makeUriScopedName , namespaceToBuilder ) import Swish.QName (QName, qnameFromURI) @@ -39,8 +38,7 @@ ) import Swish.RDF.Graph - ( RDFGraph, RDFLabel(..), NSGraph(..) - , LookupFormula(..) + ( RDFGraph, RDFLabel(..), NSGraph(..), NamespaceMap , emptyRDFGraph, toRDFGraph , resRdfType, resRdfFirst, resRdfRest, resRdfNil , resOwlSameAs, resLogImplies @@ -56,8 +54,6 @@ , xsdDouble ) -import Data.LookupMap (LookupMap(..)) - import Test.HUnit (Test(TestCase,TestList), assertEqual) import Network.URI (URI, nullURI, parseURIReference) @@ -66,6 +62,8 @@ import Data.Maybe (fromJust, fromMaybe) import Data.List (intercalate) +import qualified Data.Map as M +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy as L import qualified Data.Text.Lazy.Builder as B @@ -353,8 +351,8 @@ makeNewPrefixNamespace (pre,ns) = makeNamespace (Just pre) (getNamespaceURI ns) dg1, dg2, dg3 :: RDFGraph -dg1 = toRDFGraph [arc ds1 dp1 do1] -dg2 = toRDFGraph +dg1 = toRDFGraph $ S.singleton $ arc ds1 dp1 do1 +dg2 = toRDFGraph $ S.fromList [ arc xa1 xb1 xc1 , arc xa2 xb2 xc2 , arc xa3 xb3 xc3 @@ -384,26 +382,15 @@ xc5 = mUN ns5 "c5" dg3 = -- TODO: add in prefixes ? - toRDFGraph [ arc (Res "file:///home/swish/photos/myphoto") (Res "http://example.com/ns#photoOf") (Res "http://example.com/ns#me")] + toRDFGraph $ S.singleton $ arc (Res "file:///home/swish/photos/myphoto") (Res "http://example.com/ns#photoOf") (Res "http://example.com/ns#me") -nslist, xnslist :: LookupMap Namespace -nslist = LookupMap $ map makeNewPrefixNamespace - [ ("base1",base1) - , ("base2",base2) - , ("base3",base3) - , ("base4",base4) - ] -xnslist = LookupMap $ map makeNewPrefixNamespace - [ ("base1",base1) - , ("base2",base2) - , ("base3",base3) - , ("base4",base4) - , ("xsd", xsdNS) - ] +nslist, xnslist :: NamespaceMap +nslist = M.fromList $ map getNamespaceTuple [base1, base2, base3, base4] +xnslist = (\(a,b) -> M.insert a b nslist) $ getNamespaceTuple xsdNS toGraph :: [Arc RDFLabel] -> RDFGraph toGraph stmts = mempty { namespaces = nslist - , statements = stmts + , statements = S.fromList stmts } g1 :: RDFGraph @@ -649,8 +636,8 @@ x7 :: RDFGraph x7 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 g2] - , statements = [tx701] + , formulae = M.singleton b1 g2 -- $ Formula b1 g2 + , statements = S.singleton tx701 } tx801 :: Arc RDFLabel @@ -659,15 +646,15 @@ x8 :: RDFGraph x8 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula f1 g2] - , statements = [tx801] + , formulae = M.singleton f1 g2 -- $ Formula f1 g2 + , statements = S.singleton tx801 } x9 :: RDFGraph x9 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula f1 g1] - , statements = [tx801] + , formulae = M.singleton f1 g1 -- $ Formula f1 g1 + , statements = S.singleton tx801 } -- Test allocation of bnodes carries over a nested formula @@ -683,20 +670,20 @@ tx1212 = arc b4 p2 o2 x12fg :: RDFGraph -x12fg = mempty { statements = [tx1211,tx1212] } +x12fg = mempty { statements = S.fromList [tx1211,tx1212] } {- x12fg = NSGraph { namespaces = emptyNamespaceMap , formulae = emptyFormulaMap - , statements = [tx1211,tx1212] + , statements = S.fromList [tx1211,tx1212] } -} x12 :: RDFGraph x12 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b2 x12fg] - , statements = [tx1201,tx1202,tx1203,tx1204,tx1205] + , formulae = M.singleton b2 x12fg -- $ Formula b2 x12fg + , statements = S.fromList [tx1201,tx1202,tx1203,tx1204,tx1205] } -- List of simple anon nodes @@ -808,8 +795,7 @@ tx1627,tx1628,tx1629,tx1630,tx1631,tx1632] kg1 :: RDFGraph -kg1 = toRDFGraph - [ arc b a c ] +kg1 = toRDFGraph $ S.singleton $ arc b a c where -- the document base is set to file:///dev/null to begin with mUN = Res . makeNSScopedName dbase @@ -1265,7 +1251,7 @@ lit_g4 :: RDFGraph lit_g4 = mempty { namespaces = xnslist - , statements = [ + , statements = S.fromList [ arc s1 p1 b1 , arc b1 resRdfFirst bTrue , arc b1 resRdfRest b2 diff --git a/tests/NTTest.hs b/tests/NTTest.hs --- a/tests/NTTest.hs +++ b/tests/NTTest.hs @@ -35,11 +35,12 @@ ( Test(TestCase,TestList) , assertEqual ) -import qualified Data.Text.Lazy as T - import Data.Maybe (fromJust) import TestHelpers (runTestSuite) +import qualified Data.Set as S +import qualified Data.Text.Lazy as T + ------------------------------------------------------------ -- Parser tests ------------------------------------------------------------ @@ -100,10 +101,10 @@ ------------------------------------------------------------ s1, p1, p2, o1 :: RDFLabel -s1 = Res $ "urn:b#s1" -- rely on IsString to convert to ScopedName -p1 = Res $ "urn:b#p1" -p2 = Res $ "http://example.com/pred2" -o1 = Res $ "urn:b#o1" +s1 = Res "urn:b#s1" -- rely on IsString to convert to ScopedName +p1 = Res "urn:b#p1" +p2 = Res "http://example.com/pred2" +o1 = Res "urn:b#o1" {- s1 = Res $ makeURIScopedName "urn:b#s1" p1 = Res $ makeURIScopedName "urn:b#p1" @@ -133,10 +134,10 @@ ------------------------------------------------------------ g0 :: RDFGraph -g0 = toRDFGraph [] +g0 = toRDFGraph S.empty mkGr1 :: RDFLabel -> RDFLabel -> RDFLabel -> RDFGraph -mkGr1 s p o = toRDFGraph [arc s p o] +mkGr1 s p o = toRDFGraph $ S.singleton $ arc s p o g1, g2, g3, g4, g5, g6, g7, g8, g9, g10, g11, g12 :: RDFGraph g1 = mkGr1 s1 p1 o1 @@ -153,7 +154,7 @@ g12 = mkGr1 s1 p1 l4 gm1 :: RDFGraph -gm1 = toRDFGraph [arc b2 p2 b1, arc b2 p1 o1] +gm1 = toRDFGraph $ S.fromList [arc b2 p2 b1, arc b2 p1 o1] ------------------------------------------------------------ -- Input documents diff --git a/tests/QNameTest.hs b/tests/QNameTest.hs --- a/tests/QNameTest.hs +++ b/tests/QNameTest.hs @@ -203,7 +203,7 @@ ------------------------------------------------------------ testMaybeQNameEq :: String -> Bool -> Maybe QName -> Maybe QName -> Test -testMaybeQNameEq lbl eq n1 n2 = testCompareEq "MaybeQName" lbl eq n1 n2 +testMaybeQNameEq = testCompareEq "MaybeQName" testMaybeQNameEqSuite :: Test testMaybeQNameEqSuite = diff --git a/tests/RDFDatatypeXsdIntegerTest.hs b/tests/RDFDatatypeXsdIntegerTest.hs --- a/tests/RDFDatatypeXsdIntegerTest.hs +++ b/tests/RDFDatatypeXsdIntegerTest.hs @@ -51,22 +51,20 @@ import Swish.RDF.Vocabulary (namespaceDefault, namespaceRDF, namespaceRDFD, namespaceXSD) -import Data.LookupMap (LookupMap(..), mapFindMaybe) - -import Test.HUnit - ( Test(TestCase,TestList) - , assertFailure - ) +import Data.List (intersperse) +import Data.Maybe (fromMaybe, fromJust) +import Data.Monoid (Monoid(..)) import Network.URI (URI, parseURI) -import Data.Monoid (Monoid(..)) -import Data.Maybe (fromMaybe, fromJust) -import Data.List (intersperse) - +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B +import Test.HUnit + ( Test(TestCase,TestList) + , assertFailure + ) import TestHelpers (runTestSuite , testEq, testElem, testEqv, testEqv2) @@ -916,7 +914,7 @@ diff03inp = multiInp "Diff" [(1, -111), (2, 222)] diff01bwd :: [[B.Builder]] -diff01bwd = +diff01bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " @@ -928,7 +926,7 @@ ] diff02bwd :: [[B.Builder]] -diff02bwd = +diff02bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_2 \"222\"^^xsd:integer . " @@ -940,7 +938,7 @@ ] diff03bwd :: [[B.Builder]] -diff03bwd = +diff03bwd = [ [ "_:a a xsd_integer:Diff . " , "_:a rdf:_1 \"-111\"^^xsd:integer . " , "_:a rdf:_3 \"333\"^^xsd:integer . " @@ -1072,12 +1070,12 @@ -- Now the test cases that use the rules created above. pvRule0, pvRule1 :: Maybe (Rule RDFGraph) -pvRule0 = mapFindMaybe +pvRule0 = M.lookup (makeNSScopedName namespaceDefault "PassengerVehicle") - (LookupMap pvRules) -pvRule1 = mapFindMaybe + $ M.fromList $ map (\rl -> (ruleName rl, rl)) pvRules +pvRule1 = M.lookup (makeNSScopedName namespaceDefault "PassengerVehicle1") - (LookupMap pvRules) + $ M.fromList $ map (\rl -> (ruleName rl, rl)) pvRules pv01inp :: B.Builder pv01inp = diff --git a/tests/RDFGraphTest.hs b/tests/RDFGraphTest.hs --- a/tests/RDFGraphTest.hs +++ b/tests/RDFGraphTest.hs @@ -18,20 +18,16 @@ module Main where -import Swish.Namespace (Namespace, makeNamespace, getNamespaceURI, ScopedName, makeNSScopedName, nullScopedName) +import Swish.Namespace (Namespace, makeNamespace, getNamespaceURI, getNamespaceTuple, ScopedName, makeNSScopedName, nullScopedName) import Swish.QName (QName, qnameFromURI) -import Data.LookupMap (LookupMap(..), LookupEntryClass(..), mapFindMaybe) - -import Swish.Utils.ListHelpers (equiv) - -import Swish.GraphClass (Label(..), arc) +import Swish.GraphClass (Label(..), arc {- , arcToTriple -} ) import Swish.RDF.Graph ( RDFTriple, toRDFTriple, fromRDFTriple - , RDFGraph + , RDFGraph, NamespaceMap, Formula , RDFLabel(..), ToRDFLabel(..), FromRDFLabel(..) - , NSGraph(..), Arc(..) + , NSGraph(..) , isLiteral, isUntypedLiteral, isTypedLiteral, isXMLLiteral , isDatatyped, isMemberProp , isUri, isBlank, isQueryVar, makeBlank @@ -40,6 +36,7 @@ , getArcs, addArc , remapLabels, remapLabelList , setFormulae, getFormulae, setFormula, getFormula + , fmapNSGraph , newNode, newNodes ) import Swish.RDF.Vocabulary @@ -55,29 +52,35 @@ , xsdDate ) -import qualified Data.Text as T - -import qualified Data.Traversable as Traversable -import qualified Data.Foldable as Foldable +import Control.Arrow (first) -import Network.URI (URI, parseURI) -import Data.Monoid (Monoid(..)) import Data.List (elemIndex, intercalate) import Data.Maybe (fromJust, fromMaybe) +import Data.Monoid (Monoid(..)) import Data.Ord (comparing) +import Data.Time (UTCTime(..), Day, fromGregorian, buildTime) +import Network.URI (URI, parseURI) + import System.Locale (defaultTimeLocale) -import Data.Time (UTCTime(..), Day, fromGregorian, buildTime) +import qualified Data.Map as M +import qualified Data.Set as S +import qualified Data.Text as T + +-- import qualified Data.Traversable as Traversable +import qualified Data.Foldable as Foldable + import Test.HUnit ( Test(TestCase,TestList,TestLabel) , Assertion , assertBool, assertEqual ) import TestHelpers ( runTestSuite - , testEq - , testCompare - , testCompareEq) + , testEq + , testEqv + , testCompare + , testCompareEq) ------------------------------------------------------------ -- Test language tag comparisons @@ -690,24 +693,25 @@ nodeorder :: [String] nodeorder = [ - -- literals - "l1" - , "l11", "l12", "l10" - , "l2", "l2gb", "l3" - , "l5", "l6", "l4", "l8", "l9", "l7" - -- URIs beginning with ':' and '<' - , "es1" - , "us1" - -- variables - , "v1", "v2" -- URIs + "es1", "us1" , "o1", "p1", "s1" , "o2", "p2", "s2" , "s4", "o4", "s6", "s7" , "o3", "p3", "p4", "s3" + -- literals + , "l1" + -- language literals + , "l2", "l2gb", "l3" + -- typed literals (we have repeats) + , "l10", "l11", "l12" + , "l4", "l5", "l6" + , "l7", "l8", "l9" -- blank nodes , "b1", "b2", "b3", "b4" , "o5", "s5", "s8" + -- variables + , "v1", "v2" ] testNodeOrdSuite :: Test @@ -847,26 +851,17 @@ makeNewPrefixNamespace :: (T.Text,Namespace) -> Namespace makeNewPrefixNamespace (pre,ns) = makeNamespace (Just pre) (getNamespaceURI ns) -nslist :: LookupMap Namespace -nslist = LookupMap $ map makeNewPrefixNamespace - [ ("base1",base1) - , ("base2",base2) - , ("base3",base3) - , ("base4",base4) - ] +nslist :: NamespaceMap +nslist = M.fromList $ map getNamespaceTuple [base1,base2,base3,base4] -nslistalt :: LookupMap Namespace -nslistalt = LookupMap $ map makeNewPrefixNamespace - [ ("altbase1",base1) - , ("altbase2",base2) - , ("altbase3",base3) - ] +nslistalt :: NamespaceMap +nslistalt = M.fromList $ map (first (fmap (T.append "alt")) . getNamespaceTuple) [base1,base2,base3] toGraph :: [RDFTriple] -> RDFGraph toGraph stmts = NSGraph { namespaces = nslist , formulae = emptyFormulaMap - , statements = stmts + , statements = S.fromList stmts } g1, gt1 :: RDFGraph @@ -879,7 +874,7 @@ g1alt = NSGraph { namespaces = nslistalt , formulae = emptyFormulaMap - , statements = [t01] + , statements = S.singleton t01 } -- Construct version of g1 using just URIs @@ -893,14 +888,14 @@ tu01 = toRDFTriple uris1 urip1 urio1 g2arcs :: [String] -g2arcs = [ - "(base1:s1,base1:p1,base1:o1)", - "(base2:s2,base1:p1,base2:o2)", - "(base3:s3,base1:p1,base3:o3)", - "(base1:s1,base1:p1,\"l1\")", - "(base2:s2,base1:p1,\"l4\"^^base1:type1)", - "(base3:s3,base1:p1,\"l10\"^^rdf:XMLLiteral)" - ] +g2arcs = + [ "(base1:s1,base1:p1,base1:o1)" + , "(base1:s1,base1:p1,\"l1\")" + , "(base2:s2,base1:p1,base2:o2)" + , "(base2:s2,base1:p1,\"l4\"^^base1:type1)" + , "(base3:s3,base1:p1,base3:o3)" + , "(base3:s3,base1:p1,\"l10\"^^rdf:XMLLiteral)" + ] g2str :: String -> String g2str sp = @@ -985,9 +980,16 @@ , testGraphEq "g10-g10a" True g10 g10a ] +{- showLabel :: RDFLabel -> String showLabel = (" " ++) . show +-} +-- QUS: are these tests useful, since all they test os the Monoid instance +-- of NSGraph (but maybe we do not explicitly test this elsewhere?) +-- +-- The tests also used to check the Foldable instance of NSGraph but these +-- have been removed with the move to Set, rather than list, storage. testGraphFoldSuite :: Test testGraphFoldSuite = TestList [ @@ -999,13 +1001,15 @@ , testEq "foldEg1" g1 (Foldable.fold [mempty,g1]) , testEq "foldg1g2" fg1g2 (Foldable.fold [g1,g2]) , testEq "foldg2g1" fg1g2 (Foldable.fold [g2,g1]) +{- TODO: reinstate? , testEq "foldMap0" "" (Foldable.foldMap showLabel (mempty::RDFGraph)) , testEq "foldMapg1" (concatMap showLabel [s1,p1,o1]) (Foldable.foldMap showLabel g1) , testEq "foldMapg1f2" - (concatMap showLabel $ s2 : concatMap (\(Arc s p o) -> [s,p,o]) g2Labels ++ [s1,p1,o1]) + (concatMap showLabel $ s2 : concatMap arcToTriple g2Labels ++ [s1,p1,o1]) (Foldable.foldMap showLabel g1f2) +-} ] ------------------------------------------------------------ @@ -1015,9 +1019,8 @@ testFormulaLookup :: String -> FormulaMap RDFLabel -> RDFLabel -> Maybe RDFGraph -> Test testFormulaLookup lab fs fl gr = - testCompare "testFormulaLookup:" lab gr jfg - where - jfg = mapFindMaybe fl fs + testCompare "testFormulaLookup:" lab gr $ M.lookup fl fs + -- testCompare "testFormulaLookup:" lab gr $ fmap formGraph $ M.lookup fl fs testMaybeEq :: (Eq a, Show a) => String -> Maybe a -> Maybe a -> Test testMaybeEq = testCompare "testMaybeEq:" @@ -1031,6 +1034,7 @@ g1f6 = setFormulae fm6 g1f1 g1f7 = setFormulae fm7 g1f1 + g1f1str, g1f2str :: String g1f1str = @@ -1044,34 +1048,38 @@ "arcs: \n" ++ " (base1:s1,base1:p1,base1:o1)" -lf11, lf22, lf23, lf24, lf25, lf27, lf33, lf36 :: LookupFormula RDFLabel RDFGraph +lf11, lf22, lf23, lf24, lf25, lf27, lf33, lf36 :: Formula RDFLabel lf11 = Formula s1 g1 -lf22 = newEntry (s2,g2) -lf23 = newEntry (s2,g3) -lf24 = newEntry (s2,g4) -lf25 = newEntry (s2,g5) -lf27 = newEntry (s2,g7) -lf33 = newEntry (s3,g3) -lf36 = newEntry (s3,g6) +lf22 = Formula s2 g2 +lf23 = Formula s2 g3 +lf24 = Formula s2 g4 +lf25 = Formula s2 g5 +lf27 = Formula s2 g7 +lf33 = Formula s3 g3 +lf36 = Formula s3 g6 lf22str :: String lf22str = "base2:s2 :- { \n" ++ " (base1:s1,base1:p1,base1:o1)\n" ++ - " (base2:s2,base1:p1,base2:o2)\n" ++ - " (base3:s3,base1:p1,base3:o3)\n" ++ " (base1:s1,base1:p1,\"l1\")\n" ++ + " (base2:s2,base1:p1,base2:o2)\n" ++ " (base2:s2,base1:p1,\"l4\"^^base1:type1)\n" ++ + " (base3:s3,base1:p1,base3:o3)\n" ++ " (base3:s3,base1:p1,\"l10\"^^rdf:XMLLiteral) }" -fm2, fm3, fm4, fm5, fm6, fm7 :: LookupMap (LookupFormula RDFLabel RDFGraph) -fm2 = LookupMap [lf22] -fm3 = LookupMap [lf11, lf22, lf33] -fm4 = LookupMap [lf11, lf23, lf33] -fm5 = LookupMap [lf11, lf24, lf36] -fm6 = LookupMap [lf11, lf25, lf36] -fm7 = LookupMap [lf11, lf27, lf36] +toFM :: [Formula RDFLabel] -> FormulaMap RDFLabel +toFM = M.fromList . map (\fm -> (formLabel fm, formGraph fm)) +-- toFM = M.fromList . map (\fm -> (formLabel fm, fm)) +fm2, fm3, fm4, fm5, fm6, fm7 :: FormulaMap RDFLabel +fm2 = toFM [lf22] +fm3 = toFM [lf11, lf22, lf33] +fm4 = toFM [lf11, lf23, lf33] +fm5 = toFM [lf11, lf24, lf36] +fm6 = toFM [lf11, lf25, lf36] +fm7 = toFM [lf11, lf27, lf36] + f1, f2, f3, f4, f5, f6, f7 :: FormulaMap RDFLabel f1 = getFormulae g1f1 f2 = getFormulae g1f2 @@ -1225,17 +1233,17 @@ gt2f1a, gt2f1b, gt2f2a, gt2f2b, gt2f3a, gt2f3b :: RDFGraph gt1f1a = gt1 -gt1f1b = fmap translate g1f1 +gt1f1b = fmapNSGraph translate g1f1 gt1f2a = setFormulae ftm2 gt1 -gt1f2b = fmap translate g1f2 +gt1f2b = fmapNSGraph translate g1f2 gt1f3a = setFormulae ftm3 gt1 -gt1f3b = fmap translate g1f3 +gt1f3b = fmapNSGraph translate g1f3 gt2f1a = gt2 -gt2f1b = fmap translate g2f1 +gt2f1b = fmapNSGraph translate g2f1 gt2f2a = setFormulae ftm2 gt2 -gt2f2b = fmap translate g2f2 +gt2f2b = fmapNSGraph translate g2f2 gt2f3a = setFormulae ftm3 gt2 -gt2f3b = fmap translate g2f3 +gt2f3b = fmapNSGraph translate g2f3 ft1, ft2, ft3, ft4, ft5, ft6 :: FormulaMap RDFLabel ft1 = getFormulae gt1f1b @@ -1246,11 +1254,13 @@ ft6 = getFormulae gt2f3b ftm2, ftm3 :: FormulaMap RDFLabel -ftm2 = LookupMap [Formula st2 gt2] -ftm3 = LookupMap [Formula st1 gt1,Formula st2 gt2,Formula st3 gt3] +ftm2 = toFM [Formula st2 gt2] +ftm3 = toFM [Formula st1 gt1,Formula st2 gt2,Formula st3 gt3] -- Monadic translate tests, using Maybe Monad +{- TODO: reinstate? + gt1f1aM, gt1f1bM, gt1f2aM, gt1f2bM, gt1f5M :: Maybe RDFGraph gt1f1aM = Just gt1 gt1f1bM = Traversable.mapM translateM g1f1 @@ -1261,6 +1271,7 @@ ft1M, ft2M :: FormulaMap RDFLabel ft1M = getFormulae $ fromMaybe (error "Unexpected: gt1f1bM") gt1f1bM ft2M = getFormulae $ fromMaybe (error "Unexpected: gt1f2bM") gt1f2bM +--} testGraphTranslateSuite :: Test testGraphTranslateSuite = TestLabel "TestTranslate" $ TestList @@ -1289,17 +1300,17 @@ , testFormulaLookup "GraphTranslate06b" ft6 st1 (Just gt1) , testFormulaLookup "GraphTranslate06c" ft6 st2 (Just gt2) , testFormulaLookup "GraphTranslate06d" ft6 st3 (Just gt3) - , testGraphEqM "gt1f1aM-gt1f1bM" True gt1f1aM gt1f1bM - , testFormulaLookup "GraphTranslate07b" ft1M st1 Nothing - , testFormulaLookup "GraphTranslate07c" ft1M st2 Nothing - , testFormulaLookup "GraphTranslate07d" ft1M st3 Nothing - , testEq "gt1f1aM-gt1f1bM" gt1f1aM gt1f1bM - , testGraphEqM "gt1f2aM-gt1f2bM" True gt1f2aM gt1f2bM - , testFormulaLookup "GraphTranslate08b" ft2M st1 Nothing - , testFormulaLookup "GraphTranslate08c" ft2M st2 (Just gt2) - , testFormulaLookup "GraphTranslate08d" ft2M st3 Nothing - , testEq "gt1f2aM-gt1f2bM" gt1f2aM gt1f1bM - , testEq "GraphTranslate09a" Nothing gt1f5M +-- , testGraphEqM "gt1f1aM-gt1f1bM" True gt1f1aM gt1f1bM TODO: reinstate? +-- , testFormulaLookup "GraphTranslate07b" ft1M st1 Nothing +-- , testFormulaLookup "GraphTranslate07c" ft1M st2 Nothing +-- , testFormulaLookup "GraphTranslate07d" ft1M st3 Nothing +-- , testEq "gt1f1aM-gt1f1bM" gt1f1aM gt1f1bM +-- , testGraphEqM "gt1f2aM-gt1f2bM" True gt1f2aM gt1f2bM +-- , testFormulaLookup "GraphTranslate08b" ft2M st1 Nothing +-- , testFormulaLookup "GraphTranslate08c" ft2M st2 (Just gt2) +-- , testFormulaLookup "GraphTranslate08d" ft2M st3 Nothing +-- , testEq "gt1f2aM-gt1f2bM" gt1f2aM gt1f1bM +-- , testEq "GraphTranslate09a" Nothing gt1f5M ] ------------------------------------------------------------ @@ -1316,15 +1327,12 @@ assertGrEquiv :: String -> RDFGraph -> RDFGraph -> Assertion assertGrEquiv lbl gg1 gg2 = - assertGrHelper lbl gg1 gg2 $ getArcs gg1 `equiv` getArcs gg2 + assertGrHelper lbl gg1 gg2 $ getArcs gg1 == getArcs gg2 assertGrEq :: String -> RDFGraph -> RDFGraph -> Assertion assertGrEq lbl gg1 gg2 = assertGrHelper lbl gg1 gg2 $ gg1 == gg2 -testEquiv :: (Eq a) => String -> [a] -> [a] -> Test -testEquiv lab l1s l2s = TestCase $ assertBool lab (l1s `equiv` l2s) - tm01, tm02, tm03, tm04, tm05, tm06, tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 :: RDFTriple tm01 = arc s1 p1 b1 @@ -1405,38 +1413,38 @@ gm5, gm55 :: RDFGraph gm5 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm2] - , statements = [tm01,tm02,tm03] + , formulae = toFM [Formula b1 gm2] + , statements = S.fromList [tm01,tm02,tm03] } gm55 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm2,Formula b2 gm2f] - , statements = [tm01,tm02,tm03,tm41,tm42,tm43] + , formulae = toFM [Formula b1 gm2,Formula b2 gm2f] + , statements = S.fromList [tm01,tm02,tm03,tm41,tm42,tm43] } gm5s :: RDFGraph gm5s = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm2] - , statements = [tm01,tm02,tm03, + , formulae = toFM [Formula b1 gm2] + , statements = S.fromList [tm01,tm02,tm03, arc s1 p1 o1, arc o1 p2 s3, arc s2 p3 o4] } gm6, gm66 :: RDFGraph gm6 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula ba1 gm2,Formula bn3 gm3] - , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14] + , formulae = toFM [Formula ba1 gm2,Formula bn3 gm3] + , statements = S.fromList [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14] } gm66 = NSGraph { namespaces = nslist - , formulae = LookupMap + , formulae = toFM [Formula ba1 gm2,Formula bn3 gm3 ,Formula ba3 gm2f,Formula bn5 gm3f ] - , statements = [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14 + , statements = S.fromList [tm07,tm08,tm09,tm10,tm11,tm12,tm13,tm14 ,tm67,tm68,tm69,tm70,tm71,tm72,tm73,tm74 ] } @@ -1444,9 +1452,9 @@ gm456 :: RDFGraph gm456 = NSGraph { namespaces = nslist - -- , formulae = LookupMap [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] - , formulae = LookupMap [] - , statements = [tm01, tm04, + -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] + , formulae = M.empty + , statements = S.fromList [tm01, tm04, tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 , arc b4 p1 o2 @@ -1457,9 +1465,9 @@ gm564 :: RDFGraph gm564 = NSGraph { namespaces = nslist - -- , formulae = LookupMap [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] - , formulae = LookupMap [] - , statements = [tm01, tm02, tm03 + -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] + , formulae = M.empty + , statements = S.fromList [tm01, tm02, tm03 , arc b5 p2 b6 , tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 @@ -1469,9 +1477,9 @@ gm645 :: RDFGraph gm645 = NSGraph { namespaces = nslist - -- , formulae = LookupMap [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] - , formulae = LookupMap [] - , statements = [tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 + -- , formulae = toFM [Formula b1 gm2, Formula ba1 gm2, Formula bn3 gm3] + , formulae = M.empty + , statements = S.fromList [tm07, tm08, tm09, tm10, tm11, tm12, tm13, tm14 , arc s1 p1 b4 , arc b4 p1 o2 , arc b4 p1 o3 @@ -1502,21 +1510,21 @@ gm84, gm85, gm85a, gm86, gm86a :: RDFGraph gm84 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm81,Formula v2 gm81] - , statements = [tm81,tm82] + , formulae = toFM [Formula b1 gm81,Formula v2 gm81] + , statements = S.fromList [tm81,tm82] } gm85 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm82,Formula v4 gm82] - , statements = [tm811,tm821] + , formulae = toFM [Formula b1 gm82,Formula v4 gm82] + , statements = S.fromList [tm811,tm821] } gm85a = remapLabels [v1,v2] [v1,v2,b1,b2] id gm84 gm86 = NSGraph { namespaces = nslist - , formulae = LookupMap [Formula b1 gm82,Formula vb4 gm82] - , statements = [tm812,tm822] + , formulae = toFM [Formula b1 gm82,Formula vb4 gm82] + , statements = S.fromList [tm812,tm822] } gm86a = remapLabels [v1,v2] [v1,v2,b1,b2] makeBlank gm84 @@ -1544,7 +1552,7 @@ (mappend gm4 (mappend gm5 gm6)) (mappend (mappend gm4 gm5) gm6)) , testGraphEq "Remap07" True gm82 gm82a - , testEquiv "testRemapList07" gm82b2 gm82b1 + , testEqv "testRemapList07" gm82b2 gm82b1 , testGraphEq "Remap08" True gm83 gm83a , testGraphEq "Remap09" True gm85 gm85a , testGraphEq "Remap10" True gm86 gm86a diff --git a/tests/RDFProofContextTest.hs b/tests/RDFProofContextTest.hs --- a/tests/RDFProofContextTest.hs +++ b/tests/RDFProofContextTest.hs @@ -48,20 +48,18 @@ , scopeRDFD ) -import Data.LookupMap (mapFindMaybe) - -import Test.HUnit - ( Test(TestCase,TestList) - , assertBool, assertEqual ) +import Data.Maybe (isNothing, fromJust, fromMaybe) +import Data.Monoid (Monoid(..)) import Network.URI (URI, parseURI) -import Data.Monoid (Monoid(..)) -import Data.Maybe (isNothing, fromJust, fromMaybe) - +import qualified Data.Map as M import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B +import Test.HUnit + ( Test(TestCase,TestList) + , assertBool, assertEqual ) import TestHelpers ( runTestSuite , test , testEq @@ -150,8 +148,8 @@ xsdstrContext = [ rulesetRDF, rulesetRDFS, rulesetRDFD, rulesetXsdStr ] rulesetXsdInt, rulesetXsdStr :: RDFRuleset -rulesetXsdInt = fromJust $ mapFindMaybe (namespaceXsdType "integer") rdfRulesetMap -rulesetXsdStr = fromJust $ mapFindMaybe (namespaceXsdType "string") rdfRulesetMap +rulesetXsdInt = fromJust $ M.lookup (namespaceXsdType "integer") rdfRulesetMap +rulesetXsdStr = fromJust $ M.lookup (namespaceXsdType "string") rdfRulesetMap ------------------------ -- RDF/S rule tests diff --git a/tests/RDFProofTest.hs b/tests/RDFProofTest.hs --- a/tests/RDFProofTest.hs +++ b/tests/RDFProofTest.hs @@ -52,6 +52,7 @@ import Data.Monoid (Monoid(..)) import Data.Maybe (fromJust) +import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text.Lazy.Builder as B @@ -630,14 +631,14 @@ , " rel:daughter pers:Rh4 . \n" ] -vocab4 :: [RDFLabel] +vocab4 :: S.Set RDFLabel vocab4 = allNodes (not . labelIsVar) graph4 name4 :: ScopedName name4 = makeNSScopedName scope4 "instance4" rule4 :: RDFRule -rule4 = makeRdfInstanceEntailmentRule name4 vocab4 +rule4 = makeRdfInstanceEntailmentRule name4 (S.toList vocab4) fwd42a :: RDFGraph fwd42a = mkGr2 @@ -777,7 +778,7 @@ [ -- Check basics testEq "testRuleName41" name4 (ruleName rule4) - , testEq "testVocab41" 3 (length vocab4) + , testEq "testVocab41" 3 (S.size vocab4) , testEq "testFwdLength42" 7 (length fwdApply42) , testIn "testFwdApply42a" fwd42a fwdApply42 , testIn "testFwdApply42b" fwd42b fwdApply42 @@ -997,7 +998,7 @@ var71 = rdfQueryFind query71 graph7 var71a :: [VarBinding RDFLabel RDFLabel] -var71a = vbmApply (mod71 (allLabels labelIsVar graph7)) var71 +var71a = vbmApply (mod71 (S.toList (allLabels labelIsVar graph7))) var71 var71_1 :: VarBinding RDFLabel RDFLabel var71_1 = head var71a diff --git a/tests/RDFQueryTest.hs b/tests/RDFQueryTest.hs --- a/tests/RDFQueryTest.hs +++ b/tests/RDFQueryTest.hs @@ -56,15 +56,15 @@ import Swish.RDF.Vocabulary (namespaceRDF, toLangTag, swishName, rdfType, rdfXMLLiteral) import Swish.RDF.Parser.N3 (parseN3) -import Test.HUnit ( Test(TestList) ) - -import qualified Data.Text.Lazy.Builder as B +import Data.Monoid (Monoid(..)) +import Data.Maybe (fromJust) import Network.URI (URI, parseURI) -import Data.Monoid (Monoid(..)) -import Data.Maybe (fromJust) +import qualified Data.Set as S +import qualified Data.Text.Lazy.Builder as B +import Test.HUnit ( Test(TestList) ) import TestHelpers (runTestSuite , test , testEq @@ -76,9 +76,6 @@ -- misc helpers ------------------------------------------------------------ -testLs :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testLs = testEqv - testGr :: String -> B.Builder -> [RDFGraph] -> Test testGr lab e = testElem lab (graphFromBuilder mempty e) @@ -693,24 +690,24 @@ result44a = mconcat [ prefix4 - , "pers:Pa2 rel:son ?m . \n" - , "?m rel:son pers:Ro4 . \n" - , "?c rel:daughter ?n . \n" - , "?n rel:son ?d . \n" - ] - -result44b = - mconcat - [ prefix4 , "?a rel:son ?m . \n" , "?m rel:son ?b . \n" , "pers:Pa2 rel:daughter ?n . \n" , "?n rel:son pers:Ro4 . \n" ] +result44b = + mconcat + [ prefix4 + , "pers:Pa2 rel:son ?m . \n" + , "?m rel:son pers:Ro4 . \n" + , "?c rel:daughter ?n . \n" + , "?n rel:son ?d . \n" + ] + unbound44a, unbound44b :: [RDFLabel] -unbound44a = [Var "m", Var "c", Var "n", Var "d"] -unbound44b = [Var "a", Var "m", Var "b", Var "n"] +unbound44a = [Var "a", Var "b", Var "m", Var "n"] +unbound44b = [Var "c", Var "d", Var "m", Var "n"] var44 :: [[RDFVarBinding]] var44 = rdfQueryBack query44 graph44 @@ -796,15 +793,15 @@ result46a = mconcat [ prefix4 - , "?a rel:son pers:St3 . \n" - , "?a rel:stepson pers:Gr3 . \n" + , "?a rel:son pers:Gr3 . \n" + , "?a rel:stepson pers:St3 . \n" ] result46b = mconcat [ prefix4 - , "?a rel:son pers:Gr3 . \n" - , "?a rel:stepson pers:St3 . \n" + , "?a rel:son pers:St3 . \n" + , "?a rel:stepson pers:Gr3 . \n" ] unbound46a, unbound46b :: [RDFLabel] @@ -1050,41 +1047,41 @@ , testEq "testQuery41a" 1 (length var41) , testEq "testResult41" 1 (length res41) , testGr "testResult41a" result41a (fst $ unzip $ head res41) - , testLs "testUnbound41a" [] (snd $ head $ head res41) + , testEqv "testUnbound41a" [] (snd $ head $ head res41) , test "testQuery42" (not $ null var42) , testEq "testQuery42a" 1 (length var42) , testEq "testResult42" 1 (length res42) , testGr "testResult42a" result42a (fst $ unzip $ head res42) - , testLs "testUnbound42a" [Var "b"] (snd $ head $ head res42) + , testEqv "testUnbound42a" [Var "b"] (snd $ head $ head res42) , test "testQuery43" (not $ null var43) , testEq "testQuery43a" 1 (length var43) , testEq "testResult43" 1 (length res43) , testGr "testResult43a" result43a (fst $ unzip $ head res43) - , testLs "testUnbound43a" [Var "a"] (snd $ head $ head res43) + , testEqv "testUnbound43a" [Var "a"] (snd $ head $ head res43) , test "testQuery44" (not $ null var44) , testEq "testQuery44a" 2 (length var44) , testEq "testResult44" 2 (length res44) , testGr "testResult44a" result44a (fst $ unzip res44_2) - , testLs "testUnbound44a" unbound44a (snd $ head res44_2) + , testEqv "testUnbound44a" unbound44a (snd $ head res44_2) , testGr "testResult44b" result44b (fst $ unzip res44_1) - , testLs "testUnbound44b" unbound44b (snd $ head res44_1) + , testEqv "testUnbound44b" unbound44b (snd $ head res44_1) , test "testQuery45" (not $ null var45) , testEq "testQuery45a" 1 (length var45) , testEq "testResult45" 1 (length res45) , testEq "testResult45_1" 2 (length res45_1) , testGr "testResult45a1" result45a1 [fst res45_11] - , testLs "testUnbound45a1" unbound45a1 (snd res45_11) + , testEqv "testUnbound45a1" unbound45a1 (snd res45_11) , testGr "testResult45a2" result45a2 [fst res45_12] - , testLs "testUnbound45a2" unbound45a2 (snd res45_12) + , testEqv "testUnbound45a2" unbound45a2 (snd res45_12) , test "testQuery46" (not $ null var46) , testEq "testQuery46a" 2 (length var46) , testEq "testResult46" 2 (length res46) , testEq "testResult46_1" 1 (length res46_1) , testEq "testResult46_2" 1 (length res46_2) , testGr "testResult46a" result46a [fst res46_11] - , testLs "testUnbound46a" unbound46a (snd res46_11) + , testEqv "testUnbound46a" unbound46a (snd res46_11) , testGr "testResult46b" result46b [fst res46_21] - , testLs "testUnbound46b" unbound46b (snd res46_21) + , testEqv "testUnbound46b" unbound46b (snd res46_21) , test "testQuery47" (not $ null var47) , testEq "testQuery47a" 4 (length var47) , testEq "testResult47" 4 (length res47) @@ -1093,30 +1090,30 @@ , testEq "testResult47_3" 2 (length res47_3) , testEq "testResult47_4" 2 (length res47_4) , testGr "testResult47a1" result47a1 [fst res47_11] - , testLs "testUnbound47a1" unbound47a1 (snd res47_11) + , testEqv "testUnbound47a1" unbound47a1 (snd res47_11) , testGr "testResult47a2" result47a2 [fst res47_12] - , testLs "testUnbound47a2" unbound47a2 (snd res47_12) + , testEqv "testUnbound47a2" unbound47a2 (snd res47_12) , testGr "testResult47b1" result47b1 [fst res47_21] - , testLs "testUnbound47b1" unbound47b1 (snd res47_21) + , testEqv "testUnbound47b1" unbound47b1 (snd res47_21) , testGr "testResult47b2" result47b2 [fst res47_22] - , testLs "testUnbound47b2" unbound47b2 (snd res47_22) + , testEqv "testUnbound47b2" unbound47b2 (snd res47_22) , testGr "testResult47c1" result47c1 [fst res47_31] - , testLs "testUnbound47c1" unbound47c1 (snd res47_31) + , testEqv "testUnbound47c1" unbound47c1 (snd res47_31) , testGr "testResult47c2" result47c2 [fst res47_32] - , testLs "testUnbound47c2" unbound47c2 (snd res47_32) + , testEqv "testUnbound47c2" unbound47c2 (snd res47_32) , testGr "testResult47d1" result47d1 [fst res47_41] - , testLs "testUnbound47d1" unbound47d1 (snd res47_41) + , testEqv "testUnbound47d1" unbound47d1 (snd res47_41) , testGr "testResult47d2" result47d2 [fst res47_42] - , testLs "testUnbound47d2" unbound47d2 (snd res47_42) + , testEqv "testUnbound47d2" unbound47d2 (snd res47_42) , test "testQuery48" (not $ null var48) , testEq "testQuery48a" 2 (length var48) , testEq "testResult48" 2 (length res48) , testEq "testResult48_1" 1 (length res48_1) , testEq "testResult48_2" 1 (length res48_2) , testGr "testResult48a" result48a [fst res48_11] - , testLs "testUnbound48a" unbound48a (snd res48_11) + , testEqv "testUnbound48a" unbound48a (snd res48_11) , testGr "testResult48b" result48b [fst res48_21] - , testLs "testUnbound48b" unbound48b (snd res48_21) + , testEqv "testUnbound48b" unbound48b (snd res48_21) , test "testQuery49" (null var49) , testEq "testQuery49a" 0 (length var49) , testEq "testResult49" 0 (length res49) @@ -1126,9 +1123,9 @@ , testEq "testResult50_1" 1 (length res50_1) , testEq "testResult50_2" 1 (length res50_2) , testGr "testResult50a" result50a [fst res50_11] - , testLs "testUnbound50a" unbound50a (snd res50_11) + , testEqv "testUnbound50a" unbound50a (snd res50_11) , testGr "testResult50b" result50b [fst res50_21] - , testLs "testUnbound50b" unbound50b (snd res50_21) + , testEqv "testUnbound50b" unbound50b (snd res50_21) , testEq "testResult50F" 0 (length res50F) ] @@ -1233,7 +1230,7 @@ , testGr "testResult63a" result63a [res63a] , test "testQuery64" (not $ null var64) , testEq "testQuery64a" 1 (length var64) - , test "testQuery64b" (null $ vbEnum var64a) + , test "testQuery64b" (S.null $ vbEnum var64a) ] ------------------------------------------------------------ diff --git a/tests/RDFRulesetTest.hs b/tests/RDFRulesetTest.hs --- a/tests/RDFRulesetTest.hs +++ b/tests/RDFRulesetTest.hs @@ -48,7 +48,7 @@ import Swish.RDF.Graph ( Label (..), RDFLabel(..), RDFGraph - , Arc(..) + , RDFArcSet , getArcs , allLabels , toRDFGraph @@ -64,10 +64,11 @@ import Network.URI (URI, parseURI) import Data.Monoid (Monoid(..)) -import Data.List (nub, sort) +import Data.List (sort) import Data.Maybe (isJust, fromJust) +import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.Set as S import qualified Data.Text.Lazy.Builder as B import TestHelpers (runTestSuite @@ -77,69 +78,31 @@ , testCompareEq , testMaker ) -import qualified TestHelpers as T +import qualified TestHelpers as TH + ------------------------------------------------------------ -- Test case helpers ------------------------------------------------------------ testVal :: (Eq a, Show a) => String -> a -> a -> Test testVal = testCompare "testVal:" -{- -testVal lab a1 a2 = - TestCase ( assertEqual ("testVal:"++lab) a1 a2 ) --} testEq :: (Eq a, Show a) => String -> Bool -> a -> a -> Test testEq = testCompareEq "testIsEq:" -{- -testEq lab eq a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) eq (a1==a2) ) --} testEqual :: (Eq a, Show a) => String -> a -> a -> Test -testEqual = T.testEq -{- -testEqual lab a1 a2 = - TestCase ( assertEqual ("testEq:"++lab) a1 a2 ) --} - -{- -testLe :: (Ord a, Show a) => String -> Bool -> a -> a -> Test -testLe lab eq a1 a2 = - TestCase ( assertEqual ("testLe:"++lab) eq (a1<=a2) ) --} +testEqual = TH.testEq testStringEq :: String -> String -> String -> Test testStringEq = testCompare "testStringEq:" -{- -testStringEq lab s1 s2 = - TestCase ( assertEqual ("testStringEq:"++lab) s1 s2 ) --} testSameNamespace :: String -> Namespace -> Namespace -> Test testSameNamespace = testMaker getNamespaceTuple "testSameNamespace:" -{- -testSameNamespace lab n1 n2 = - TestCase ( assertBool ("testSameNamespace:"++lab) ((p1==p2)&&(u1==u2)) ) - where - (p1, u1) = getNamespaceTuple n1 - (p2, u2) = getNamespaceTuple n2 --} testScopedNameEq :: String -> Bool -> ScopedName -> ScopedName -> Test testScopedNameEq = testCompareEq "testScopedNameEq:" -{- -testScopedNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testScopedNameEq:"++lab) eq (n1==n2) ) --} -{- -testQNameEq :: String -> Bool -> QName -> QName -> Test -testQNameEq lab eq n1 n2 = - TestCase ( assertEqual ("testQNameEq:"++lab) eq (n1==n2) ) --} - testSameAs :: (Ord a) => String -> String -> [a] -> [a] -> Test testSameAs l1 l2 x y = let z = sort x == sort y @@ -162,7 +125,7 @@ toURI :: String -> URI toURI = fromJust . parseURI -toNS :: Maybe T.Text -> String -> Namespace +toNS :: Maybe Text -> String -> Namespace toNS p = makeNamespace p . toURI ------------------------------------------------------------ @@ -277,8 +240,8 @@ isXMLLit :: String -> RDFVarBindingFilter isXMLLit = rdfVarBindingXMLLiteral . Var -queryBack :: [Arc RDFLabel] -> RDFGraph -> [[RDFVarBinding]] -queryBack qas = rdfQueryBack (toRDFGraph qas) +queryBack :: RDFArcSet -> RDFGraph -> [[RDFVarBinding]] +queryBack qas = rdfQueryBack (toRDFGraph qas) -- Backward chaining rdf:r2 @@ -287,7 +250,7 @@ rdfr2con = makeRDFGraphFromN3Builder "?x ?a ?b . ?b rdf:type rdf:XMLLiteral ." rdfr2modv :: RDFVarBindingModify -rdfr2modv = allocateTo "b" "l" $ allLabels labelIsVar rdfr2ant +rdfr2modv = allocateTo "b" "l" $ S.toList $ allLabels labelIsVar rdfr2ant rdfr2modc :: Maybe RDFVarBindingModify rdfr2modc = vbmCompose (makeVarFilterModify $ isXMLLit "l") rdfr2modv @@ -334,45 +297,52 @@ b_l1 = Blank "l1" b_l2 = Blank "l2" -rdfr2v1, rdfr2b1, rdfr2v2, rdfr2v3 :: [[RDFVarBinding]] +-- could look at S.Set (S.Set RDFVarBinding) which would make +-- comparison easier to write +-- +rdfr2v1, rdfr2b1, rdfr2v2 :: [[RDFVarBinding]] rdfr2v1 = queryBack (ruleCon rdfr2grc) con03 -rdfr2b1 = [ [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] - , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] - , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] +rdfr2b1 = [ [ makeVarBinding [ (v_b,b_l2) ] , makeVarBinding [ (v_b,b_l1) ] - , makeVarBinding [ (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] - , [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] - , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] + , [ makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] + , makeVarBinding [ (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] - , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_rx) ] - , makeVarBinding [ (v_b,b_l2) ] - ] - , [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] - , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] - , makeVarBinding [ (v_b,b_l1) ] - , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] - , [ makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] - , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] + , [ makeVarBinding [ (v_b,b_l2) ] + , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] + ] + , [ makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] , makeVarBinding [ (v_x,b_l1), (v_a,u_rt), (v_b,u_rx) ] - , makeVarBinding [ (v_x,b_l2), (v_a,u_rt), (v_b,u_rx) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p2b), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p2a), (v_b,b_l2) ] + , makeVarBinding [ (v_x,u_s), (v_a,u_p1), (v_b,b_l1) ] ] ] rdfr2v2 = rdfQueryBackModify (ruleModify rdfr2grc) rdfr2v1 -rdfr2v3 = map nub rdfr2v2 +-- as rdfr2v2 is empty no point in the following + +-- rdfr2v3 :: [[RDFVarBinding]] +-- rdfr2v3 = map nub rdfr2v2 + testRDFSuite :: Test testRDFSuite = TestList - [ test "testRDF01" $ isJust rdfr2modc + [ test "testRDF01" (isJust rdfr2modc) , testVal "testRDF02" rdfr2b1 rdfr2v1 - , testVal "testRDF03" [] rdfr2v2 - , testVal "testRDF04" [] rdfr2v3 + , test "testRDF03" $ rdfr2v2 == [] + -- , test "testRDF04" $ rdfr2v3 == [] , testEq "testRDF09" True [] $ bwdApply rdfr2rul con03 ] diff --git a/tests/TestHelpers.hs b/tests/TestHelpers.hs --- a/tests/TestHelpers.hs +++ b/tests/TestHelpers.hs @@ -24,7 +24,7 @@ , testElem , testJust, testNothing , testJe, testJl, testNo - , testEqv, testEqv2, testHasEqv, testMaybeEqv + , testEqv, testNotEqv, testEqv2, testHasEqv, testMaybeEqv , testMaker ) where @@ -42,7 +42,7 @@ import Data.Maybe (isJust, isNothing, fromJust) -import Swish.Utils.ListHelpers (equiv) +import qualified Data.Set as S -- | Run the test suite and exit the process with either -- @exitSuccess@ or @exitFailure@. @@ -125,39 +125,35 @@ -- Compare lists and lists of lists and Maybe lists for set equivalence: -data ListTest a = ListTest [a] - -instance (Eq a) => Eq (ListTest a) where - (ListTest a1) == (ListTest a2) = a1 `equiv` a2 - -instance (Show a) => Show (ListTest a) where - show (ListTest a) = show a - -data MaybeListTest a = MaybeListTest (Maybe [a]) +data MaybeListTest a = MaybeListTest (Maybe (S.Set a)) -instance (Eq a) => Eq (MaybeListTest a) where - MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 `equiv` a2 +instance (Ord a) => Eq (MaybeListTest a) where + MaybeListTest (Just a1) == MaybeListTest (Just a2) = a1 == a2 MaybeListTest Nothing == MaybeListTest Nothing = True _ == _ = False instance (Show a) => Show (MaybeListTest a) where show (MaybeListTest a) = show a -testEqv :: (Eq a, Show a) => String -> [a] -> [a] -> Test -testEqv = testMaker ListTest "testEqv" +testEqv :: (Ord a, Show a) => String -> [a] -> [a] -> Test +testEqv = testMaker S.fromList "testEqv" -testEqv2 :: (Eq a, Show a) => String -> [[a]] -> [[a]] -> Test -testEqv2 = testMaker (ListTest . map ListTest) "testEqv2" +testNotEqv :: (Ord a, Show a) => String -> [a] -> [a] -> Test +testNotEqv lab a1 a2 = + TestCase ( assertBool ("testNotEqv:"++lab) (S.fromList a1 /= S.fromList a2) ) -testHasEqv :: (Eq a, Show a) => String -> [a] -> [[a]] -> Test +testEqv2 :: (Ord a, Show a) => String -> [[a]] -> [[a]] -> Test +testEqv2 = testMaker (S.fromList . map S.fromList) "testEqv2" + +testHasEqv :: (Ord a, Show a) => String -> [a] -> [[a]] -> Test testHasEqv lab a1 a2 = TestCase ( assertMember ("testHasEqv:"++lab) ma1 ma2 ) where - ma1 = ListTest a1 - ma2 = map ListTest a2 + ma1 = S.fromList a1 + ma2 = map S.fromList a2 -testMaybeEqv :: (Eq a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test -testMaybeEqv = testMaker MaybeListTest "testMaybeEqv" +testMaybeEqv :: (Ord a, Show a) => String -> Maybe [a] -> Maybe [a] -> Test +testMaybeEqv = testMaker (MaybeListTest . fmap S.fromList) "testMaybeEqv" {- diff --git a/tests/VarBindingTest.hs b/tests/VarBindingTest.hs --- a/tests/VarBindingTest.hs +++ b/tests/VarBindingTest.hs @@ -35,13 +35,12 @@ import Swish.RDF.Vocabulary (swishName) -import Test.HUnit (Test(TestList)) - import Data.List (union, intersect) import Data.Maybe (isJust, isNothing, fromJust) --- import qualified Data.Text as T +import qualified Data.Set as S +import Test.HUnit (Test(TestList)) import TestHelpers (runTestSuite , test , testEq @@ -63,7 +62,7 @@ vb2 = makeVarBinding [(3,"c"),(2,"b"),(1,"a")] vb2str :: String -vb2str = "[(3,\"c\"),(2,\"b\"),(1,\"a\")]" +vb2str = vb1str vb3 :: VarBinding Int String vb3 = makeVarBinding [(1,"a"),(2,"b"),(3,"c"),(4,"d"),(5,"e")] @@ -111,9 +110,9 @@ , testEq "testVarBinding04" vb1str $ show vb1 , testEq "testVarBinding05" vb2str $ show vb2 , testEq "testVarBinding06" vb4str $ show vb4 - , testEq "testVarBinding10" [1,2,3] $ boundVars vb1 - , testEq "testVarBinding11" [3,2,1] $ boundVars vb2 - , testEq "testVarBinding12" [] $ boundVars vb4 + , testEq "testVarBinding10" (S.fromList [1,2,3]) $ boundVars vb1 + , testEq "testVarBinding11" (S.fromList [3,2,1]) $ boundVars vb2 + , testEq "testVarBinding12" S.empty $ boundVars vb4 , test "testVarBinding20" (subBinding vb1 vb2) , test "testVarBinding21" (subBinding vb1 vb3) , test "testVarBinding22" $ not (subBinding vb1 vb4) @@ -181,13 +180,16 @@ -- Add new bindings per vb9m vbm1 :: VarBindingModify String Int -vbm1 = VarBindingModify - { vbmName = swishName "vbm1" - , vbmApply = map (`joinVarBindings` vb9m) - , vbmVocab = boundVars vb9m - , vbmUsage = [boundVars vb9m] - } +vbm1 = + let vcb = S.toList (boundVars vb9m) + in VarBindingModify + { vbmName = swishName "vbm1" + , vbmApply = map (`joinVarBindings` vb9m) + , vbmVocab = vcb + , vbmUsage = [vcb] + } + vb1m1, vb2m1 :: VarBinding String Int [vb1m1] = vbmApply vbm1 [vb1m] [vb2m1] = vbmApply vbm1 [vb2m] @@ -215,7 +217,7 @@ sumBinding :: String -> String -> String -> [VarBinding String Int] -> [VarBinding String Int] -sumBinding va vb vc vbinds = concatMap abSumc vbinds +sumBinding va vb vc = concatMap abSumc where abSumc :: VarBinding String Int -> [VarBinding String Int] abSumc vbind = @@ -347,7 +349,6 @@ vbabcd :: VarBinding String Int vbabcd = makeVarBinding [("a",1),("b",2),("c",3),("d",4)] - -- [[[need test for incompatible composition]]] -- -- Three ways to be incompatible: