diff --git a/Data/Interned/URI.hs b/Data/Interned/URI.hs new file mode 100644 --- /dev/null +++ b/Data/Interned/URI.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE TypeFamilies, FlexibleInstances #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : URI +-- Copyright : (c) 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : TypeFamilies, FlexibleInstances +-- +-- Support interning URIs. +-- +-------------------------------------------------------------------------------- + +module Data.Interned.URI + ( InternedURI + ) where + +import Data.String (IsString(..)) +import Data.Hashable +import Data.Interned +import Data.Maybe (fromMaybe) + +import Network.URI + +-- Could look at adding UNPACK statements before each component +data InternedURI = InternedURI !Int !URI + +instance IsString InternedURI where + fromString = intern . + fromMaybe (error "Error: unable to create a URI.") . + parseURIReference + + +instance Eq InternedURI where + InternedURI a _ == InternedURI b _ = a == b + +instance Ord InternedURI where + compare (InternedURI a _) (InternedURI b _) = compare a b + +instance Show InternedURI where + showsPrec d (InternedURI _ b) = showsPrec d b + +instance Interned InternedURI where + type Uninterned InternedURI = URI + data Description InternedURI = DU !URI deriving (Eq) -- DU {-# UNPACK #-} !URI deriving (Eq) + describe = DU + identify = InternedURI + identity (InternedURI i _) = i + cache = iuCache + +instance Uninternable InternedURI where + unintern (InternedURI _ b) = b + +-- Rather than be clever, use the reverse of the string +-- representation of the URI +instance Hashable (Description InternedURI) where + hash = hashWithSalt 5381 -- use the stringSalt value from Data.Hashable + hashWithSalt salt (DU u) = hashWithSalt salt ((reverse . show) u) + +iuCache :: Cache InternedURI +iuCache = mkCache +{-# NOINLINE iuCache #-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/Utils/Namespace.hs b/Swish/Utils/Namespace.hs --- a/Swish/Utils/Namespace.hs +++ b/Swish/Utils/Namespace.hs @@ -115,7 +115,7 @@ -- ScopedName, made from a namespace and a local name ------------------------------------------------------------ --- |A full ScopedName value has a QName prefix, namespace URI +-- | A full ScopedName value has a QName prefix, namespace URI -- and a local part. ScopedName values may omit the prefix -- (see 'Namespace') or the local part. -- @@ -124,15 +124,19 @@ -- data ScopedName = ScopedName !QName Namespace T.Text +-- | Returns the local part. getScopeLocal :: ScopedName -> T.Text getScopeLocal (ScopedName _ _ l) = l +-- | Returns the namespace. getScopeNamespace :: ScopedName -> Namespace getScopeNamespace (ScopedName _ ns _) = ns +-- | Returns the prefix of the namespace, if set. getScopePrefix :: ScopedName -> Maybe T.Text getScopePrefix = getNamespacePrefix . getScopeNamespace +-- | Returns the URI of the namespace. getScopeURI :: ScopedName -> URI getScopeURI = getNamespaceURI . getScopeNamespace @@ -142,34 +146,30 @@ maybe (error ("Unable to convert " ++ s ++ " into a ScopedName")) makeURIScopedName (parseURIReference s) +-- | Scoped names are equal if their corresponding QNames are equal instance Eq ScopedName where - (==) = snEq + (ScopedName qn1 _ _) == (ScopedName qn2 _ _) = qn1 == qn2 +-- | Scoped names are ordered by their QNames instance Ord ScopedName where - (<=) = snLe + (ScopedName qn1 _ _) <= (ScopedName qn2 _ _) = qn1 <= qn2 +-- | If there is a namespace associated then the Show instance +-- uses @prefix:local@, otherwise @@. instance Show ScopedName where - show (ScopedName _ n l) = case getNamespacePrefix n of + show (ScopedName qn n l) = case getNamespacePrefix n of Just pre -> T.unpack $ mconcat [pre, ":", l] - _ -> "<" ++ show (getNamespaceURI n) ++ T.unpack l ++ ">" - --- Scoped names are equal if their corresponding QNames are equal -snEq :: ScopedName -> ScopedName -> Bool -snEq s1 s2 = getQName s1 == getQName s2 - --- Scoped names are ordered by their QNames -snLe :: ScopedName -> ScopedName -> Bool -snLe s1 s2 = getQName s1 <= getQName s2 + _ -> show qn -- "<" ++ show (getNamespaceURI n) ++ T.unpack l ++ ">" --- |Get QName corresponding to a scoped name +-- |Get the QName corresponding to a scoped name. getQName :: ScopedName -> QName getQName (ScopedName qn _ _) = qn --- |Get URI corresponding to a scoped name (using RDF conventions) +-- |Get URI corresponding to a scoped name (using RDF conventions). getScopedNameURI :: ScopedName -> URI getScopedNameURI = getQNameURI . getQName --- for the moment leave this as String rather than Text +-- for the moment leave matchName using String rather than Text -- |Test if supplied string matches the display form of a -- scoped name. @@ -181,14 +181,7 @@ makeScopedName pre nsuri local = ScopedName (newQName nsuri local) (Namespace pre nsuri) local -{- -TODO: should just pass URIs around. - -At the moment support the use of URI references. Unclear of semantics -to know whether this is sensible (probably is, but should look at). --} - --- |Construct a ScopedName from a QName +-- |Construct a ScopedName from a QName. makeQNameScopedName :: Maybe T.Text -> QName -> ScopedName makeQNameScopedName pre qn = ScopedName qn (Namespace pre (getNamespace qn)) (getLocalName qn) diff --git a/Swish/Utils/QName.hs b/Swish/Utils/QName.hs --- a/Swish/Utils/QName.hs +++ b/Swish/Utils/QName.hs @@ -39,6 +39,9 @@ import Data.String (IsString(..)) import Data.Maybe (fromMaybe) +import Data.Interned (intern, unintern) +import Data.Interned.URI (InternedURI) + import qualified Data.Text as T ------------------------------------------------------------ @@ -60,7 +63,7 @@ may not be a good idea (space vs time saving). -} -data QName = QName !URI URI T.Text +data QName = QName !InternedURI URI T.Text -- | This is not total since it will fail if the input string is not a valid URI. instance IsString QName where @@ -83,7 +86,12 @@ -} -- 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) @@ -122,7 +130,7 @@ uri = fromMaybe (error ("Unable to combine " ++ show ns ++ " with " ++ l)) $ luri `relativeTo` ns -} - in QName uri ns local + in QName (intern uri) ns local {- @@ -141,14 +149,15 @@ qnameFromURI uri = let uf = uriFragment uri up = uriPath uri - q0 = QName uri uri "" + q0 = QName iuri uri "" + iuri = intern uri in case uf of "#" -> q0 - '#':xs -> QName uri (uri { uriFragment = "#" }) (T.pack xs) + '#':xs -> QName iuri (uri { uriFragment = "#" }) (T.pack xs) "" -> case break (=='/') (reverse up) of ("",_) -> q0 -- path ends in / or is empty (_,"") -> q0 -- path contains no / - (rlname,rpath) -> QName uri (uri {uriPath = reverse rpath}) (T.pack (reverse rlname)) + (rlname,rpath) -> QName iuri (uri {uriPath = reverse rpath}) (T.pack (reverse rlname)) e -> error $ "Unexpected: uri=" ++ show uri ++ " has fragment='" ++ show e ++ "'" @@ -170,7 +179,7 @@ -- | Returns the full URI of the QName (ie the combination of the -- namespace and local components). getQNameURI :: QName -> URI -getQNameURI (QName u _ _) = u +getQNameURI (QName u _ _) = unintern u {- Original used comparison of concatenated strings, diff --git a/swish.cabal b/swish.cabal --- a/swish.cabal +++ b/swish.cabal @@ -1,5 +1,5 @@ Name: swish -Version: 0.5.0.3 +Version: 0.6.0.0 Stability: experimental License: LGPL License-file: LICENSE @@ -46,6 +46,9 @@ . Changes: . + [Version 0.6.0.0] Add Data.Interned.URI and use it to speed up the QName + equality check. + . [Version 0.5.0.3] Didn't get all the required @FlexibleInstances@. . [Version 0.5.0.2] HUnit constraint is only added when the @tests@ flag @@ -172,7 +175,9 @@ mtl >= 1 && < 3, network >= 2.2 && < 2.4, directory >= 1.0 && < 1.2, - filepath >= 1.1 && < 1.3 + filepath >= 1.1 && < 1.3, + hashable == 1.1.*, + intern == 0.8.* Exposed-Modules: Swish @@ -218,6 +223,7 @@ Swish.Utils.PartOrderedCollection Swish.Utils.QName Swish.Utils.ShowM + Data.Interned.URI other-modules: -- Paths_swish