diff --git a/Swish.hs b/Swish.hs --- a/Swish.hs +++ b/Swish.hs @@ -28,9 +28,9 @@ -- "Swish.RDF.SwishScript". -- -- Users wishing to process RDF data directly may prefer to look at --- the following modules; "Swish.RDF", "Swish.RDF.N3Parser", --- "Swish.RDF.N3Formatter", "Swish.RDF.NTParser" and --- "Swish.RDF.NTFormatter". +-- the following modules; "Swish.RDF", "Swish.RDF.TurtleParser", +-- "Swish.RDF.N3Parser", "Swish.RDF.N3Formatter", "Swish.RDF.NTParser" +-- and "Swish.RDF.NTFormatter". -- -- (1) Semantic web: -- @@ -40,7 +40,9 @@ -- -- (4) Notation 3: -- --- (5) RDF: +-- (5) Turtle: +-- +-- (6) RDF: -- -------------------------------------------------------------------------------- diff --git a/Swish/RDF/N3Parser.hs b/Swish/RDF/N3Parser.hs --- a/Swish/RDF/N3Parser.hs +++ b/Swish/RDF/N3Parser.hs @@ -449,10 +449,11 @@ is09 c = c >= '0' && c <= '9' isaz09 c = isaz c || is09 c +match :: (Ord a) => a -> [(a,a)] -> Bool +match v = any (\(l,h) -> v >= l && v <= h) + startChar :: Char -> Bool startChar c = let i = ord c - match :: (Ord a) => a -> [(a,a)] -> Bool - match v = any (\(l,h) -> v >= l && v <= h) in c == '_' || match c [('A', 'Z'), ('a', 'z')] || match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x02ff), @@ -464,8 +465,6 @@ inBody :: Char -> Bool inBody c = let i = ord c - match :: (Ord a) => a -> [(a,a)] -> Bool - match v = any (\(l,h) -> v >= l && v <= h) in c `elem` "-_" || i == 0x007 || match c [('0', '9'), ('A', 'Z'), ('a', 'z')] || match i [(0x00c0, 0x00d6), (0x00d8, 0x00f6), (0x00f8, 0x037d), @@ -735,8 +734,7 @@ qname :: N3Parser ScopedName qname = - -- (char ':' *> toSN getDefaultPrefix) - (char ':' >> g >>= return . uncurry makeNSScopedName) + fmap (uncurry makeNSScopedName) (char ':' >> g) <|> (n3Name >>= fullOrLocalQName) where g = (,) <$> getDefaultPrefix <*> (n3Name <|> return "") @@ -1048,14 +1046,6 @@ We change the production rule from objecttail to objectlist for lists of objects (may change back). -May be an optimisation needed in the case of - - :s :p :o1 , .. , :o. - -Is parsec creating the list of actions, using sepBy1 -in objectListWith, and then evaluating them all once the list -has been created? - -} object :: N3Parser RDFLabel @@ -1126,559 +1116,6 @@ atWord "forAll" *> failBad "universal (@forAll) currently unsupported." -- will be something like: *> symbolCsl - -{- - --- OLD -- - --- helper routines - -isymbol :: String -> N3Parser () -isymbol s = symbol s >> return () - --- document = directive* statement-list - -document :: N3Parser RDFGraph -document = do - whiteSpace - _ <- many directive - statements - eof - s <- getState - return $ setNamespaces (prefixUris s) (graphState s) - --- directive = "@prefix" prefix ":" uriRef2 "." // Namespace declaration --- | "@prefix" ":" uriRef2 "." // Default namespace --- | "@equivalence" uriRef2 "." // Alternative to daml:equivalent --- | "@listfirst" uriRef2 "." // Alternative to n3:first --- | "@listrest" uriRef2 "." // Alternative to n3:rest --- | "@listnull" uriRef2 "." // Alternative to n3:null --- | "@plus" uriRef2 "." // Alternative to operator:plus --- | "@minus" uriRef2 "." // Alternative to operator:minus --- | "@slash" uriRef2 "." // Alternative to operator:slash --- | "@star" uriRef2 "." // Alternative to operator:star --- | "@base" uriRef2 "." // Base URI for relative URIs. - -directive :: N3Parser () -directive = - (try (symbol "@prefix") >> (defaultPrefix <|> namedPrefix)) - <|> (string "@" >> syntaxUri) - "directive" - -defaultPrefix :: N3Parser () -defaultPrefix = do - u <- br ":" "." uriRef2 - updateState $ setPrefix "" (getScopedNameURI u) - -namedPrefix :: N3Parser () -namedPrefix = do - n <- name - u <- br ":" "." uriRef2 - updateState $ setPrefix n (getScopedNameURI u) - -syntaxUri :: N3Parser () -syntaxUri = do - s <- uriName - u <- uriRef2 - isymbol "." - updateState $ setSUri s (getScopedNameURI u) - -uriName :: N3Parser String -uriName = - try (symbol "equivalence") - <|> try (symbol "listfirst") - <|> try (symbol "listrest") - <|> try (symbol "listnull") - <|> try (symbol "plus") - <|> try (symbol "minus") - <|> try (symbol "slash") - <|> try (symbol "star") - <|> try (symbol "base") - "special URI directive" - - --- statements = [ statement ( "." statement )* ] --- --- statement = subject property-list --- --- properties = [ property ( ";" property )* ] --- --- New statements are added to the user state graph - -statements :: N3Parser () -statements = sepEndBy1 statement (symbol ".") >> return () - -statement :: N3Parser () --- statement = subject >>= optional . properties -- when using Parsec's optional -statement = subject >>= optional . properties >> return () -- not sure this is exactly the same as with Parsec - -properties :: RDFLabel -> N3Parser () -properties subj = sepBy1 (property subj) (symbol ";") >> return () - - --- property = verb object-list --- | ":-" anon-node // Creates anon-node aongside the current node --- verb = ">-" prop "->" // has 'prop' of --- | "<-" prop "<-" // is 'prop' of --- | operator // has operator:'operator' of (???) --- | prop // has 'prop' of -- shorthand --- | "has" prop "of" // has 'prop' of --- | "is" prop "of" // is 'prop' of --- | "a" // has rdf:type of --- | "=" // has daml:equivalent of --- --- subj is the subject node for these properties. --- --- New statements are added to the graph in the parser's user state. - -property :: RDFLabel -> N3Parser () -property subj = - (verb >>= uncurry (objects subj)) - <|> - (isymbol ":-" >> anonNode subj >> return ()) - -verb :: N3Parser (RDFLabel,Bool) -verb = - (prop >>= \p -> return (p, False)) - <|> (operator >>= \p -> return (p, False)) - <|> (br ">-" "->" prop >>= \p -> return (p, False)) - <|> (br "<-" "<-" prop >>= \p -> return (p, True)) - <|> (br "has" "of" prop >>= \p -> return (p, False)) - <|> (br "is" "of" prop >>= \p -> return (p, True)) - <|> (symbol "a" >> operatorLabel rdf_type >>= \lab -> return (lab, False)) - <|> (symbol "=" >> operatorLabel owl_sameAs >>= \lab -> return (lab, False)) - "property" - - --- objects = object --- | object "," object-list --- --- subj is the subject node for the new statements, --- prop is the property node for the new statements. --- swap is true if the subject/object values in the resulting statement --- are to be swapped (for "is of", etc.) --- --- New statements are added to the graph in the parser's user state - -objects :: RDFLabel -> RDFLabel -> Bool -> N3Parser () -objects subj ppty swap = - sepBy1 (object subj ppty swap) (symbol ",") >> return () - --- anonNode = "[" property-list "]" // Something with given properties --- | "{" statement-list "}" // List of statements as resource --- | "(" node-list ")" // Construct list with --- // rdf:first, rdf:rest, rdf:nil --- --- subj is the subject node with which the new anonymous node is equated, --- --- The anonymous node value is returned by this parser (which is often the same --- as the supplied subject node, but not always). --- --- New statements are added to the graph in the parser's user state --- (in the case of a formula, a new graph and parser are created, and --- the graph arcs are added to this new graph). - -anonNode :: RDFLabel -> N3Parser RDFLabel -anonNode subj = - (br "[" "]" (properties subj) >> return subj) - <|> br "{" "}" (formula subj) - <|> br "(" ")" (nodeList subj) - "anon node (\"[\", \"(\" or \"{\")" - --- This method allows a statement list to be parsed as a subgraph --- whose value is associated with the supplied node of the current --- graph. - -formula :: RDFLabel -> N3Parser RDFLabel -formula subj = do - subgr <- subgraph subj - updateState - $ updateGraph - $ setFormula (Formula subj subgr) - return subj - -subgraph :: RDFLabel -> N3Parser RDFGraph -subgraph this = do - pstate <- getState - let fstate = pstate { graphState = emptyRDFGraph, thisNode = this } - setState fstate -- switch new state into parser - statements -- parse statements of formula - fstate' <- getState - let nstate = pstate { nodeGen = nodeGen fstate' } - setState nstate -- swap back state, with updated nodeGen - return (graphState fstate') - --- prop = uri-ref2 --- | varid --- --- Returns URI value as a Node - -prop :: N3Parser RDFLabel -prop = nodeid <|> varid <|> uriNode - - --- operator = "+" // >- operator:plus -> --- | "-" // >- operator:minus -> --- | "/" // >- operator:slash -> --- | "*" // >- operator:star-> --- --- If matched, the operator is returned as a node value. - -operator :: N3Parser RDFLabel -operator = - (symbol "+" >> operatorLabel operator_plus) - <|> (symbol "-" >> operatorLabel operator_minus) - <|> (symbol "*" >> operatorLabel operator_star) - <|> (symbol "/" >> operatorLabel operator_slash) - "" - --- subject = node - -subject :: N3Parser RDFLabel -subject = node - - --- object = litNode --- --- This production adds a new triple to the graph state, --- using the supplied subject and property values. --- If swap is True, the subject and object positions are --- swapped. - -object :: RDFLabel -> RDFLabel -> Bool -> N3Parser () -object subj ppty True = do - o <- litNode - addStatement o ppty subj - -object subj ppty _ = do - o <- litNode - addStatement subj ppty o - --- nodeList = litNode* --- --- subj is the node from which the list is linked. --- --- Returns the supplied head of list or Nil node allocated. --- --- Link first element of link to list head, scan rest of list, --- and return the list head; otherwise return a node rdf_null. --- --- This slightly convoluted pattern is to deal with two different --- occurrences of a list node: --- :- ( l1, l2, ... ) --- Here, (the supplied subj) is the listhead. --- prop ( l1, l2, ... ) --- Here, the a new blank is supplied as subj to be the listhead. --- In either case, if the list is non-empty, the supplied subj --- is returned. But if the list is empty, a rdf_null node is returned. --- In the second case, the invoking production must use the returned --- value. - -nodeList :: RDFLabel -> N3Parser RDFLabel -nodeList subj = - (do - val <- litNode - first <- operatorLabel rdf_first - addStatement subj first val - nodeList1 subj - return subj) - <|> operatorLabel rdf_nil - "Node or ')'" - -nodeList1 :: RDFLabel -> N3Parser () -nodeList1 prev = - (do - val <- litNode - lnk <- newBlankNode - first <- operatorLabel rdf_first - rest <- operatorLabel rdf_rest - addStatement lnk first val - addStatement prev rest lnk - nodeList1 lnk) - <|> (do - nil <- operatorLabel rdf_nil - rest <- operatorLabel rdf_rest - addStatement prev rest nil) - "Node or ')'" - - --- lit-node = node --- | str-node [ "@" lang ] [ "^^" uriRef2 ] --- str-node = '"' constant-value '"' --- | '"""' constant value '"""' // Including single or double occurences of --- // quotes and/or newlines --- --- Returns a new node value. - -litNode :: N3Parser RDFLabel -litNode = - node - <|> liftM2 Lit strNode litTypeOrLang - "URI, blank node or literal" - -strNode :: N3Parser String -strNode = - tripleQuoteString - <|> singleQuoteString - - -litTypeOrLang :: N3Parser (Maybe ScopedName) -litTypeOrLang = - langTag - <|> typeUri - <|> return Nothing - "'@tag' (language tag) or '^^name' (datatype URI)" - -langTag :: N3Parser (Maybe ScopedName) -langTag = - fmap (Just . langName) (string "@" >> name) - "'@tag' (language tag)" - -typeUri :: N3Parser (Maybe ScopedName) -typeUri = - fmap Just (string "^^" >> uriRef2) - "'^^name' (datatype URI)" - --- node = nodeid --- | varid --- | uri-ref2 --- | anon-node --- --- nodeid = "_:" name --- --- varid = "?" name --- --- Returns a new node value. - -node :: N3Parser RDFLabel -node = nodeid - <|> varid - <|> uriNode - <|> (newBlankNode >>= anonNode) - "URI or blank node" - --- Identified blank node in input --- --- Note that automatically generated blank node identifiers start with --- a digit, where input node identifiers start with a letter, so there --- can be no clash. Care is needed when serializing a graph to ensure --- that future clashes are avoided. - -nodeid :: N3Parser RDFLabel --- nodeid = lexeme nodeid1 -nodeid = fmap Blank (string "_:" >> name) - --- variable identifier - -varid :: N3Parser RDFLabel -varid = fmap Var (string "?" >> name) - --- uriNode = qname --- | "<" URI-reference ">" --- | "this" - -uriNode :: N3Parser RDFLabel -uriNode = - fmap Res uriRef2 - <|> fmap thisNode (string "this" >> getState) - "URI node" - - --- uriRef2 = qname --- | ":" local-name --- | "<" URI-reference ">" --- qname = prefix ":" local-name --- --- prefix = name // Namespace prefix --- --- local-name = name // Local name (namespace qualified) --- --- name = alpha alphanumeric* --- --- alpha = "a"-"z" --- | "A"-"Z" --- | "_" --- --- alphanumeric = alpha --- | "0"-"9" --- --- URI-reference = (conforming to syntax in RFC2396) --- --- uriRef2 returns a ScopedName. - -uriRef2 :: N3Parser ScopedName -uriRef2 = lexeme (try uriRef2a) - "URI or QName" - -uriRef2a :: N3Parser ScopedName -uriRef2a = - liftM2 ScopedName prefix (colon >> localname) - <|> (colon >> liftM2 ScopedName defaultprefix localname) - <|> fmap makeUriScopedName absUriRef - "URI or QName" - -prefix :: N3Parser Namespace -prefix = do - pref <- prefixname - st <- getState - return (getPrefixNs st pref) -- map prefix to namespace - -defaultprefix :: N3Parser Namespace -defaultprefix = do - st <- getState - return (getPrefixNs st "") - -name :: N3Parser String -name = lexeme $ name1 identStart - -prefixname :: N3Parser String -prefixname = name1 identStart - -localname :: N3Parser String -localname = lexeme $ name1 identLetter - --- 'name1' is a name without following whitespace --- initChar is a parser for the first character -name1 :: N3Parser Char -> N3Parser String -name1 initChar = - liftM2 (:) initChar (many identLetter) - "identifier" - - ----------------------------------------------------------------------- --- Lexical support ----------------------------------------------------------------------- --- --- The following code adapted from ParsecToken, --- modified to handle different escape conventions and triple-quoted strings --- \c --- \uhhhh --- \Uhhhhhhhh --- --- Regular single-quoted string -- cannot be split over line breaks - -singleQuoteString :: N3Parser String -singleQuoteString = - lexeme - ( between (char '"') (char '"' "end of string (\")") anyStringChars - "literal string" ) - -anyStringChars :: CharParser st String -anyStringChars = - fmap (foldr (maybe id (:)) "") (many stringChar) - --- Triple-quoted string -- may include line breaks, '"' or '""'. -tripleQuoteString :: N3Parser String -tripleQuoteString = - lexeme - (fmap (foldr (++) "") $ between (try $ string "\"\"\"") - (string "\"\"\"" "end of string (\"\"\")") - (many tripleQuoteSubstring)) - "triple-quoted literal string" - --- Match non-quote substring or one or two quote characters -tripleQuoteSubstring :: N3Parser String -tripleQuoteSubstring = - tripleQuoteSubstring1 - <|> try sqTripleQuoteSubstring1 - <|> try dqTripleQuoteSubstring1 - -dqTripleQuoteSubstring1 :: N3Parser String -dqTripleQuoteSubstring1 = - fmap ("\"\""++) $ string "\"\"" >> tripleQuoteSubstring1 - -sqTripleQuoteSubstring1 :: N3Parser String -sqTripleQuoteSubstring1 = - fmap ('"':) $ char '"' >> tripleQuoteSubstring1 - --- match at least one non-quote character in a triple-quoted string -tripleQuoteSubstring1 :: N3Parser String -tripleQuoteSubstring1 = - fmap (foldr (maybe id (:)) "") $ many1 tripleQuoteStringChar - -tripleQuoteStringChar :: CharParser st (Maybe Char) -tripleQuoteStringChar = - stringChar <|> (string "\n" >> return (Just '\n')) - -stringChar :: CharParser st (Maybe Char) -stringChar = - fmap Just stringLetter - <|> stringEscape - "string character" - -stringLetter :: CharParser st Char -stringLetter = satisfy (\c -> (c /= '"') && (c /= '\\') && (c >= '\032')) - -stringEscape :: CharParser st (Maybe Char) -stringEscape = - fmap Just $ char '\\' >> escapeCode - --- escape codes -escapeCode :: CharParser st Char -escapeCode = charEsc <|> charUCS2 <|> charUCS4 "escape code" - --- \c -charEsc :: CharParser st Char -charEsc = choice (map parseEsc escMap) - where - parseEsc (c,code) = fmap (const code) (char c) - escMap = zip "nrt\\\"\'" "\n\r\t\\\"\'" - --- \uhhhh -charUCS2 :: CharParser st Char -charUCS2 = - fmap chr $ char 'u' >> numberFW 16 hexDigit 4 0 - --- \Uhhhhhhhh -charUCS4 :: CharParser st Char -charUCS4 = - fmap chr $ char 'U' >> numberFW 16 hexDigit 8 0 - --- parse fixed-width number: -numberFW :: Int -> CharParser st Char -> Int -> Int -> CharParser st Int -numberFW _ _ 0 val = return val -numberFW base baseDigit width val = do - d <- baseDigit - numberFW base baseDigit (width-1) (val*base + digitToInt d) - - ----------------------------------------------------------------------- --- Parse a URI reference from the input --- The result returned has absolute form; relative URIs are resolved --- relative to the current base prefix (set using "@base"). --- - --- lexeme version -lexUriRef :: N3Parser String -lexUriRef = lexeme absUriRef - --- from Swish.Utils.ProcessURI -absoluteUriPart :: String -- ^ URI base - -> String -- ^ URI reference - -> String -absoluteUriPart base rel = showURI $ fromJust $ relativeTo (fromJust (parseURIReference rel)) (fromJust (parseURI base)) - -absUriRef :: N3Parser String -absUriRef = do - u <- between (char '<') (char '>' "end of URI '>'") anyUriChars - if isURI u - then return u - else if isURIReference u - then do - s <- getState - return $ absoluteUriPart (getSUri s "base") u - else fail ("Invalid URI: <"++u++">") - -anyUriChars :: N3Parser String -anyUriChars = many uriChar - -uriChar :: N3Parser Char -uriChar = - alphaNum - <|> oneOf "[];?:@&=+$,-_.!~*'()%//#" - "URI character" - --} -------------------------------------------------------------------------------- -- diff --git a/Swish/RDF/RDFGraph.hs b/Swish/RDF/RDFGraph.hs --- a/Swish/RDF/RDFGraph.hs +++ b/Swish/RDF/RDFGraph.hs @@ -89,7 +89,7 @@ import Swish.RDF.GraphClass ( LDGraph(..), Label (..) - , Arc(..), arc, arcSubj, arcPred, arcObj + , Arc(..), arc, arcSubj, arcPred, arcObj, arcLabels , Selector ) import Swish.RDF.GraphMatch (graphMatch, LabelMap, ScopedLabel(..)) @@ -119,6 +119,7 @@ import Network.URI (URI) import Data.Monoid (Monoid(..)) +import Data.Maybe (mapMaybe) import Data.Char (ord, isDigit) import Data.List (intersect, union, findIndices, foldl') import Data.Ord (comparing) @@ -663,11 +664,11 @@ -- first character of local name is '_' and -- remaining characters of local name are all digits isMemberProp :: RDFLabel -> Bool -isMemberProp (Res sn) = getScopeNamespace sn == namespaceRDF && - T.head loc == '_' && - T.all isDigit (T.tail loc) - where - loc = getScopeLocal sn +isMemberProp (Res sn) = + getScopeNamespace sn == namespaceRDF && + case T.uncons (getScopeLocal sn) of + Just ('_', t) -> T.all isDigit t + _ -> False isMemberProp _ = False -- |Test if supplied labal is a blank node @@ -1084,12 +1085,16 @@ toRDFGraph :: [RDFTriple] -> RDFGraph -- toRDFGraph arcs = emptyRDFGraph { statements = arcs } toRDFGraph arcs = - let lbls = concatMap (\(Arc s p o) -> [s,p,o]) arcs - ns1 = map (getScopeNamespace . getScopedName) (filter isUri lbls) - ns2 = map (getScopeNamespace . getDataType) (filter isTypedLiteral lbls) - getDataType (Lit _ (Just dt)) = dt - getDataType _ = nullScopedName -- should not happen - nsmap = foldl' mapAddIfNew emptyNamespaceMap (ns1++ns2) + let lbls = concatMap arcLabels arcs + + getNS (Res s) = Just s + getNS (Lit _ (Just tn)) | not (isLang tn) = Just tn + | otherwise = Nothing + getNS _ = Nothing + + ns = mapMaybe (fmap getScopeNamespace . getNS) lbls + nsmap = foldl' mapAddIfNew emptyNamespaceMap ns + in mempty { namespaces = nsmap, statements = arcs } -- |Create a new, empty RDF graph. diff --git a/Swish/RDF/RDFParser.hs b/Swish/RDF/RDFParser.hs --- a/Swish/RDF/RDFParser.hs +++ b/Swish/RDF/RDFParser.hs @@ -30,6 +30,7 @@ , string , stringT , symbol + , isymbol , lexeme , notFollowedBy , whiteSpace @@ -206,6 +207,9 @@ symbol :: String -> Parser s String symbol = lexeme . string + +isymbol :: String -> Parser s () +isymbol = ignore . symbol lexeme :: Parser s a -> Parser s a lexeme p = p <* whiteSpace diff --git a/Swish/RDF/SwishCommands.hs b/Swish/RDF/SwishCommands.hs --- a/Swish/RDF/SwishCommands.hs +++ b/Swish/RDF/SwishCommands.hs @@ -50,9 +50,11 @@ import Swish.RDF.RDFGraph ( RDFGraph, merge ) +import qualified Swish.RDF.TurtleFormatter as TTLF import qualified Swish.RDF.N3Formatter as N3F import qualified Swish.RDF.NTFormatter as NTF +import Swish.RDF.TurtleParser (parseTurtle) import Swish.RDF.N3Parser (parseN3) import Swish.RDF.NTParser (parseNT) import Swish.RDF.RDFParser (appendURIs) @@ -273,6 +275,7 @@ case fmt of N3 -> writeOut N3F.formatGraphAsLazyText NT -> writeOut NTF.formatGraphAsLazyText + Turtle -> writeOut TTLF.formatGraphAsLazyText -- _ -> swishError ("Unsupported file format: "++show fmt) SwishArgumentError ------------------------------------------------------------ @@ -348,6 +351,7 @@ Right res -> return $ Just res case fmt of + Turtle -> readIn (`parseTurtle` Just (getQNameURI buri)) N3 -> readIn (`parseN3` Just buri) NT -> readIn parseNT {- diff --git a/Swish/RDF/SwishMain.hs b/Swish/RDF/SwishMain.hs --- a/Swish/RDF/SwishMain.hs +++ b/Swish/RDF/SwishMain.hs @@ -25,8 +25,6 @@ -- -- * Add RDF/XML input and output -- --- * Add Turtle and related formats for input and output --- module Swish.RDF.SwishMain ( SwishStatus(..), SwishAction, @@ -89,6 +87,7 @@ , "-v display Swish version and quit." , "-q do not display Swish version on start up." , "-nt use Ntriples format for subsequent input and output." + , "-ttl use Turtle format for subsequent input and output." , "-n3 use Notation3 format for subsequent input and output (default)" , "-i[=file] read file in selected format into the graph workspace," , " replacing any existing graph." @@ -179,6 +178,7 @@ wrap f = Right $ SA $ f marg in case nam of + "-ttl" -> wrap $ swishFormat Turtle "-nt" -> wrap $ swishFormat NT "-n3" -> wrap $ swishFormat N3 "-i" -> wrap swishInput diff --git a/Swish/RDF/SwishMonad.hs b/Swish/RDF/SwishMonad.hs --- a/Swish/RDF/SwishMonad.hs +++ b/Swish/RDF/SwishMonad.hs @@ -80,13 +80,15 @@ The supported input and output formats. -} data SwishFormat = - N3 -- ^ N3 format - | NT -- ^ NTriples format + Turtle -- ^ Turtle format + | N3 -- ^ N3 format + | NT -- ^ NTriples format deriving Eq instance Show SwishFormat where show N3 = "N3" show NT = "Ntriples" + show Turtle = "Turtle" -- show RDF = "RDF/XML" -- | The State for a Swish \"program\". diff --git a/Swish/RDF/SwishScript.hs b/Swish/RDF/SwishScript.hs --- a/Swish/RDF/SwishScript.hs +++ b/Swish/RDF/SwishScript.hs @@ -890,7 +890,7 @@ ; return $ Right dat } fromUri = fromFile - fromFile uri | uriScheme uri == "file:" = Right `fmap` (lift $ LIO.readFile $ uriPath uri) + fromFile uri | uriScheme uri == "file:" = Right `fmap` lift (LIO.readFile $ uriPath uri) | otherwise = error $ "Unsupported file name for read: " ++ show uri -- Temporary implementation: just write local file diff --git a/Swish/RDF/TurtleFormatter.hs b/Swish/RDF/TurtleFormatter.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/TurtleFormatter.hs @@ -0,0 +1,885 @@ +{-# LANGUAGE OverloadedStrings #-} + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : TurtleFormatter +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Turtle formatter (see [1]) +-- for an RDFGraph value. +-- +-- REFERENCES: +-- +-- 1 +-- Turtle, Terse RDF Triple Language +-- W3C Working Draft 09 August 2011 () +-- +-------------------------------------------------------------------------------- + +{- +TODO: + +The code used to determine whether a blank node can be written +using the "[]" short form could probably take advantage of the +GraphPartition module. + +-} + +module Swish.RDF.TurtleFormatter + ( NodeGenLookupMap + , formatGraphAsText + , formatGraphAsLazyText + , formatGraphAsBuilder + , formatGraphIndent + , formatGraphDiag + ) +where + +import Swish.RDF.RDFGraph ( + RDFGraph, RDFLabel(..) + , NamespaceMap, RevNamespaceMap + -- emptyNamespaceMap, + -- FormulaMap, emptyFormulaMap, + , getArcs + , labels + -- , setNamespaces + , getNamespaces, + -- getFormulae, + emptyRDFGraph + , quote + , quoteT + , resRdfFirst, resRdfRest, resRdfNil + ) + +import Swish.RDF.Vocabulary ( + isLang + , langTag + , rdfType + , rdfNil + , xsdBoolean, xsdDecimal, xsdInteger, xsdDouble + ) + +import Swish.RDF.GraphClass (Arc(..)) + +import Swish.Utils.LookupMap + ( LookupEntryClass(..) + , LookupMap, emptyLookupMap, reverseLookupMap + , listLookupMap + , mapFind, mapFindMaybe, mapAdd + -- , mapDelete + , mapMerge + ) + +import Swish.Utils.Namespace (ScopedName, getScopeLocal, getScopeURI) + +import Data.Char (isDigit) + +import Data.List (foldl', delete, groupBy, partition, sort, intersperse) + +import Data.Monoid (Monoid(..)) +import Control.Monad (liftM, when) +import Control.Monad.State (State, modify, get, put, runState) + +-- it strikes me that using Lazy Text here is likely to be +-- wrong; however I have done no profiling to back this +-- assumption up! + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import qualified Data.Text.Lazy.Builder as B + +-- temporary conversion +quoteB :: Bool -> String -> B.Builder +quoteB f v = B.fromString $ quote f v + +---------------------------------------------------------------------- +-- Graph formatting state monad +---------------------------------------------------------------------- +-- +-- The graph to be formatted is carried as part of the formatting +-- state, so that decisions about what needs to be formatted can +-- themselves be based upon and reflected in the state (e.g. if a +-- decision is made to include a blank node inline, it can be removed +-- from the graph state that remains to be formatted). + +type SubjTree lb = [(lb,PredTree lb)] +type PredTree lb = [(lb,[lb])] + +data TurtleFormatterState = TFS + { indent :: B.Builder + , lineBreak :: Bool + , graph :: RDFGraph + , subjs :: SubjTree RDFLabel + , props :: PredTree RDFLabel -- for last subject selected + , objs :: [RDFLabel] -- for last property selected + -- , formAvail :: FormulaMap RDFLabel + -- , formQueue :: [(RDFLabel,RDFGraph)] + , nodeGenSt :: NodeGenState + , bNodesCheck :: [RDFLabel] -- these bNodes are not to be converted to '[..]' format + , traceBuf :: [String] + } + +type Formatter a = State TurtleFormatterState a + +emptyTFS :: NodeGenState -> TurtleFormatterState +emptyTFS ngs = TFS + { indent = "\n" + , lineBreak = False + , graph = emptyRDFGraph + , subjs = [] + , props = [] + , objs = [] + -- , formAvail = emptyFormulaMap + -- , formQueue = [] + , nodeGenSt = ngs + , bNodesCheck = [] + , traceBuf = [] + } + +-- | Node name generation state information that carries through +-- and is updated by nested formulae +type NodeGenLookupMap = LookupMap (RDFLabel,Int) + +data NodeGenState = Ngs + { prefixes :: NamespaceMap + , nodeMap :: NodeGenLookupMap + , nodeGen :: Int + } + +emptyNgs :: NodeGenState +emptyNgs = Ngs + { prefixes = emptyLookupMap + , nodeMap = emptyLookupMap + , nodeGen = 0 + } + +-- simple context for label creation +-- (may be a temporary solution to the problem +-- of label creation) +-- +data LabelContext = SubjContext | PredContext | ObjContext + deriving (Eq, Show) + +getIndent :: Formatter B.Builder +getIndent = indent `liftM` get + +setIndent :: B.Builder -> Formatter () +setIndent ind = modify $ \st -> st { indent = ind } + +getLineBreak :: Formatter Bool +getLineBreak = lineBreak `liftM` get + +setLineBreak :: Bool -> Formatter () +setLineBreak brk = modify $ \st -> st { lineBreak = brk } + +getNgs :: Formatter NodeGenState +getNgs = nodeGenSt `liftM` get + +setNgs :: NodeGenState -> Formatter () +setNgs ngs = modify $ \st -> st { nodeGenSt = ngs } + +getPrefixes :: Formatter NamespaceMap +getPrefixes = prefixes `liftM` getNgs + +getSubjs :: Formatter (SubjTree RDFLabel) +getSubjs = subjs `liftM` get + +setSubjs :: SubjTree RDFLabel -> Formatter () +setSubjs sl = modify $ \st -> st { subjs = sl } + +getProps :: Formatter (PredTree RDFLabel) +getProps = props `liftM` get + +setProps :: PredTree RDFLabel -> Formatter () +setProps ps = modify $ \st -> st { props = ps } + +{- +getObjs :: Formatter ([RDFLabel]) +getObjs = objs `liftM` get + +setObjs :: [RDFLabel] -> Formatter () +setObjs os = do + st <- get + put $ st { objs = os } +-} + +getBnodesCheck :: Formatter [RDFLabel] +getBnodesCheck = bNodesCheck `liftM` get + +{- +addTrace :: String -> Formatter () +addTrace tr = do + st <- get + put $ st { traceBuf = tr : traceBuf st } +-} + +{- +queueFormula :: RDFLabel -> Formatter () +queueFormula fn = do + st <- get + let fa = formAvail st + newState fv = st { + formAvail = mapDelete fa fn, + formQueue = (fn,fv) : formQueue st + } + case mapFindMaybe fn fa of + Nothing -> return () + Just v -> put (newState v) >> return () +-} + +{- +Return the graph associated with the label and delete it +from the store, if there is an association, otherwise +return Nothing. + +extractFormula :: RDFLabel -> Formatter (Maybe RDFGraph) +extractFormula fn = do + st <- get + let fa = formAvail st + newState = st { formAvail=mapDelete fa fn } + case mapFindMaybe fn fa of + Nothing -> return Nothing + Just fv -> put newState >> return (Just fv) + +-} + +{- +moreFormulae :: Formatter Bool +moreFormulae = do + st <- get + return $ not $ null (formQueue st) + +nextFormula :: Formatter (RDFLabel,RDFGraph) +nextFormula = do + st <- get + let (nf : fq) = formQueue st + put $ st { formQueue = fq } + return nf + +-} + +-- list has a length of 1 +len1 :: [a] -> Bool +len1 (_:[]) = True +len1 _ = False + +{-| +Given a set of statements and a label, return the details of the +RDF collection referred to by label, or Nothing. + +For label to be considered as representing a collection we require the +following conditions to hold (this is only to support the +serialisation using the '(..)' syntax and does not make any statement +about semantics of the statements with regard to RDF Collections): + + - there must be one rdf_first and one rdfRest statement + - there must be no other predicates for the label + +-} +getCollection :: + SubjTree RDFLabel -- ^ statements organized by subject + -> RDFLabel -- ^ does this label represent a list? + -> Maybe (SubjTree RDFLabel, [RDFLabel], [RDFLabel]) + -- ^ the statements with the elements removed; the + -- content elements of the collection (the objects of the rdf:first + -- predicate) and the nodes that represent the spine of the + -- collection (in reverse order, unlike the actual contents which are in + -- order). +getCollection subjList lbl = go subjList lbl ([],[]) + where + go sl l (cs,ss) | l == resRdfNil = Just (sl, reverse cs, ss) + | otherwise = do + (pList1, sl') <- removeItem sl l + (pFirst, pList2) <- removeItem pList1 resRdfFirst + (pNext, pList3) <- removeItem pList2 resRdfRest + + -- QUS: could I include these checks implicitly in the pattern matches above? + -- ie instrad of (pFirst, pos1) <- .. + -- have ([content], pos1) <- ... + -- ? + if and [len1 pFirst, len1 pNext, null pList3] + then go sl' (head pNext) (head pFirst : cs, l : ss) + else Nothing + +{- +TODO: + +Should we change the preds/objs entries as well? + +-} +extractList :: LabelContext -> RDFLabel -> Formatter (Maybe [RDFLabel]) +extractList lctxt ln = do + osubjs <- getSubjs + oprops <- getProps + let mlst = getCollection osubjs' ln + + -- we only want to send in rdf:first/rdf:rest here + fprops = filter ((`elem` [resRdfFirst, resRdfRest]) . fst) oprops + + osubjs' = + case lctxt of + SubjContext -> (ln, fprops) : osubjs + _ -> osubjs + + -- tr = "extractList " ++ show ln ++ " (" ++ show lctxt ++ ")\n -> osubjs= " ++ show osubjs ++ "\n -> opreds= " ++ show oprops ++ "\n -> mlst= " ++ show mlst ++ "\n" + -- addTrace tr + case mlst of + -- sl is guaranteed to be free of (ln,fprops) here if lctxt is SubjContext + Just (sl,ls,_) -> do + setSubjs sl + when (lctxt == SubjContext) $ setProps $ filter ((`notElem` [resRdfFirst, resRdfRest]) . fst) oprops + return (Just ls) + + Nothing -> return Nothing + +{-| +Removes the first occurrence of the item from the +association list, returning it's contents and the rest +of the list, if it exists. +-} +removeItem :: (Eq a) => [(a,b)] -> a -> Maybe (b, [(a,b)]) +removeItem os x = + let (as, bs) = break (\a -> fst a == x) os + in case bs of + ((_,b):bbs) -> Just (b, as ++ bbs) + [] -> Nothing + +---------------------------------------------------------------------- +-- Define a top-level formatter function: +---------------------------------------------------------------------- + +formatGraphAsText :: RDFGraph -> T.Text +formatGraphAsText = L.toStrict . formatGraphAsLazyText + +formatGraphAsLazyText :: RDFGraph -> L.Text +formatGraphAsLazyText = B.toLazyText . formatGraphAsBuilder + +formatGraphAsBuilder :: RDFGraph -> B.Builder +formatGraphAsBuilder = formatGraphIndent "\n" True + +formatGraphIndent :: B.Builder -> Bool -> RDFGraph -> B.Builder +formatGraphIndent indnt flag gr = + let (res, _, _, _) = formatGraphDiag indnt flag gr + in res + +-- | Format graph and return additional information +formatGraphDiag :: + B.Builder -- ^ indentation + -> Bool -- ^ are prefixes to be generated? + -> RDFGraph + -> (B.Builder, NodeGenLookupMap, Int, [String]) +formatGraphDiag indnt flag gr = + let fg = formatGraph indnt " .\n" False flag gr + ngs = emptyNgs { + prefixes = emptyLookupMap, + nodeGen = findMaxBnode gr + } + + (out, fgs) = runState fg (emptyTFS ngs) + ogs = nodeGenSt fgs + + in (out, nodeMap ogs, nodeGen ogs, traceBuf fgs) + +---------------------------------------------------------------------- +-- Formatting as a monad-based computation +---------------------------------------------------------------------- + +formatGraph :: + B.Builder -- indentation string + -> B.Builder -- text to be placed after final statement + -> Bool -- True if a line break is to be inserted at the start + -> Bool -- True if prefix strings are to be generated + -> RDFGraph -- graph to convert + -> Formatter B.Builder +formatGraph ind end dobreak dopref gr = do + setIndent ind + setLineBreak dobreak + setGraph gr + + fp <- if dopref + then formatPrefixes (getNamespaces gr) + else return mempty + more <- moreSubjects + if more + then do + fr <- formatSubjects + return $ mconcat [fp, fr, end] + else return fp + +formatPrefixes :: NamespaceMap -> Formatter B.Builder +formatPrefixes pmap = do + let mls = map (pref . keyVal) (listLookupMap pmap) + ls <- sequence mls + return $ mconcat ls + where + pref (Just p,u) = nextLine $ mconcat ["@prefix ", B.fromText p, ": <", quoteB True (show u), "> ."] + pref (_,u) = nextLine $ mconcat ["@prefix : <", quoteB True (show u), "> ."] + +{- +NOTE: +I expect there to be confusion below where I need to +convert from Text to Builder +-} + +formatSubjects :: Formatter B.Builder +formatSubjects = do + sb <- nextSubject + sbstr <- formatLabel SubjContext sb + + flagP <- moreProperties + if flagP + then do + prstr <- formatProperties sb sbstr + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [prstr, " .", fr] + else return prstr + + else do + txt <- nextLine sbstr + + flagS <- moreSubjects + if flagS + then do + fr <- formatSubjects + return $ mconcat [txt, " .", fr] + else return txt + +{- +TODO: now we are throwing a Builder around it is awkward to +get the length of the text to calculate the indentation + +So + + a) change the indentation scheme + b) pass around text instead of builder + +mkIndent :: L.Text -> L.Text +mkIndent inVal = L.replicate (L.length inVal) " " +-} + +hackIndent :: B.Builder +hackIndent = " " + +formatProperties :: RDFLabel -> B.Builder -> Formatter B.Builder +formatProperties sb sbstr = do + pr <- nextProperty sb + prstr <- formatLabel PredContext pr + obstr <- formatObjects sb pr $ mconcat [sbstr, " ", prstr] + more <- moreProperties + let sbindent = hackIndent -- mkIndent sbstr + if more + then do + fr <- formatProperties sb sbindent + nl <- nextLine $ obstr `mappend` " ;" + return $ nl `mappend` fr + else nextLine obstr + +formatObjects :: RDFLabel -> RDFLabel -> B.Builder -> Formatter B.Builder +formatObjects sb pr prstr = do + ob <- nextObject sb pr + obstr <- formatLabel ObjContext ob + more <- moreObjects + if more + then do + let prindent = hackIndent -- mkIndent prstr + fr <- formatObjects sb pr prindent + nl <- nextLine $ mconcat [prstr, " ", obstr, ","] + return $ nl `mappend` fr + else return $ mconcat [prstr, " ", obstr] + +{- +Add a list inline. We are given the labels that constitute +the list, in order, so just need to display them surrounded +by (). +-} +insertList :: [RDFLabel] -> Formatter B.Builder +insertList [] = return "()" -- not convinced this can happen +insertList xs = do + ls <- mapM (formatLabel ObjContext) xs + return $ mconcat ("( " : intersperse " " ls) `mappend` " )" + +{- +Add a blank node inline. +-} + +insertBnode :: LabelContext -> RDFLabel -> Formatter B.Builder +insertBnode SubjContext lbl = do + -- a safety check + flag <- moreProperties + if flag + then do + txt <- (`mappend` "\n") `liftM` formatProperties lbl "" + return $ mconcat ["[] ", txt] + else error $ "Internal error: expected properties with label: " ++ show lbl + +insertBnode _ lbl = do + ost <- get + let osubjs = subjs ost + oprops = props ost + oobjs = objs ost + + (bsubj, rsubjs) = partition ((== lbl) . fst) osubjs + + rprops = case bsubj of + [(_,rs)] -> rs + _ -> [] + + -- we essentially want to create a new subgraph + -- for this node but it's not as simple as that since + -- we could have something like + -- :a :b [ :foo [ :bar "xx" ] ] + -- so we still need to carry around the whole graph + -- + nst = ost { subjs = rsubjs, + props = rprops, + objs = [] + } + + put nst + flag <- moreProperties + txt <- if flag + then (`mappend` "\n") `liftM` formatProperties lbl "" + else return "" + + -- TODO: how do we restore the original set up? + -- I can't believe the following is sufficient + -- + nst' <- get + let slist = map fst $ subjs nst' + nsubjs = filter (\(l,_) -> l `elem` slist) osubjs + + put $ nst' { subjs = nsubjs, + props = oprops, + objs = oobjs + } + + -- TODO: handle indentation? + return $ mconcat ["[", txt, "]"] + +---------------------------------------------------------------------- +-- Formatting helpers +---------------------------------------------------------------------- + +setGraph :: RDFGraph -> Formatter () +setGraph gr = do + st <- get + + let ngs0 = nodeGenSt st + pre' = mapMerge (prefixes ngs0) (getNamespaces gr) + ngs' = ngs0 { prefixes = pre' } + arcs = sortArcs $ getArcs gr + nst = st { graph = gr + , subjs = arcTree arcs + , props = [] + , objs = [] + -- , formAvail = getFormulae gr + , nodeGenSt = ngs' + , bNodesCheck = countBnodes arcs + } + + put nst + +hasMore :: (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 + st <- get + + let sb:sbs = subjs st + nst = st { subjs = sbs + , props = snd sb + , objs = [] + } + + put nst + return $ fst sb + +nextProperty :: RDFLabel -> Formatter RDFLabel +nextProperty _ = do + st <- get + + let pr:prs = props st + nst = st { props = prs + , objs = snd pr + } + + put nst + return $ fst pr + +nextObject :: RDFLabel -> RDFLabel -> Formatter RDFLabel +nextObject _ _ = do + st <- get + + let ob:obs = objs st + nst = st { objs = obs } + + put nst + return ob + +nextLine :: B.Builder -> Formatter B.Builder +nextLine str = do + ind <- getIndent + brk <- getLineBreak + if brk + then return $ ind `mappend` str + else do + -- After first line, always insert line break + setLineBreak True + return str + +-- Format a label +-- Most labels are simply displayed as provided, but there are a +-- number of wrinkles to take care of here: +-- (a) blank nodes automatically allocated on input, with node +-- identifiers of the form of a digit string nnn. These are +-- not syntactically valid, and are reassigned node identifiers +-- of the form _nnn, where nnn is chosen so that is does not +-- clash with any other identifier in the graph. +-- (b) URI nodes: if possible, replace URI with qname, +-- else display as +-- (c) formula nodes (containing graphs). +-- (d) use the "special-case" formats for integer/float/double +-- literals. +-- +-- [[[TODO:]]] +-- (d) generate multi-line literals when appropriate +-- +-- This is being updated to produce inline formula, lists and +-- blank nodes. The code is not efficient. +-- +-- +-- Note: There is a lot less customisation possible in Turtle than N3. +-- + +formatLabel :: LabelContext -> RDFLabel -> Formatter B.Builder + +{- +The "[..]" conversion is done last, after "()" and "{}" checks. +-} +formatLabel lctxt lab@(Blank (_:_)) = do + mlst <- extractList lctxt lab + case mlst of + Just lst -> insertList lst + Nothing -> do + -- NOTE: unlike N3 we do not properly handle "formula"/named graphs + -- also we only expand out bnodes into [...] format when it's a object. + -- although we need to handle [] for the subject. + nb1 <- getBnodesCheck + if lctxt /= PredContext && lab `notElem` nb1 + then insertBnode lctxt lab + else formatNodeId lab + +-- formatLabel _ lab@(Res sn) = +formatLabel ctxt (Res sn) + | ctxt == PredContext && sn == rdfType = return "a" + | ctxt == ObjContext && sn == rdfNil = return "()" + | otherwise = do + pr <- getPrefixes + let nsuri = getScopeURI sn + local = getScopeLocal sn + premap = reverseLookupMap pr :: RevNamespaceMap + prefix = mapFindMaybe nsuri premap + + name = case prefix of + Just (Just p) -> B.fromText $ quoteT True $ mconcat [p, ":", local] -- TODO: what are quoting rules for QNames + _ -> mconcat ["<", quoteB True (show nsuri ++ T.unpack local), ">"] + + return name + +-- The canonical notation for xsd:double in XSD, with an upper-case E, +-- does not match the syntax used in N3, so we need to convert here. +-- Rather than converting back to a Double and then displaying that +-- we just convert E to e for now. +-- +formatLabel _ (Lit lit (Just dtype)) + | dtype == xsdDouble = return $ B.fromText $ T.toLower lit + | dtype `elem` [xsdBoolean, xsdDecimal, xsdInteger] = return $ B.fromText lit + | otherwise = return $ quoteText lit `mappend` formatAnnotation dtype +formatLabel _ (Lit lit Nothing) = return $ quoteText lit + +formatLabel _ lab = return $ B.fromString $ show lab + +-- the annotation for a literal (ie type or language) +formatAnnotation :: ScopedName -> B.Builder +formatAnnotation a | isLang a = "@" `mappend` B.fromText (langTag a) + | otherwise = "^^" `mappend` showScopedName a + +{- +We have to decide whether to use " or """ to quote +the string. + +There is also no need to restrict the string to the +ASCII character set; this could be an option but we +can also leave Unicode as is (or at least convert to UTF-8). + +If we use """ to surround the string then we protect the +last character if it is a " (assuming it isn't protected). +-} + +quoteText :: T.Text -> B.Builder +quoteText txt = + let st = T.unpack txt -- TODO: fix + qst = quoteB (n==1) st + n = if '\n' `elem` st || '"' `elem` st then 3 else 1 + qch = B.fromString (replicate n '"') + in mconcat [qch, qst, qch] + +formatNodeId :: RDFLabel -> Formatter B.Builder +formatNodeId lab@(Blank (lnc:_)) = + if isDigit lnc then mapBlankNode lab else return $ B.fromString $ show lab +formatNodeId other = error $ "formatNodeId not expecting a " ++ show other -- to shut up -Wall + +mapBlankNode :: RDFLabel -> Formatter B.Builder +mapBlankNode lab = do + ngs <- getNgs + let cmap = nodeMap ngs + cval = nodeGen ngs + nv <- case mapFind 0 lab cmap of + 0 -> do + let nval = succ cval + nmap = mapAdd cmap (lab, nval) + setNgs $ ngs { nodeGen = nval, nodeMap = nmap } + return nval + + n -> return n + + -- TODO: is this what we want? + return $ "_:swish" `mappend` B.fromString (show nv) + +-- TODO: need to be a bit more clever with this than we did in NTriples +-- not sure the following counts as clever enough ... +-- +showScopedName :: ScopedName -> B.Builder +{- +showScopedName (ScopedName n l) = + let uri = nsURI n ++ l + in quote uri +-} +showScopedName = quoteB True . show + +---------------------------------------------------------------------- +-- Graph-related helper functions +---------------------------------------------------------------------- + +newtype SortedArcs lb = SA [Arc lb] + +sortArcs :: (Ord lb) => [Arc lb] -> SortedArcs lb +sortArcs = SA . sort + +-- Rearrange a list of arcs into a tree of pairs which group together +-- all statements for a single subject, and similarly for multiple +-- objects of a common predicate. +-- +arcTree :: (Eq lb) => SortedArcs lb -> SubjTree lb +arcTree (SA as) = commonFstEq (commonFstEq id) $ map spopair as + where + spopair (Arc s p o) = (s,(p,o)) + +{- +arcTree as = map spopair $ sort as + where + spopair (Arc s p o) = (s,[(p,[o])]) +-} + +-- Rearrange a list of pairs so that multiple occurrences of the first +-- are commoned up, and the supplied function is applied to each sublist +-- with common first elements to obtain the corresponding second value +commonFstEq :: (Eq a) => ( [b] -> c ) -> [(a,b)] -> [(a,c)] +commonFstEq f ps = + [ (fst $ head sps,f $ map snd sps) | sps <- groupBy fstEq ps ] + where + fstEq (f1,_) (f2,_) = f1 == f2 + +findMaxBnode :: RDFGraph -> Int +findMaxBnode = maximum . map getAutoBnodeIndex . labels + +getAutoBnodeIndex :: RDFLabel -> Int +getAutoBnodeIndex (Blank ('_':lns)) = res where + -- cf. prelude definition of read s ... + res = case [x | (x,t) <- reads lns, ("","") <- lex t] of + [x] -> x + _ -> 0 +getAutoBnodeIndex _ = 0 + +{- +Find all blank nodes that occur + - any number of times as a subject + - 0 or 1 times as an object + +Such nodes can be output using the "[..]" syntax. To make it simpler +to check we actually store those nodes that can not be expanded. + +Note that we do not try and expand any bNode that is used in +a predicate position. + +Should probably be using the SubjTree RDFLabel structure but this +is easier for now. + +-} + +countBnodes :: SortedArcs RDFLabel -> [RDFLabel] +countBnodes (SA as) = snd (foldl' ctr ([],[]) as) + where + -- first element of tuple are those blank nodes only seen once, + -- second element those blank nodes seen multiple times + -- + inc b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (l:b1s, bms) + inc b _ = b + + -- if the bNode appears as a predicate we instantly add it to the + -- list of nodes not to expand, even if only used once + incP b@(b1s,bms) l@(Blank _) | l `elem` bms = b + | l `elem` b1s = (delete l b1s, l:bms) + | otherwise = (b1s, l:bms) + incP b _ = b + + ctr orig (Arc _ p o) = inc (incP orig p) o + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/Swish/RDF/TurtleParser.hs b/Swish/RDF/TurtleParser.hs new file mode 100644 --- /dev/null +++ b/Swish/RDF/TurtleParser.hs @@ -0,0 +1,1072 @@ +{-# LANGUAGE OverloadedStrings #-} -- only used in 'fromMaybe "" mbase' line of parseN3 + +-------------------------------------------------------------------------------- +-- See end of this file for licence information. +-------------------------------------------------------------------------------- +-- | +-- Module : TurtleParser +-- Copyright : (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- License : GPL V2 +-- +-- Maintainer : Douglas Burke +-- Stability : experimental +-- Portability : OverloadedStrings +-- +-- This Module implements a Turtle parser (see [1]), returning a +-- new 'RDFGraph' consisting of triples and namespace information parsed from +-- the supplied input string, or an error indication. +-- +-- REFERENCES: +-- +-- 1 +-- Turtle, Terse RDF Triple Language +-- W3C Working Draft 09 August 2011 () +-- +-- Notes: +-- +-- At present there is a lot of overlap with the N3 Parser. +-- +-------------------------------------------------------------------------------- + +module Swish.RDF.TurtleParser + ( ParseResult + , parseTurtle + , parseTurtlefromText + {- + , parseAnyfromText + , parseTextFromText, parseAltFromText + , parseNameFromText -- , parsePrefixFromText + , parseAbsURIrefFromText, parseLexURIrefFromText, parseURIref2FromText + -} + + {- + -- * Exports for parsers that embed Turtle in a bigger syntax + , TurtleParser, TurtleState(..), SpecialMap + + , getPrefix -- a combination of the old defaultPrefix and namedPrefix productions + , n3symbol -- replacement for uriRef2 -- TODO: check this is semantically correct + , quickVariable -- was varid + , lexUriRef + , document, subgraph + , newBlankNode + -} + ) +where + +import Swish.RDF.RDFGraph + ( RDFGraph, RDFLabel(..) + , ToRDFLabel(..) + , NamespaceMap + , addArc + , setNamespaces + , emptyRDFGraph + ) + +import Swish.RDF.GraphClass (arc) + +import Swish.Utils.LookupMap + ( LookupMap(..) + , LookupEntryClass(..) + , mapFindMaybe, mapReplaceOrAdd, mapAdd, mapReplace ) + +import Swish.Utils.Namespace + ( Namespace, makeNamespace + , ScopedName + , getScopeNamespace + , getScopedNameURI + , getScopeNamespace + , makeURIScopedName + , makeNSScopedName + ) + +import Swish.RDF.Vocabulary + ( langName + , rdfType + , rdfFirst, rdfRest, rdfNil + , xsdBoolean, xsdInteger, xsdDecimal, xsdDouble + , defaultBase + ) + +import Swish.RDF.RDFParser + ( ParseResult + -- , prefixTable + , ignore + -- , notFollowedBy + -- , endBy + -- , sepEndBy + -- , manyTill + , noneOf + , char + , ichar + , string + , stringT + , symbol + , isymbol + , lexeme + , whiteSpace + , mkTypedLit + , hex4 + , hex8 + , appendURIs + ) + +import Control.Applicative +import Control.Monad (foldM) + +import Network.URI (URI(..), parseURIReference) + +import Data.Char (ord) +import Data.Maybe (fromMaybe, fromJust) + +import qualified Data.Text as T +import qualified Data.Text.Lazy as L +import Text.ParserCombinators.Poly.StateText + +---------------------------------------------------------------------- +-- Define parser state and helper functions +---------------------------------------------------------------------- + +-- | Turtle parser state +data TurtleState = TurtleState + { graphState :: RDFGraph -- Graph under construction + , prefixUris :: NamespaceMap -- namespace prefix mapping table + , baseUri :: URI -- base URI + , nodeGen :: Int -- blank node id generator + } deriving Show + +-- | Functions to update TurtleState vector (use with stUpdate) + +setPrefix :: Maybe T.Text -> URI -> TurtleState -> TurtleState +setPrefix pre uri st = st { prefixUris=p' } + where + p' = mapReplaceOrAdd (makeNamespace pre uri) (prefixUris st) + +-- | Change the base +setBase :: URI -> TurtleState -> TurtleState +setBase buri st = st { baseUri = buri } + +-- Functions to access state: + +-- | Return the default prefix +getDefaultPrefix :: TurtleParser Namespace +getDefaultPrefix = do + s <- stGet + case getPrefixURI s Nothing of + Just uri -> return $ makeNamespace Nothing uri + _ -> failBad "No default prefix defined; how unexpected (probably a programming error)!" + +-- Map prefix to URI (naming needs a scrub here) +getPrefixURI :: TurtleState -> Maybe T.Text -> Maybe URI +getPrefixURI st pre = mapFindMaybe pre (prefixUris st) + +findPrefixNamespace :: Maybe L.Text -> TurtleParser Namespace +findPrefixNamespace (Just p) = findPrefix (L.toStrict p) +findPrefixNamespace Nothing = getDefaultPrefix + +-- Return function to update graph in Turtle parser state, +-- using the supplied function of a graph +-- +updateGraph :: (RDFGraph -> RDFGraph) -> TurtleState -> TurtleState +updateGraph f s = s { graphState = f (graphState s) } + +---------------------------------------------------------------------- +-- Define top-level parser function: +-- accepts a string and returns a graph or error +---------------------------------------------------------------------- + +type TurtleParser a = Parser TurtleState a + +-- | Parse as Turtle (with no real base URI). +-- +-- See 'parseTurtle' if you need to provide a base URI. +-- +parseTurtlefromText :: + L.Text -- ^ input in N3 format. + -> ParseResult +parseTurtlefromText = flip parseTurtle Nothing + +-- | Parse a string with an optional base URI. +-- +-- Unlike 'parseN3' we treat the base URI as a URI and not +-- a QName. +-- +parseTurtle :: + L.Text -- ^ input in N3 format. + -> Maybe URI -- ^ optional base URI + -> ParseResult +parseTurtle txt mbase = parseAnyfromText turtleDoc mbase txt + +hashURI :: URI +hashURI = fromJust $ parseURIReference "#" + +emptyState :: + Maybe URI -- ^ starting base for the graph + -> TurtleState +emptyState mbase = + let pmap = LookupMap [makeNamespace Nothing hashURI] + buri = fromMaybe (getScopedNameURI defaultBase) mbase + in TurtleState + { graphState = emptyRDFGraph + , prefixUris = pmap + , baseUri = buri + , nodeGen = 0 + } + +-- | Function to supply initial context and parse supplied term. +-- +parseAnyfromText :: TurtleParser a -- ^ parser to apply + -> Maybe URI -- ^ base URI of the input, or @Nothing@ to use default base value + -> L.Text -- ^ input to be parsed + -> Either String a +parseAnyfromText parser mbase input = + let (result, _, unparsed) = runParser parser (emptyState mbase) input + + -- TODO: work out how best to report error context. + + in case result of + Left emsg -> Left $ concat [emsg, "\nRemaining input:\n", L.unpack unparsed] + _ -> result + +newBlankNode :: TurtleParser RDFLabel +newBlankNode = do + n <- stQuery (succ . nodeGen) + stUpdate $ \s -> s { nodeGen = n } + return $ Blank (show n) + +{- +This has been made tricky by the attempt to remove the default list +of prefixes from the starting point of a parse and the subsequent +attempt to add every new namespace we come across to the parser state. + +So we add in the original default namespaces for testing, since +this routine is really for testing. + +addTestPrefixes :: TurtleParser () +addTestPrefixes = stUpdate $ \st -> st { prefixUris = LookupMap prefixTable } -- should append to existing map + +-} + +-- helper routines + +comma, semiColon , fullStop :: TurtleParser () +comma = isymbol "," +semiColon = isymbol ";" +fullStop = isymbol "." + +sQuot, dQuot, sQuot3, dQuot3 :: TurtleParser () +sQuot = ichar '\'' +dQuot = ichar '"' +sQuot3 = ignore $ string "'''" +dQuot3 = ignore $ string "\"\"\"" + +match :: (Ord a) => a -> [(a,a)] -> Bool +match v = any (\(l,h) -> v >= l && v <= h) + +-- a specialization of bracket +br :: String -> String -> TurtleParser a -> TurtleParser a +br lsym rsym = bracket (symbol lsym) (symbol rsym) + +-- this is a lot simpler than N3 +atWord :: T.Text -> TurtleParser () +atWord s = char '@' *> lexeme (stringT s) *> pure () + +{- +Add statement to graph in the parser state; there is a special case +for the special-case literals in the grammar since we need to ensure +the necessary namespaces (in other words xsd) are added to the +namespace store. +-} + +addStatement :: RDFLabel -> RDFLabel -> RDFLabel -> TurtleParser () +addStatement s p o@(Lit _ (Just dtype)) | dtype `elem` [xsdBoolean, xsdInteger, xsdDecimal, xsdDouble] = do + ost <- stGet + let stmt = arc s p o + oldp = prefixUris ost + ogs = graphState ost + newp = mapReplaceOrAdd (getScopeNamespace dtype) oldp + stUpdate $ \st -> st { prefixUris = newp, graphState = addArc stmt ogs } +addStatement s p o = stUpdate (updateGraph (addArc (arc s p o) )) + +isaz, isAZ, isaZ, is09, isaZ09 :: Char -> Bool +isaz c = c >= 'a' && c <= 'z' +isAZ c = c >= 'A' && c <= 'Z' +isaZ c = isaz c || isAZ c +is09 c = c >= '0' && c <= '9' +isaZ09 c = isaZ c || is09 c + +{- +Convert a string representing a double into canonical +XSD form. The input string is assumed to be syntactically +valid so we use read rather than reads. We use the String read +rather than Text one because of issues I have had in some tests +with the accuracy of the Text one. +-} +d2s :: L.Text -> RDFLabel +d2s = + let conv :: String -> Double + conv = read + in toRDFLabel . conv . L.unpack + +{- +Since operatorLabel can be used to add a label with an +unknown namespace, we need to ensure that the namespace +is added if not known. If the namespace prefix is already +in use then it is over-written (rather than add a new +prefix for the label). + +TODO: + - could we use the reverse lookupmap functionality to + find if the given namespace URI is in the namespace + list? If it is, use it's key otherwise do a + mapReplaceOrAdd for the input namespace. + +-} +operatorLabel :: ScopedName -> TurtleParser RDFLabel +operatorLabel snam = do + st <- stGet + let sns = getScopeNamespace snam + opmap = prefixUris st + pkey = entryKey sns + pval = entryVal sns + + rval = Res snam + + -- the lookup and the replacement could be fused + case mapFindMaybe pkey opmap of + Just val | val == pval -> return rval + | otherwise -> do + stUpdate $ \s -> s { prefixUris = mapReplace opmap sns } + return rval + + _ -> do + stUpdate $ \s -> s { prefixUris = mapAdd opmap sns } + return rval + +findPrefix :: T.Text -> TurtleParser Namespace +findPrefix pre = do + st <- stGet + case mapFindMaybe (Just pre) (prefixUris st) of + Just uri -> return $ makeNamespace (Just pre) uri + Nothing -> failBad $ "Undefined prefix '" ++ T.unpack pre ++ ":'." + +{- + +Syntax productions; the Turtle NBF grammar elements are from +http://www.w3.org/TR/turtle/turtle.bnf + +The element names are converted to match Haskell syntax +and idioms where possible: + + - camel Case rather than underscores and all upper case + + - upper-case identifiers prepended by _ after above form + +-} + +{- +[1] turtleDoc ::= (statement)* +-} +turtleDoc :: TurtleParser RDFGraph +turtleDoc = mkGr <$> (whiteSpace *> many statement *> eof *> stGet) + where + mkGr s = setNamespaces (prefixUris s) (graphState s) + +{- +[2] statement ::= directive "." + | triples "." +-} +statement :: TurtleParser () +statement = (directive <|> triples) *> fullStop + +{- +[3] directive ::= prefixID + | base +-} +directive :: TurtleParser () +directive = lexeme (prefixID <|> base) + +{- +[4] prefixID ::= PREFIX PNAME_NS IRI_REF +-} +prefixID :: TurtleParser () +prefixID = do + _prefix + p <- lexeme _pnameNS + u <- _iriRef + stUpdate (setPrefix (fmap L.toStrict p) u) + +{- +[5] base ::= BASE IRI_REF +-} +base :: TurtleParser () +base = _base >> _iriRef >>= stUpdate . setBase + +{- +[6] triples ::= subject predicateObjectList +-} + +triples :: TurtleParser () +triples = subject >>= predicateObjectList + +{- +[7] predicateObjectList ::= verb objectList ( ";" verb objectList )* (";")? +-} + +predicateObjectList :: RDFLabel -> TurtleParser () +predicateObjectList subj = + let term = verb >>= objectList subj + in sepBy1 term semiColon *> ignore (optional semiColon) + -- in sepBy1 (lexeme term) semiColon *> ignore (optional semiColon) + +{- +[8] objectList ::= object ( "," object )* +-} + +objectList :: RDFLabel -> RDFLabel -> TurtleParser () +objectList subj prd = sepBy1 object comma >>= mapM_ (addStatement subj prd) + +{- +[9] verb ::= predicate + | "a" +-} + +verb :: TurtleParser RDFLabel +verb = predicate <|> (lexeme (char 'a') *> operatorLabel rdfType) + +{- +[10] subject ::= IRIref + | blank +-} + +subject :: TurtleParser RDFLabel +subject = (Res <$> iriref) <|> blank + +{- +[11] predicate ::= IRIref +-} + +predicate :: TurtleParser RDFLabel +predicate = Res <$> iriref + +{- +[12] object ::= IRIref + | blank + | literal +-} + +object :: TurtleParser RDFLabel +object = (Res <$> iriref) <|> blank <|> literal + +{- +[13] literal ::= RDFLiteral + | NumericLiteral + | BooleanLiteral +-} + +literal :: TurtleParser RDFLabel +literal = lexeme $ rdfLiteral <|> numericLiteral <|> booleanLiteral + +{- +[14] blank ::= BlankNode + | blankNodePropertyList + | collection + +Since both BlankNode and blankNodePropertyList can match '[ ... ]' we pull +that out and treat this as + + blank ::= BLANK_NODE_LABEL + | "[" (predicateObjectList | WS*) "]" + | collection + +blank :: TurtleParser RDFLabel +blank = lexeme (blankNode <|> blankNodePropertyList <|> collection) + +-} + +blank :: TurtleParser RDFLabel +blank = lexeme (_blankNodeLabel + <|> + bracket (char '[') (char ']') handleBlankNode + <|> + collection + ) + +{- +[15] blankNodePropertyList ::= "[" predicateObjectList "]" + +We now match the brackets in the parent rule. + +blankNodePropertyList :: TurtleParser RDFLabel +blankNodePropertyList = do + bNode <- newBlankNode + -- br "[" "]" (predicateObjectList bNode) + bracket (satisfy (=='[')) + (satisfy (==']')) + (_manyws *> predicateObjectList bNode *> _manyws) + -- ignore (optional _manyws) -- TODO: this is a hack + return bNode + +-} + +handleBlankNode :: TurtleParser RDFLabel +handleBlankNode = do + bNode <- newBlankNode + _manyws + ignore $ optional $ predicateObjectList bNode + _manyws + return bNode + + +{- +[16] collection ::= "(" object* ")" +-} + +collection :: TurtleParser RDFLabel +collection = do + os <- br "(" ")" (many object) + eNode <- operatorLabel rdfNil + case os of + [] -> return eNode + + (x:xs) -> do + sNode <- newBlankNode + first <- operatorLabel rdfFirst + addStatement sNode first x + lNode <- foldM addElem sNode xs + rest <- operatorLabel rdfRest + addStatement lNode rest eNode + return sNode + + where + addElem prevNode curElem = do + bNode <- newBlankNode + first <- operatorLabel rdfFirst + rest <- operatorLabel rdfRest + addStatement prevNode rest bNode + addStatement bNode first curElem + return bNode + +{- +[17] ::= "@base" +-} + +_base :: TurtleParser () +_base = atWord "base" + +{- +[18] ::= "@prefix" +-} + +_prefix :: TurtleParser () +_prefix = atWord "prefix" + +{- +[19] ::= ( "\\u" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) + | ( "\\U" [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] + [0-9a-fA-F] [0-9a-fA-F] [0-9a-fA-F] ) + +-} + +_uchar :: TurtleParser Char +_uchar = char '\\' *> _uchar' + +_uchar' :: TurtleParser Char +_uchar' = (char 'u' *> hex4) <|> (char 'U' *> hex8) + +{- +[60s] RDFLiteral ::= String ( LANGTAG | ( "^^" IRIref ) )? +-} + +rdfLiteral :: TurtleParser RDFLabel +rdfLiteral = do + lbl <- turtleString + opt <- optional (_langTag <|> (string "^^" *> iriref)) + return $ Lit (L.toStrict lbl) opt + +{- +[61s] NumericLiteral ::= NumericLiteralUnsigned + | NumericLiteralPositive + | NumericLiteralNegative +-} + +numericLiteral :: TurtleParser RDFLabel +numericLiteral = numericLiteralNegative <|> numericLiteralPositive <|> numericLiteralUnsigned + +{- +[62s] NumericLiteralUnsigned ::= INTEGER + | DECIMAL + | DOUBLE +-} + +numericLiteralUnsigned :: TurtleParser RDFLabel +numericLiteralUnsigned = + d2s <$> _double + <|> + (mkTypedLit xsdDecimal . L.toStrict <$> _decimal) + <|> + (mkTypedLit xsdInteger . L.toStrict <$> _integer) + +{- +[63s] NumericLiteralPositive ::= INTEGER_POSITIVE + | DECIMAL_POSITIVE + | DOUBLE_POSITIVE +-} + +numericLiteralPositive :: TurtleParser RDFLabel +numericLiteralPositive = + d2s <$> _doublePositive + <|> + (mkTypedLit xsdDecimal . L.toStrict <$> _decimalPositive) + <|> + (mkTypedLit xsdInteger . L.toStrict <$> _integerPositive) + +{- +[64s] NumericLiteralNegative ::= INTEGER_NEGATIVE + | DECIMAL_NEGATIVE + | DOUBLE_NEGATIVE +-} + +numericLiteralNegative :: TurtleParser RDFLabel +numericLiteralNegative = + d2s <$> _doubleNegative + <|> + (mkTypedLit xsdDecimal . L.toStrict <$> _decimalNegative) + <|> + (mkTypedLit xsdInteger . L.toStrict <$> _integerNegative) + +{- +[65s] BooleanLiteral ::= "true" + | "false" +-} + +booleanLiteral :: TurtleParser RDFLabel +booleanLiteral = mkTypedLit xsdBoolean . T.pack <$> (string "true" <|> string "false") + +{- +[66s] String ::= STRING_LITERAL1 + | STRING_LITERAL2 + | STRING_LITERAL_LONG1 + | STRING_LITERAL_LONG2 +-} + +turtleString :: TurtleParser L.Text +turtleString = + lexeme ( + _stringLiteralLong1 <|> _stringLiteral1 <|> + _stringLiteralLong2 <|> _stringLiteral2) + +{- +[67s] IRIref ::= IRI_REF + | PrefixedName +-} + +iriref :: TurtleParser ScopedName +iriref = lexeme ((makeURIScopedName <$> _iriRef) <|> prefixedName) + +{- +[68s] PrefixedName ::= PNAME_LN + | PNAME_NS +-} + +prefixedName :: TurtleParser ScopedName +prefixedName = + _pnameLN <|> + flip makeNSScopedName T.empty <$> (_pnameNS >>= findPrefixNamespace) + +{- +[69s] BlankNode ::= BLANK_NODE_LABEL + | ANON + +blankNode :: TurtleParser RDFLabel +blankNode = lexeme (_blankNodeLabel <|> _anon) + +-} + +{- +[70s] ::= "<" ( [^<>\"{}|^`\\] - [#0000- ] | UCHAR )* ">" + +Read [#0000- ] as [#x00-#x20] from +http://lists.w3.org/Archives/Public/public-rdf-comments/2011Aug/0011.html + +Unlike N3, whitespace is significant within the surrounding <>. + +At present relying on Network.URI to define what characters are valid +in a URI. This is not necessarily ideal. +-} + +_iriRef :: TurtleParser URI +_iriRef = do + utxt <- bracket (char '<') (char '>') $ manySatisfy (/= '>') -- TODO: fix + let ustr = L.unpack utxt + case parseURIReference ustr of + Nothing -> fail $ "Unable to convert <" ++ ustr ++ "> to a URI" + Just uref -> do + s <- stGet + either fail return $ appendURIs (baseUri s) uref + +{- +[71s] ::= (PN_PREFIX)? ":" +-} + +_pnameNS :: TurtleParser (Maybe L.Text) +_pnameNS = optional _pnPrefix <* char ':' + +{- +[72s] ::= PNAME_NS PN_LOCAL +-} + +_pnameLN :: TurtleParser ScopedName +_pnameLN = makeNSScopedName + <$> (_pnameNS >>= findPrefixNamespace) + <*> fmap L.toStrict _pnLocal + +{- +[73s] ::= "_:" PN_LOCAL +-} + +_blankNodeLabel :: TurtleParser RDFLabel +_blankNodeLabel = (Blank . L.unpack) <$> (string "_:" *> _pnLocal) + +{- + +These are unused in the grammar. + +[74s] ::= "?" VARNAME +[75s] ::= "$" VARNAME +-} + +{- +[76s] ::= BASE + | PREFIX + | "@" [a-zA-Z]+ ( "-" [a-zA-Z0-9]+ )* + +I am ignoring the BASE and PREFIX lines here as they don't make sense to me. +-} + +_langTag :: TurtleParser ScopedName +_langTag = do + ichar '@' + h <- many1Satisfy isaZ + mt <- optional (L.cons <$> char '-' <*> many1Satisfy isaZ09) + return $ langName $ L.toStrict $ L.append h (fromMaybe L.empty mt) + +{- +[77s] ::= [0-9]+ +-} + +_integer :: TurtleParser L.Text +_integer = many1Satisfy is09 + +{- +[78s] ::= [0-9]+ "." [0-9]* + | "." [0-9]+ + +We try to produce a canonical form for the +numbers. +-} + +_decimal :: TurtleParser L.Text +_decimal = + let dpart = L.cons <$> char '.' <*> (fromMaybe "0" <$> optional _integer) + in + (L.append <$> _integer <*> dpart) + <|> + (L.append "0." <$> (char '.' *> _integer)) + +{- +[79s] ::= [0-9]+ "." [0-9]* EXPONENT + | "." ( [0-9] )+ EXPONENT + | ( [0-9] )+ EXPONENT + +Unlike _decimal, the canonical form is enforced +later on, although it could be done here. +-} + +_double :: TurtleParser L.Text +_double = + (L.append <$> _decimal <*> _exponent) + <|> + (L.append <$> _integer <*> _exponent) + +{- +[80s] ::= "+" INTEGER +[81s] ::= "+" DECIMAL +[82s] ::= "+" DOUBLE +-} + +_integerPositive, _decimalPositive, _doublePositive :: TurtleParser L.Text +_integerPositive = char '+' *> _integer +_decimalPositive = char '+' *> _decimal +_doublePositive = char '+' *> _double + +{- +[83s] ::= "-" INTEGER +[84s] ::= "-" DECIMAL +[85s] ::= "-" DOUBLE +-} + +_integerNegative, _decimalNegative, _doubleNegative :: TurtleParser L.Text +_integerNegative = L.cons <$> char '-' <*> _integer +_decimalNegative = L.cons <$> char '-' <*> _decimal +_doubleNegative = L.cons <$> char '-' <*> _double + +{- +[86s] ::= [eE] [+-]? [0-9]+ +-} + +_exponent :: TurtleParser L.Text +_exponent = do + ignore $ satisfy (`elem` "eE") + ms <- optional (satisfy (`elem` "+-")) + e <- _integer + case ms of + Just '-' -> return $ L.append "E-" e + _ -> return $ L.cons 'E' e + +{- +[87s] ::= "'" ( ( [^'\\\n\r] ) | ECHAR | UCHAR )* "'" +[88s] ::= '"' ( ( [^\"\\\n\r] ) | ECHAR | UCHAR )* '"' +[89s] ::= "'''" ( ( "'" | "''" )? ( [^'\\] | ECHAR | UCHAR ) )* "'''" +[90s] ::= '"""' ( ( '"' | '""' )? ( [^\"\\] | ECHAR | UCHAR ) )* '"""' +-} + +_stringLiteral1, _stringLiteral2 :: TurtleParser L.Text +_stringLiteral1 = _stringIt sQuot (_tChars "'\\\n\r") +_stringLiteral2 = _stringIt dQuot (_tChars "\"\\\n\r") + +_stringLiteralLong1, _stringLiteralLong2 :: TurtleParser L.Text +_stringLiteralLong1 = _stringItLong sQuot3 (_tCharsLong '\'' "'\\") +_stringLiteralLong2 = _stringItLong dQuot3 (_tCharsLong '"' "\"\\") + +_stringIt :: TurtleParser a -> TurtleParser Char -> TurtleParser L.Text +_stringIt sep chars = L.pack <$> bracket sep sep (many chars) + +_stringItLong :: TurtleParser a -> TurtleParser L.Text -> TurtleParser L.Text +_stringItLong sep chars = L.concat <$> bracket sep sep (many chars) + +_tChars :: String -> TurtleParser Char +_tChars excl = (char '\\' *> (_echar' <|> _uchar')) + <|> noneOf excl + +_tCharsLong :: Char -> String -> TurtleParser L.Text +_tCharsLong c excl = do + mq <- optional $ oneOrTwo c + r <- _tChars excl + return $ L.append (fromMaybe L.empty mq) (L.singleton r) + +oneOrTwo :: Char -> TurtleParser L.Text +oneOrTwo c = do + a <- char c + mb <- optional (char c) + case mb of + Just b -> return $ L.pack [a,b] + _ -> return $ L.singleton a + +{- +[91s] ::= "\\" [tbnrf\\\"'] +-} + +_echar :: TurtleParser Char +_echar = char '\\' *> _echar' + +_echar' :: TurtleParser Char +_echar' = + (char 't' *> pure '\t') <|> + (char 'b' *> pure '\b') <|> + (char 'n' *> pure '\n') <|> + (char 'r' *> pure '\r') <|> + (char '\\' *> pure '\\') <|> + (char '"' *> pure '"') <|> + (char '\'' *> pure '\'') + + +{- + +Unused. + +[92s] ::= "(" (WS)* ")" +-} + +{- +[93s] ::= " " + | "\t" + | "\r" + | "\n" + +_ws :: TurtleParser () +_ws = ignore $ satisfy (`elem` " \t\r\n") + +-} + +_manyws :: TurtleParser () +_manyws = ignore $ manySatisfy (`elem` " \t\r\n") + +{- +[94s] ::= "[" (WS)* "]" + +Unused as we do not support the use of ANON in the BlankNode +terminal. + +_anon :: TurtleParser RDFLabel +_anon = br "[" "]" _manyws *> newBlankNode + +-} + +{- +[95s] ::= [A-Z] + | [a-z] + | [#00C0-#00D6] + | [#00D8-#00F6] + | [#00F8-#02FF] + | [#0370-#037D] + | [#037F-#1FFF] + | [#200C-#200D] + | [#2070-#218F] + | [#2C00-#2FEF] + | [#3001-#D7FF] + | [#F900-#FDCF] + | [#FDF0-#FFFD] + | [#10000-#EFFFF] + | UCHAR + +TODO: may want to make this a Char -> Bool selector for +use with manySatisfy rather than a combinator. +-} + +_pnCharsBase :: TurtleParser Char +_pnCharsBase = + let f c = let i = ord c + in isaZ c || + match i [(0xc0, 0xd6), (0xd8, 0xf6), (0xf8, 0x2ff), + (0x370, 0x37d), (0x37f, 0x1fff), (0x200c, 0x200d), + (0x2070, 0x218f), (0x2c00, 0x2fef), (0x3001, 0xd7ff), + (0xf900, 0xfdcf), (0xfdf0, 0xfffd), (0x10000, 0xeffff)] + in satisfy f <|> _uchar + +{- +[96s] ::= PN_CHARS_BASE + | "_" +-} + +_pnCharsU :: TurtleParser Char +_pnCharsU = _pnCharsBase <|> char '_' + +{- + +Only used in VAR1/2 rules which are themselves unused. + +Unused in the grammar (other than +[97s] ::= ( PN_CHARS_U | [0-9] ) ( PN_CHARS_U | [0-9] | #00B7 | [#0300-#036F] | [# + 203F-#2040] )* +-} + +{- +[98s] ::= PN_CHARS_U + | "-" + | [0-9] + | #00B7 + | [#0300-#036F] + | [#203F-#2040] +-} + +_pnChars :: TurtleParser Char +_pnChars = + _pnCharsU + <|> + satisfy (\c -> let i = ord c + in c == '-' || (c >= '0' && c <= '9') || i == 0xb7 || + match i [(0x0300, 0x036f), (0x203f, 0x2040)]) + +{- +[99s] ::= PN_CHARS_BASE ( ( PN_CHARS | "." )* PN_CHARS )? +-} + +_pnPrefix :: TurtleParser L.Text +_pnPrefix = L.cons <$> _pnCharsBase <*> _pnRest + +{- +[100s] ::= ( PN_CHARS_U | [0-9] ) ( ( PN_CHARS | "." )* PN_CHARS )? +-} + +_pnLocal :: TurtleParser L.Text +_pnLocal = L.cons <$> (_pnCharsU <|> satisfy is09) + <*> _pnRest + +{- +Extracted from PN_PREFIX and PN_LOCAL is + + :== ( ( PN_CHARS | "." )* PN_CHARS )? + +We assume below that the match is only ever done for small strings, so +the cost of the foldr isn't likely to be large. Let's see how well +this assumption holds up. + +-} + +_pnRest :: TurtleParser L.Text +_pnRest = do + lbl <- many (_pnChars <|> char '.') + let (nret, lclean) = clean lbl + + -- a simple difference list implementation + edl = id + snocdl x xs = xs . (x:) + appenddl = (.) + replicatedl n x = (replicate n x ++) + + -- this started out as a simple automaton/transducer from + -- http://www.haskell.org/pipermail/haskell-cafe/2011-September/095347.html + -- but then I decided to complicate it + -- + clean :: String -> (Int, String) + clean = go 0 edl + where + go n acc [] = (n, acc []) + go n acc ('.':xs) = go (n+1) acc xs + go 0 acc (x:xs) = go 0 (snocdl x acc) xs + go n acc (x:xs) = go 0 (appenddl acc (snocdl x (replicatedl n '.'))) xs + + reparse $ L.replicate (fromIntegral nret) (L.singleton '.') + return $ L.pack lclean + +{- +Original from + + chop = go 0 [] + where + -- go :: State -> Stack -> String -> String + go 0 _ [] = [] + go 0 _ (x:xs) + | isSpace x = go 1 [x] xs + | otherwise = x : go 0 xs + + go 1 ss [] = [] + go 1 ss (x:xs) + | isSpace c = go 1 (x:ss) xs + | otherwise = reverse ss ++ x : go 0 xs + +-} + +-------------------------------------------------------------------------------- +-- +-- Copyright (c) 2003, Graham Klyne, 2009 Vasili I Galchin, 2011 Douglas Burke +-- All rights reserved. +-- +-- This file is part of Swish. +-- +-- Swish is free software; you can redistribute it and/or modify +-- it under the terms of the GNU General Public License as published by +-- the Free Software Foundation; either version 2 of the License, or +-- (at your option) any later version. +-- +-- Swish is distributed in the hope that it will be useful, +-- but WITHOUT ANY WARRANTY; without even the implied warranty of +-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +-- GNU General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with Swish; if not, write to: +-- The Free Software Foundation, Inc., +-- 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +-- +-------------------------------------------------------------------------------- diff --git a/swish.cabal b/swish.cabal --- a/swish.cabal +++ b/swish.cabal @@ -1,5 +1,5 @@ Name: swish -Version: 0.6.0.1 +Version: 0.6.1.0 Stability: experimental License: LGPL License-file: LICENSE @@ -27,7 +27,7 @@ . Swish is a work-in-progress, and currently incorporates: . - * Notation3 and NTriples input and output. The N3 support is + * Turtle, Notation3 and NTriples input and output. The N3 support is incomplete (no handling of @\@forAll@). . * RDF graph isomorphism testing and merging. @@ -46,6 +46,11 @@ . Changes: . + [Version 0.6.1.0] Added support for Turtle format (added the + Swish.RDF.TurtleFormatter and Swish.RDF.TurtleParser modules). + . + [Version 0.6.0.2] Minor internal changes. + . [Version 0.6.0.1] Moved to using hashing routine using the Data.Hashable interface rather than Swish.Utils.MiscHelpers which is deprecated. . @@ -217,6 +222,8 @@ Swish.RDF.SwishMain Swish.RDF.SwishMonad Swish.RDF.SwishScript + Swish.RDF.TurtleFormatter + Swish.RDF.TurtleParser Swish.RDF.VarBinding Swish.RDF.Vocabulary Swish.Utils.ListHelpers