diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +Copyright (c) 2015, Sannsyn AS + +Permission is hereby granted, free of charge, to any person +obtaining a copy of this software and associated documentation +files (the "Software"), to deal in the Software without +restriction, including without limitation the rights to use, +copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the +Software is furnished to do so, subject to the following +conditions: + +The above copyright notice and this permission notice shall be +included in all copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES +OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND +NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT +HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, +WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING +FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR +OTHER DEALINGS IN THE SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/library/XMLQuery/XMLTypes.hs b/library/XMLQuery/XMLTypes.hs new file mode 100644 --- /dev/null +++ b/library/XMLQuery/XMLTypes.hs @@ -0,0 +1,16 @@ +module XMLQuery.XMLTypes where + +import XMLQuery.XMLTypes.Prelude +import Data.XML.Types +import qualified XMLQuery as Query +import qualified XMLQuery.XMLTypes.Interpreter as Interpreter +import qualified Success.Pure as Success + + +element :: Query.Element a -> Element -> Either (Maybe Text) a +element query input = + Success.asEither (Interpreter.element query input) + +nodes :: Query.Nodes a -> [Node] -> Either (Maybe Text) a +nodes query input = + Success.asEither (Interpreter.nodes query input) diff --git a/library/XMLQuery/XMLTypes/Interpreter.hs b/library/XMLQuery/XMLTypes/Interpreter.hs new file mode 100644 --- /dev/null +++ b/library/XMLQuery/XMLTypes/Interpreter.hs @@ -0,0 +1,87 @@ +module XMLQuery.XMLTypes.Interpreter where + +import XMLQuery.XMLTypes.Prelude +import Data.XML.Types +import qualified XMLQuery.AST as AST +import qualified XMLQuery.XMLTypes.Renderer as Renderer +import qualified Success.Pure as Success + + +type Result = + Success Text + +nodes :: Alt AST.Nodes a -> [Node] -> Result a +nodes (Alt alternatives) input = + runAlternatives alternatives input + where + runAlternatives alternatives input = + asum (map (\alternative -> runAlternative alternative input) alternatives) + runAlternative alternative input = + case alternative of + Ap fa altfab -> + case fa of + AST.NodesNode query -> + case input of + head : tail -> + nodes altfab tail <*> + node query head + _ -> + Success.failure "No more nodes" + Pure a -> + Success.success a + +node :: Alt AST.Node a -> Node -> Result a +node alt node = + runAlt interpreter alt + where + interpreter :: forall a. AST.Node a -> Result a + interpreter = + \case + AST.NodeElement alt -> + case node of + NodeElement input -> + element alt input + _ -> + Success.failure "Not an element node" + AST.NodeText ast -> + case node of + NodeContent content -> + text ast (Renderer.run Renderer.content content) + _ -> + Success.failure "Not a content node" + +element :: Alt AST.Element a -> Element -> Result a +element alt input = + runAlt interpreter alt + where + interpreter :: forall a. AST.Element a -> Result a + interpreter = + \case + AST.ElementNameText textAST -> + text textAST (Renderer.run Renderer.name (elementName input)) + AST.ElementAttr attrAST -> + asum (map (attr attrAST) (elementAttributes input)) + AST.ElementNodes ast -> + nodes ast (elementNodes input) + +attr :: Alt AST.Attr a -> (Name, [Content]) -> Result a +attr alt input = + runAlt interpreter alt + where + interpreter :: forall a. AST.Attr a -> Result a + interpreter = + \case + AST.AttrNameText ast -> + text ast (Renderer.run Renderer.name (fst input)) + AST.AttrValueText ast -> + text ast (Renderer.run Renderer.contents (snd input)) + +text :: Alt AST.Text a -> Text -> Result a +text alt input = + runAlt interpreter alt + where + interpreter :: forall a. AST.Text a -> Result a + interpreter = + \case + AST.Text fn -> + either Success.failure Success.success (fn input) diff --git a/library/XMLQuery/XMLTypes/Prelude.hs b/library/XMLQuery/XMLTypes/Prelude.hs new file mode 100644 --- /dev/null +++ b/library/XMLQuery/XMLTypes/Prelude.hs @@ -0,0 +1,29 @@ +module XMLQuery.XMLTypes.Prelude +( + module Exports, +) +where + + +-- base-prelude +------------------------- +import BasePrelude as Exports hiding (fail, Alt) + +-- transformers +------------------------- +import Control.Monad.Trans.State.Strict as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.Reader as Exports hiding (liftCallCC, liftCatch) +import Control.Monad.Trans.Class as Exports + +-- text +------------------------- +import Data.Text as Exports (Text) + +-- success +------------------------- +import Success.Pure as Exports (Success) + +-- free +------------------------- +import Control.Alternative.Free as Exports +import Control.Monad.Free as Exports hiding (Pure) diff --git a/library/XMLQuery/XMLTypes/Renderer.hs b/library/XMLQuery/XMLTypes/Renderer.hs new file mode 100644 --- /dev/null +++ b/library/XMLQuery/XMLTypes/Renderer.hs @@ -0,0 +1,36 @@ +module XMLQuery.XMLTypes.Renderer where + +import XMLQuery.XMLTypes.Prelude +import Data.XML.Types +import qualified Data.Text.Lazy.Builder as Builder +import qualified Data.Text.Lazy as LazyText +import qualified HTMLEntities.Decoder + + +type Renderer a = + a -> Builder.Builder + +run :: Renderer a -> a -> Text +run renderer input = + LazyText.toStrict $ + Builder.toLazyText $ + renderer input + +name :: Renderer Name +name = + \(Name local ns prefix) -> + foldMap (\x -> Builder.fromText x <> Builder.singleton ':') prefix <> + Builder.fromText local + +contents :: Renderer [Content] +contents = + foldMap content + +content :: Renderer Content +content = + \case + ContentText x -> + Builder.fromText x + ContentEntity x -> + either (error "XMLQuery.XMLTypes.Renderer.content: corrupt ContentEntity") Builder.fromText $ + HTMLEntities.Decoder.htmlEntity x diff --git a/tasty/Main.hs b/tasty/Main.hs new file mode 100644 --- /dev/null +++ b/tasty/Main.hs @@ -0,0 +1,34 @@ +module Main where + +import BasePrelude hiding (assert) +import Data.Default.Class +import Test.QuickCheck.Instances +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.SmallCheck +import Test.Tasty.QuickCheck +import Data.Text (Text) +import qualified Test.QuickCheck as QuickCheck +import qualified Main.Queries as Queries +import qualified XMLQuery as XMLQuery +import qualified XMLQuery.XMLTypes as XMLQueryXMLTypes +import qualified Text.XML as XMLConduit +import qualified Data.XML.Types as XMLTypes + + +main = + defaultMain tree + +tree = + testGroup "All tests" + [ + testCase "sample 1" $ + queryFile Queries.query1 "samples/1.xml" >>= + \x -> assertEqual (show x) (Right ("Ehrlin, Carl-Johan Forssén", "9788202505929", ["Bøker", "Barnas ARK"])) x + ] + +queryFile :: XMLQuery.Element a -> String -> IO (Either (Maybe Text) a) +queryFile query filename = + XMLConduit.readFile def filename >>= + pure . XMLQueryXMLTypes.element query . XMLTypes.documentRoot . XMLConduit.toXMLDocument + diff --git a/tasty/Main/Queries.hs b/tasty/Main/Queries.hs new file mode 100644 --- /dev/null +++ b/tasty/Main/Queries.hs @@ -0,0 +1,55 @@ +module Main.Queries where + +import BasePrelude +import XMLQuery +import qualified Data.Text as Text + + +query1 :: Element (Text.Text, Text.Text, [Text.Text]) +query1 = + elementNameIs "response" *> + elementNodes (nodesEventualNode (nodeElement element)) + where + element = + elementNameIs "result" *> + elementNodes (nodesEventualNode (nodeElement element)) + where + element = + elementNameIs "doc" *> + ((,,) <$> author <*> isbn <*> mainCatalogueArea) + where + author = + elementNodes (nodesEventualNode (nodeElement element)) + where + element = + elementAttr attr *> + elementNodes nodes + where + attr = + attrNameIs "name" *> + attrValueIs "author" + nodes = + nodesEventualNode (nodeElement (elementNodes (nodesEventualNode (nodeText textValue)))) + isbn = + elementNodes (nodesEventualNode (nodeElement element)) + where + element = + elementAttr attr *> + elementNodes (nodesEventualNode (nodeText textValue)) + where + attr = + attrNameIs "name" *> + attrValueIs "isbn" + mainCatalogueArea = + elementNodes (nodesEventualNode (nodeElement element)) + where + element = + elementAttr attr *> + elementNodes (many (nodesEventualNode (nodeElement (elementNodes (nodesEventualNode (nodeText textValue)))))) + where + attr = + attrNameIs "name" *> + attrValueIs "main_catalog_area" + + + diff --git a/xml-query-xml-types.cabal b/xml-query-xml-types.cabal new file mode 100644 --- /dev/null +++ b/xml-query-xml-types.cabal @@ -0,0 +1,93 @@ +name: + xml-query-xml-types +version: + 0.4 +synopsis: + An interpreter of "xml-query" queries for the "xml-types" documents +category: + Data, XML, Parsing +homepage: + https://github.com/sannsyn/xml-query-xml-types +bug-reports: + https://github.com/sannsyn/xml-query-xml-types/issues +author: + Nikita Volkov +maintainer: + Nikita Volkov +copyright: + (c) 2015, Sannsyn AS +license: + MIT +license-file: + LICENSE +build-type: + Simple +cabal-version: + >=1.10 + + +source-repository head + type: + git + location: + git://github.com/sannsyn/xml-query-xml-types.git + + +library + hs-source-dirs: + library + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + other-modules: + XMLQuery.XMLTypes.Prelude + XMLQuery.XMLTypes.Renderer + XMLQuery.XMLTypes.Interpreter + exposed-modules: + XMLQuery.XMLTypes + build-depends: + html-entities >= 1.1 && < 1.2, + xml-query >= 0.9 && < 0.10, + xml-types >= 0.3.6 && < 0.4, + -- + text == 1.*, + -- + free >= 4.12 && < 5, + success == 0.2.*, + transformers >= 0.3 && < 0.5, + base-prelude >= 0.1.19 && < 0.2 + + +test-suite tasty + type: + exitcode-stdio-1.0 + hs-source-dirs: + tasty + main-is: + Main.hs + other-modules: + Main.Queries + default-extensions: + Arrows, BangPatterns, ConstraintKinds, DataKinds, DefaultSignatures, DeriveDataTypeable, DeriveFoldable, DeriveFunctor, DeriveGeneric, DeriveTraversable, EmptyDataDecls, FlexibleContexts, FlexibleInstances, FunctionalDependencies, GADTs, GeneralizedNewtypeDeriving, ImpredicativeTypes, LambdaCase, LiberalTypeSynonyms, MagicHash, MultiParamTypeClasses, MultiWayIf, NoImplicitPrelude, NoMonomorphismRestriction, OverloadedStrings, PatternGuards, ParallelListComp, QuasiQuotes, RankNTypes, RecordWildCards, ScopedTypeVariables, StandaloneDeriving, TemplateHaskell, TupleSections, TypeFamilies, TypeOperators, UnboxedTuples + default-language: + Haskell2010 + build-depends: + -- + xml-query, + xml-query-xml-types, + xml-types, + xml-conduit, + -- testing: + tasty == 0.11.*, + tasty-quickcheck == 0.8.*, + tasty-smallcheck == 0.8.*, + tasty-hunit == 0.9.*, + quickcheck-instances >= 0.3.11 && < 0.4, + QuickCheck >= 2.8.1 && < 2.9, + -- data: + text == 1.*, + -- general: + data-default-class, + base-prelude, + base