packages feed

HaXPath (empty) → 0.3.0.0

raw patch · 14 files changed

+1902/−0 lines, 14 filesdep +HListdep +HUnitdep +HaXPath

Dependencies added: HList, HUnit, HaXPath, base, bytestring, text

Files

+ CHANGELOG.md view
@@ -0,0 +1,15 @@+## 0.3.0.0++* Remove dependency on `text`+* Allow paths to be shown as any string-like type++## 0.2.0.0++* Major refactor to simplify the API+* Add axes contraints on schematic paths+* This version was not published on Hackage++## 0.1.0.0++* Initial experimental version+* This version was not published on Hackage
+ HaXPath.cabal view
@@ -0,0 +1,66 @@+cabal-version: 1.18++name:            HaXPath+version:         0.3.0.0+synopsis:        An XPath-generating embedded domain specific language.+description:     An XPath-generating embedded domain specific language, allowing construction and composition of+                 type-safe XPaths in Haskell.+homepage:        https://github.com/hgrano/HaXPath+bug-reports:     https://github.com/hgrano/HaXPath/issues+author:          Huw Grano+maintainer:      huw.grano@gmail.com+category:        XML+build-type:      Simple+license:         BSD3+license-file:    LICENSE+extra-doc-files: README.md+                 CHANGELOG.md++source-repository head+  type: git+  location: https://github.com/hgrano/HaXPath++library+  exposed-modules:+      HaXPath+    , HaXPath.Operators+    , HaXPath.Schematic+    , HaXPath.Schematic.Operators+  hs-source-dirs:+      src+  ghc-options: -Wall+  build-depends:+      base >= 4.6 && < 5+    , HList >= 0.4.0.0 && < 0.6.0.0+  default-language: Haskell2010++test-suite test+  type: exitcode-stdio-1.0+  main-is: Spec.hs+  other-modules:+      HaXPath.Test+    , HaXPath.Schematic.Test+  hs-source-dirs:+      test+  ghc-options: -Wall+  build-depends:+      base+    , bytestring >= 0.11.1.0+    , HaXPath+    , HUnit+    , text+  default-language: Haskell2010++test-suite examples+  type: exitcode-stdio-1.0+  main-is: Main.hs+  other-modules:+      HaXPath.Examples+    , HaXPath.Schematic.Examples+  build-depends:+      base+    , HaXPath+  hs-source-dirs:+      examples+  ghc-options: -Wall+  default-language: Haskell2010
+ LICENSE view
@@ -0,0 +1,28 @@+BSD 3-Clause License++Copyright (c) 2023, Huw Grano++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+   list of conditions and the following disclaimer.++2. Redistributions in binary form must reproduce the above copyright notice,+   this list of conditions and the following disclaimer in the documentation+   and/or other materials provided with the distribution.++3. Neither the name of the copyright holder nor the names of its+   contributors may be used to endorse or promote products derived from+   this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"+AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR+SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER+CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY,+OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,42 @@+# HaXPath+HaXPath is a library and embedded domain-specifc language which uses strongly-typed Haskell expressions to represent+XPaths.++## Motivation+In many contexts when querying XML documents in Haskell we often need to use `String` values to represent the+XPaths we want to use. These `String` expressions can quickly become hard to manage as they do not take advantage of+Haskell's type system, particularly for more complex XPaths. We may not know until run-time whether the XPath is even+syntactically valid. HaXPath does not have its own XPath engine to run the queries, rather it is expected to be used+in combination with other libraries which have such functionality. Instead, we can simply convert the strongly-typed+XPath expressions to `String` or `Text` and send them to our favourite APIs.++## HaXPath API+HaXPath provides two core APIs: the standard API (`HaXPath` module) allows for expressing generic XPaths, while+the schematic API (`HaXPath.Schematic` module) is a layer of abstraction built upon the standard API which constrains+XPath expressions so they must follow a specifc document schema.++### Standard API+`HaXPath` modules are expected to be imported qualified as otherwise you will get name conflicts with the Prelude. The+operators however need not be qualified, and can conveniently be imported directly from `HaXPath.Operators`. All+operators are suffixed with `.`, with the exception of the `#` operator.++Some basic examples:++https://github.com/hgrano/HaXPath/tree/master/examples/HaXPath/Examples.hs++### Schematic API+The schematic API provides further constraints than the standard API by only allowing paths that are valid with respect+to some custom schema. Take for example the following XML document for a restaurant menu:++```xml+<?xml version="1.0" encoding="UTF-8"?>+<menu>+  <item name="Belgian Waffles" price="$5.95"></item>+  <item name="Strawberry Waffles" price="$7.95"></item>+  <item name="French Toast" price="$4.50"></item>+</menu>+```+It should be fairly intuitive that there is an underlying schema to the above document. We can express this using the+`HaXPath.Schematic` module:++https://github.com/hgrano/HaXPath/tree/master/examples/HaXPath/Schematic/Examples.hs
+ examples/HaXPath/Examples.hs view
@@ -0,0 +1,71 @@+{-# LANGUAGE OverloadedStrings #-}++module HaXPath.Examples where++import qualified HaXPath           as X+import           HaXPath.Operators++-- Create XPath nodes for elements <a>, <b>, <c>, <d>+a :: X.Node+a = X.namedNode "a"++b :: X.Node+b = X.namedNode "b"++c :: X.Node+c = X.namedNode "c"++d :: X.Node+d = X.namedNode "d"++-- The XPath "child::a/child::b"+p0 :: X.RelativePath+p0 = X.child a /. X.child b++-- The axes can be inferred using abbreviated syntax+p0Abbrev :: X.RelativePath+p0Abbrev = a /. b ++-- The XPath "/descendant-or-self::node()/child::a/child::b"+-- root is a virtual node, and can be used only at the beginning of a path to indicate it is an absolute path+p1 :: X.AbsolutePath+p1 = X.root /. X.descendantOrSelf X.node /. X.child a /. X.child b++-- The same XPath as above but in abbreviated form+p1Abbrev :: X.AbsolutePath+p1Abbrev = X.root //. a /. b++-- Convert paths to `Text`:+p1Raw :: String+p1Raw = X.show p1 -- "/descendant-or-self::node()/child::a/child::b"++p1AbbrevRaw :: String+p1AbbrevRaw = X.show p1Abbrev -- "/descendant-or-self::node()/child::a/child::b"+-- (note the unabbreviated form is generated by show)++-- Qualifiers can be added to filter node sets using the `#` operator:++-- Equivalent of "(/descendant-or-self::node()/child::a/child::b)[position() = 1]"+p1First :: X.AbsolutePath+p1First = p1 # [X.position =. 1]++-- Equivalent of "/descendant-or-self::node()/child::a/child::b[position() = 1]"+p1FirstB :: X.AbsolutePath+p1FirstB = X.root //. a /. b # [X.position =. 1]++-- Equivalent of "/descendant-or-self::node()/child::a[@id = 'abc']/b"+p1FilterById :: X.AbsolutePath+p1FilterById = X.root //. a # [X.at "id" =. "abc"] /. b++-- Note that the second argument to '#' must represent an XPath boolean value, otherwise it will not type check.++-- XPaths can be re-used and composed together in a type-safe manner as shown+p2 :: X.RelativePath+p2 = c /. d++p3 :: X.RelativePath+p3 = c /. d /. d++-- Equivalent of "//a/b/(c/d | c/d/d)"+p4 :: X.AbsolutePath+p4 = p1 /. (p2 |. p3)
+ examples/HaXPath/Schematic/Examples.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE OverloadedStrings     #-}++module HaXPath.Schematic.Examples where++import           Data.Proxy                  (Proxy(Proxy))+import qualified HaXPath.Schematic           as S+import           HaXPath.Schematic.Operators++-- Empty data type for our schema+data MenuSchema++-- Type of the document root in our schema+type MenuRoot = S.DocumentRoot MenuSchema++-- Type of absolute paths in our schema which return nodes of type rn+type AbsolutePath rn = S.AbsolutePath MenuSchema rn++root :: MenuRoot+root = S.root++-- Type of the <menu> node.+data Menu++-- We need to provide an XML identifier for the node, otherwise it won't compile if we try to use it as a node+instance S.IsNode Menu where+  nodeName _ = "menu"++-- A <menu> node.+menu :: S.Node Menu+menu = S.namedNode++-- Type of the <item> node.+data Item++instance S.IsNode Item where+  nodeName _ = "item"++-- An <item> node.+item :: S.Node Item+item = S.namedNode++-- Type of the "name" attribute+data Name++instance S.IsAttribute Name where+  attributeName _ = "name"++-- @name attribute+-- "as" is a type-level list of attributes used within the expression.+-- The "Member" constraint is used to show that the type Name is a member of "as".+-- This constraint can then be used to verify that it is only used within the context of a node that can actually have+-- the name attribute.+name :: S.Member Name as => S.Text as+name = S.at (Proxy :: Proxy Name)++-- Type of the "price" attribute+data Price++instance S.IsAttribute Price where+  attributeName _ = "price"++-- @price+price :: S.Member Price as => S.Text as+price = S.at (Proxy :: Proxy Price)++-- Menu is the only possible node at the top level of the document+type instance S.Relatives (S.DocumentRoot MenuSchema) S.Child = '[Menu]++-- The only possible child node of a menu is item+type instance S.Relatives Menu S.Child = '[Item]++-- An <item> may have "name" and "price" attributes.+type instance S.Attributes Item = '[Name, Price]++-- Select all the waffles items with a certain price+-- The equivalent of "/menu/item[contains(@name, 'Waffle') and @price = 7.50]"+p0 :: AbsolutePath Item+p0 = root /. menu /. item # [name `S.contains` "Waffle" &&. price =. "$7.50"]++-- The following will not type check because <menu> does not have a price+-- root /. menu # price =. "$7.50"++-- The following will not type check because <item> cannot exist at the top level of the document+-- root /. item
+ examples/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import HaXPath.Examples ()+import HaXPath.Schematic.Examples ()++main :: IO ()+main = pure ()
+ src/HaXPath.hs view
@@ -0,0 +1,559 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}+{-# LANGUAGE TypeOperators         #-}++-- | The core module of the XPath-generating DSL. This module should be used as a qualified import.+module HaXPath(+  -- * Basic data types+  IsExpression,+  Showed,+  Bool',+  Bool,+  false,+  true,+  Number',+  Number,+  Text',+  Text,+  text,+  -- * Nodes+  Node',+  Node,+  node,+  namedNode,+  DocumentRoot',+  root',+  DocumentRoot,+  root,+  at,+  -- * Basic combinators+  not,+  (&&.),+  (||.),+  contains,+  doesNotContain,+  Eq,+  (=.),+  (/=.),+  Ord,+  (<.),+  (<=.),+  (>.),+  (>=.),+  position,+  -- * Paths+  CurrentContext,+  RootContext,+  IsContext,+  Context,+  Path',+  Path,+  AbsolutePath',+  AbsolutePath,+  RelativePath',+  RelativePath,+  PathLike,+  show',+  show,+  -- * Axes+  ancestor,+  child,+  descendant,+  descendantOrSelf,+  following,+  followingSibling,+  parent,+  self,+  -- * Path combinators+  SlashOperator(..),+  DoubleSlashOperator(..),+  Filterable(..),+  count,+  (|.)+) where++import           Data.List (intercalate)+import           Data.List.NonEmpty (NonEmpty((:|)))+import           Data.Proxy  (Proxy (Proxy))+import Data.Semigroup (sconcat)+import qualified Data.String as S+import           Prelude     (($), (*), (+), (-), (.), (<$>), (<>), (==))+import qualified Prelude     as P++-- | XPath textual (string) data type, which can be showed as the string type @s@.+newtype Text' s = Text { unText :: Expression s }++-- | 'Text'' specialised so it can be shown as 'P.String'.+type Text = Text' P.String++-- | XPath numeric data type, which can be showed as the string type @s@.+newtype Number' s = Number { unNumber :: Expression s }++-- | 'Number'' specialised so it can be shown as 'P.String'.+type Number = Number' P.String++-- | XPath boolean data type, which can be showed as the string type @s@.+newtype Bool' s = Bool { unBool :: Expression s }++-- | 'Bool'' specialised so it can be shown as 'P.String'.+type Bool = Bool' P.String++-- | XPath @true()@ value.+true :: S.IsString s => Bool' s+true = Bool $ Function "true" []++-- | XPath @false()@ value.+false :: S.IsString s => Bool' s+false = Bool $ Function "false" []++data PathBegin = FromRootContext | FromCurrentContext deriving (P.Eq)++-- Internal data type to represent an XPath expression using the string-like type s.+data Expression s = Function s [Expression s] |+                    -- Apply the named function to zero or more arguments.+                    Operator s (Expression s) (Expression s) |+                    -- Apply a binary operator to the two operands.+                    Attribute s |+                    -- Access the given attribute of the node (@).+                    TextLiteral s |+                    -- Text value in quotes.+                    IntegerLiteral P.Integer |+                    -- Literal integer (XPath number).+                    NamedNode s |+                    -- Select node with the provided name.+                    FilteredNode (Expression s) [Expression s] |+                    LocationStep Axis (Expression s) |+                    -- From current context move along the given axis and select nodes matching the expression.+                    PathFrom PathBegin (Expression s) (P.Maybe (Expression s)) [Expression s]+                    -- From the starting point, take the first path (expression), then follow the next path (expression)+                    -- (if present) and finally filter by zero or more boolean (expressions).++-- | Class of types which can be used to form a valid XPath expression. Library users should not create instances of+-- this class.+class IsExpression a where+  toExpression :: a -> Expression (Showed a)++instance IsExpression (Text' s) where+  toExpression = unText++instance IsExpression (Number' s) where+  toExpression = unNumber++instance IsExpression (Bool' s) where+  toExpression = unBool++showExpression :: (S.IsString s, P.Show s) => Expression s -> [s]+showExpression (Function f es) = [f, "("] <> args <> [")"]+  where+    args = intercalate [", "] $ showExpression <$> es+showExpression (Operator o a b) =+  showOperand a <> [" ", o, " "] <> showOperand b+  where+    showOperand e@(TextLiteral _)    = showExpression e+    showOperand e@(IntegerLiteral _) = showExpression e+    showOperand e@(Function _ _)     = showExpression e+    showOperand e@(Attribute _)      = showExpression e+    showOperand e                    = "(" : showExpression e <> [")"]++showExpression (Attribute a) = ["@", a]+showExpression (TextLiteral t) = [S.fromString $ P.show t]+showExpression (IntegerLiteral i) = [S.fromString $ P.show i]+showExpression (PathFrom begin p pNextMay preds) =+  let prefix = case begin of+        FromRootContext    -> "/"+        FromCurrentContext -> ""+  in+  let showPath x = case x of+        LocationStep _ _ -> showExpression x+        _                -> "(" : showExpression x <> [")"]+  in+  let fullPShowed = prefix : showPath p <> case pNextMay of+        P.Nothing    -> []+        P.Just pNext -> "/" : showPath pNext+  in+  showWithPredicates fullPShowed preds+showExpression (LocationStep axis n) = showAxis axis : ["::"] <> showExpression n+showExpression (NamedNode n) = [n]+showExpression (FilteredNode n preds) = showExpression n <> showPredicates preds++showPredicates :: (S.IsString s, P.Show s) => [Expression s] -> [s]+showPredicates preds =  "[" : intercalate ["]["] (showExpression <$> preds) <> ["]"]++showWithPredicates :: (S.IsString s, P.Show s) => [s] -> [Expression s] -> [s]+showWithPredicates s es+  | P.not (P.null es) = "(" : s <> [")"] <> showPredicates es+  | P.otherwise = s++-- | Display an XPath expression. This is useful to sending the XPath expression to a separate XPath evaluator e.g.+-- a web browser.+show' :: (PathLike p,+          IsExpression p,+          P.Monoid (Showed p),+          S.IsString (Showed p),+          P.Show (Showed p)) =>+          p -> Showed p+show' = sconcat . (P.mempty :|) . showExpression . toExpression++-- | Specialisation of 'show'' to only generate 'P.String's.+show :: (PathLike p, IsExpression p, Showed p ~ P.String) => p -> P.String+show = show'++instance S.IsString s => S.IsString (Text' s) where+  fromString = Text . TextLiteral . S.fromString++boolToInt :: Bool' s -> Number' s+boolToInt (Bool b) = Number b++-- | Access the value of a node's attribute in text form (equivalent to XPath's @\@@).+at :: s -> Text' s+at = Text . Attribute++-- | Type class of XPath types that can be compared for equality. Library users should not create instances of this+-- class.+class IsExpression t => Eq t++instance Eq (Text' s)+instance Eq (Number' s)+instance Eq (Bool' s)++-- | The XPath @=@ operator.+(=.) :: (Eq a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x =. y = Bool $ Operator "=" (toExpression x) (toExpression y)+infix 4 =.++-- | The XPath @!=@ operator.+(/=.) :: (Eq a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x /=. y = Bool $ Operator "!=" (toExpression x) (toExpression y)+infix 4 /=.++-- | Type class of XPath types that can be ordered. Library users should not create instances of this class.+class Eq t => Ord t++instance Ord (Text' s)+instance Ord (Number' s)+instance Ord (Bool' s)++-- | The XPath @<@ operator.+(<.) :: (Ord a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x <. y = Bool $ Operator "<" (toExpression x) (toExpression y)+infix 4 <.++-- | The XPath @<=@ operator.+(<=.) :: (Ord a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x <=. y = Bool $ Operator "<=" (toExpression x) (toExpression y)+infix 4 <=.++-- | The XPath @>@ operator.+(>.) :: (Ord a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x >. y = Bool $ Operator ">" (toExpression x) (toExpression y)+infix 4 >.++-- | The XPath @>=@ operator.+(>=.) :: (Ord a, S.IsString (Showed a)) => a -> a -> Bool' (Showed a)+x >=. y = Bool $ Operator ">=" (toExpression x) (toExpression y)+infix 4 >=.++instance  S.IsString s => P.Num (Number' s) where+  Number x + Number y = Number $ Operator "+" x y++  Number x - Number y = Number $ Operator "-" x y++  Number x * Number y = Number $ Operator "*" x y++  abs x = x * P.signum x++  signum x = boolToInt (x >. 0) - boolToInt (x <. 0)++  fromInteger = Number . IntegerLiteral++-- | The XPath @position()@ function.+position :: S.IsString s => Number' s+position = Number $ Function "position" []++-- | The XPath @text()@ function.+text :: S.IsString s => Text' s+text = Text $ Function "text" []++-- | The XPath @contains()@ function.+contains :: S.IsString s => Text' s -> Text' s -> Bool' s+contains x y = Bool . Function "contains" $ [toExpression x, toExpression y]++-- | The opposite of 'contains'.+doesNotContain :: S.IsString s => Text' s -> Text' s -> Bool' s+doesNotContain x y = not $ contains x y++-- | The XPath @count()@ function.+count :: (IsContext c, S.IsString s) => Path' c s -> Number' s+count p = Number $ Function "count" [toExpression p]++-- | The XPath @and@ operator.+(&&.) :: S.IsString s => Bool' s -> Bool' s -> Bool' s+x &&. y = Bool $ Operator "and" (toExpression x) (toExpression y)+infixr 3 &&.++-- | The XPath @or@ operator.+(||.) :: S.IsString s => Bool' s -> Bool' s -> Bool' s+x ||. y = Bool $ Operator "or" (toExpression x) (toExpression y)+infixr 2 ||.++-- | The XPath @not(.)@ function.+not :: S.IsString s => Bool' s -> Bool' s+not x = Bool $ Function "not" [toExpression x]++data Axis = Ancestor |+            Child |+            Descendant |+            DescendantOrSelf |+            Following |+            FollowingSibling |+            Parent |+            Self++showAxis :: S.IsString s => Axis -> s+showAxis axis = case axis of+  Ancestor         -> "ancestor"+  Child            -> "child"+  Descendant       -> "descendant"+  DescendantOrSelf -> "descendant-or-self"+  Following        -> "following"+  FollowingSibling -> "following-sibling"+  Parent           -> "parent"+  Self             -> "self"++-- | An XPath node which can be showed as the string type @s@.+newtype Node' s = Node { unNode :: Expression s }++-- | 'Node'' specialised so it can be shown as 'P.String'.+type Node = Node' P.String++instance IsExpression (Node' s) where+  toExpression = unNode++-- | An XPath beginning from some context `c` (either the root context or the current context).+newtype Path' c s = Path { unPath :: Expression s }++-- | 'Path'' specialised so it can be shown as 'P.String'.+type Path c = Path' c P.String++-- | An XPath relative to the current context.+type RelativePath' = Path' CurrentContext++-- | 'RelativePath'' specialised so it can be shown as 'P.String'.+type RelativePath = RelativePath' P.String++-- | An XPath beginning from the document root.+type AbsolutePath' = Path' RootContext++-- | 'AbsolutePath'' specialised so it can be shown as 'P.String'.+type AbsolutePath = AbsolutePath' P.String++-- | Type to indicate the XPath begins from the current context.+data CurrentContext++-- | Type to indicate the XPath begins from the document root.+data RootContext++-- | Class of valid types for the type parameter `c` in 'Path'. Library users should not create instances of this class.+class IsContext c where+  toPathBegin :: proxy c -> PathBegin++instance IsContext RootContext where+  toPathBegin _ = FromRootContext++instance IsContext CurrentContext where+  toPathBegin _ = FromCurrentContext++instance IsContext c => IsExpression (Path' c s) where+  toExpression = unPath++-- | The XPath @node()@ function.+node :: S.IsString s => Node' s+node = Node $ Function "node" []++-- | Create a node with the given name.+namedNode :: S.IsString s => s -> Node' s+namedNode = Node . NamedNode++-- | Type to represent the root of the document. Useful in forming an XPaths which must begin from the root.+data DocumentRoot' s = DocumentRoot++-- | 'DocumentRoot'' specialised so it can be used in paths to be shown as 'P.String'.+type DocumentRoot = DocumentRoot' P.String++-- | The root of the document. There is no corresponding XPath expression for 'root' but it can be used to indicate that+-- an XPath must be begin from the root by using this as the first step in the path.+root' :: DocumentRoot' s+root' = DocumentRoot++-- | Specialisation of 'root'' so it can be used in paths to be shown as 'P.String'.+root :: DocumentRoot+root = root'++-- | Type family which allows a context to be inferred. This allows for support of abbreviated syntax.+type family Context p where+  Context (Path' c s) = c+  Context (Node' s) = CurrentContext+  Context (DocumentRoot' s) = RootContext++-- | Type family which associates an expression type with the type that will be returned by 'show'' when it is dislayed+-- in XPath syntax. This allows flexiblity to use different string-like types, such as 'P.String', @Text@, @ByteString@+-- or even builders for these types.+type family (Showed p) where+  Showed (Number' s) = s+  Showed (Text' s) = s+  Showed (Bool' s) = s+  Showed (Path' c s) = s+  Showed (Node' s) = s+  Showed (DocumentRoot' s) = s++-- | Constraint for path-like types - i.e. they either a 'Path' or otherwise can be converted to one using abbreviated+-- syntax rules.+type PathLike p = IsContext (Context p)++-- | Type class for the XPath @/@ operator. It can operate on multiple types as the axes can be inferred based on+-- XPath's abbreviated syntax. Library users should not create instances of this class.+class (PathLike p, PathLike q, Showed p ~ Showed q) => SlashOperator p q where+  -- | The XPath @/@ operator.+  (/.) :: p -> q -> Path' (Context p) (Showed q)+  infixl 8 /.++instance IsContext c => SlashOperator (Path' c s) (Path' CurrentContext s) where+  pa /. nextPa = Path $ case toExpression pa of+    PathFrom begin fstPath P.Nothing preds -> PathFrom begin fstPath (P.Just $ toExpression nextPa) preds+    _ -> PathFrom+      (toPathBegin (Proxy :: Proxy c))+      (toExpression $ fromCurrentContext pa)+      (P.Just $ toExpression nextPa)+      []++instance IsContext c => SlashOperator (Path' c s) (Node' s) where+  pa /. n = pa /. child n++instance SlashOperator (Node' s) (Path' CurrentContext s) where+  n /. pa = child n /. pa++instance SlashOperator (Node' s) (Node' s) where+  n /. nextNode = child n /. child nextNode++instance SlashOperator (DocumentRoot' s) (Path' CurrentContext s) where+  DocumentRoot /. p = fromRootContext p++instance SlashOperator (DocumentRoot' s) (Node' s) where+  DocumentRoot /. n = fromRootContext (child n)++-- | Type class for the XPath @//@ operator. It can operate on multiple types as the axes can be inferred based on+-- XPath's abbreviated syntax. Library users should not create instances of this class.+class (PathLike p, PathLike q, Showed p ~ Showed q) => DoubleSlashOperator p q where+  -- | The XPath @//@ operator.+  (//.) :: p -> q -> Path' (Context p) (Showed q)+  infixl 8 //.++instance (IsContext c, S.IsString s) => DoubleSlashOperator (Path' c s) (Path' CurrentContext s) where+  pa //. nextPa = Path $ case toExpression pa of+    PathFrom begin fstPath P.Nothing preds -> PathFrom begin fstPath nextPa' preds+    _ -> PathFrom (toPathBegin (Proxy :: Proxy c)) (toExpression $ fromCurrentContext pa) nextPa' []++    where+      nextPa' = P.Just . toExpression $ descendantOrSelf node /. nextPa++instance (IsContext c, S.IsString s) => DoubleSlashOperator (Path' c s) (Node' s) where+  pa //. n = pa /. descendantOrSelf node /. n++instance S.IsString s => DoubleSlashOperator (Node' s) (Path' CurrentContext s) where+  n //. pa = child n //. pa++instance S.IsString s => DoubleSlashOperator (Node' s) (Node' s) where+  n //. nextNode = child n //. child nextNode++instance S.IsString s => DoubleSlashOperator (DocumentRoot' s) (Path' CurrentContext s) where+  DocumentRoot //. p = fromRootContext (descendantOrSelf node) /. p++instance S.IsString s => DoubleSlashOperator (DocumentRoot' s) (Node' s) where+  DocumentRoot //. n = fromRootContext (descendantOrSelf node /. n)++locationStep :: Axis -> Node' s -> Path' c s+locationStep axis n = Path $ LocationStep axis (toExpression n)++-- | The XPath @ancestor::@ axis.+ancestor :: Node' s -> Path' CurrentContext s+ancestor = locationStep Ancestor++-- | The XPath @child::@ axis.+child :: Node' s -> Path' CurrentContext s+child = locationStep Child++-- | The XPath @descendant::@ axis.+descendant :: Node' s -> Path' CurrentContext s+descendant = locationStep Descendant++-- | The XPath @descendant-or-self::@ axis.+descendantOrSelf :: Node' s -> Path' CurrentContext s+descendantOrSelf = locationStep DescendantOrSelf++-- | The XPath @following::@ axis.+following :: Node' s -> Path' CurrentContext s+following = locationStep Following++-- | The XPath @following-sibling::@ axis.+followingSibling :: Node' s -> Path' CurrentContext s+followingSibling = locationStep FollowingSibling++-- | The XPath @parent::@ axis.+parent :: Node' s -> Path' CurrentContext s+parent = locationStep Parent++-- | The XPath @self::@ axis.+self :: Node' s -> Path' CurrentContext s+self = locationStep Self++changeContext :: PathBegin -> Path' c s -> Path' c' s+changeContext begin (Path p) = Path $ case p of+  PathFrom _ fstPath sndPath preds -> PathFrom begin fstPath sndPath preds+  LocationStep _ _                 -> if begin == FromRootContext then PathFrom begin p P.Nothing [] else p+  other                            -> PathFrom begin other P.Nothing []++fromCurrentContext :: Path' c s -> Path' CurrentContext s+fromCurrentContext = changeContext FromCurrentContext++fromRootContext :: Path' CurrentContext s -> Path' RootContext s+fromRootContext = changeContext FromRootContext++-- | The union of two node-sets.+(|.) :: (PathLike p,+         PathLike q,+         IsExpression p,+         IsExpression q,+         Context p ~ Context q,+         Showed p ~ Showed q,+         S.IsString (Showed q)) =>+         p -> q-> Path' (Context p) (Showed q)+x |. y = Path $ Operator "|" (toExpression x) (toExpression y)+infix 7 |.++-- | Type class to allow filtering of node sets. Library users should not create instances of this class.+class (IsExpression p, PathLike p) => Filterable p where+  -- | Filter the nodes returned by @p@ such that they match the list of predicates.+  (#) :: Showed p ~ s => p -> [Bool' s] -> p+  infixl 9 #++instance IsContext c => Filterable (Path' c s) where+  xp # preds =+    let predExps = toExpression <$> preds in+    Path $ case toExpression xp of+      LocationStep axis (FilteredNode n ps)  -> LocationStep axis (FilteredNode n (ps <> predExps))+      LocationStep axis e                    -> LocationStep axis (FilteredNode e predExps)+      PathFrom begin firstSteps nextSteps ps -> PathFrom begin firstSteps nextSteps (ps <> predExps)+      otherExp                               -> PathFrom (toPathBegin (Proxy :: Proxy c)) otherExp P.Nothing predExps++instance Filterable (Node' s) where+  n # preds =+    let predExps = toExpression <$> preds in+    Node $ case toExpression n of+      FilteredNode nExp ps -> FilteredNode nExp (ps <> predExps)+      otherExp             -> FilteredNode otherExp predExps
+ src/HaXPath/Operators.hs view
@@ -0,0 +1,18 @@+-- | XPath operators which are re-exported from the "HaXPath" module for convenience. This module is designed to be+-- imported unqualified.+module HaXPath.Operators (+  (#),+  (&&.),+  (/.),+  (//.),+  (/=.),+  (<.),+  (<=.),+  (=.),+  (>.),+  (>=.),+  (||.),+  (|.)+) where++import           HaXPath
+ src/HaXPath/Schematic.hs view
@@ -0,0 +1,483 @@+{-# LANGUAGE ConstraintKinds       #-}+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE FlexibleInstances     #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE NoImplicitPrelude     #-}+{-# LANGUAGE ScopedTypeVariables   #-}+{-# LANGUAGE TypeFamilies          #-}++-- | Wrapper over the "HaXPath" module which supports stronger type gurantuees such that XPaths must be valid with+-- respect to the document schema. This module should be used as a qualified import.+module HaXPath.Schematic (+  -- * Basic data types+  ToNonSchematic(..),+  Bool',+  Bool,+  false,+  true,+  Number',+  Number,+  Text',+  Text,+  text,+  -- * Nodes+  Node',+  Node,+  IsNode(..),+  namedNode,+  DocumentRoot',+  root',+  DocumentRoot,+  root,+  Attributes,+  AttributesUsed,+  IsAttribute(..),+  at,+  -- * Basic combinators+  not,+  (&&.),+  (||.),+  (=.),+  (/=.),+  (<.),+  (<=.),+  (>.),+  (>=.),+  contains,+  doesNotContain,+  position,+  -- * Paths+  Path',+  Path,+  AbsolutePath',+  AbsolutePath,+  RelativePath',+  RelativePath,+  PathLike,+  SelectNode,+  ReturnNode,+  Relatives,+  show',+  show,+  -- * Axes+  Axis,+  Ancestor,+  ancestor,+  Child,+  child,+  Descendant,+  descendant,+  DescendantOrSelf,+  descendantOrSelf,+  Following,+  following,+  FollowingSibling,+  followingSibling,+  Parent,+  parent,+  -- * Path combinators+  (/.),+  (//.),+  (#),+  count,+  -- * Utilities+  Member+) where++import           Data.HList.CommonMain (HMember)+import           Data.Proxy            (Proxy (Proxy))+import qualified Data.String           as S+import           Data.Kind             (Type)+import qualified HaXPath               as X+import           Prelude               (($), (*), (+), (.), (<$>))+import qualified Prelude               as P++-- | Type level membership constraint indicating that the type @x@ is a member of the type-level list @xs@.+type Member x xs = HMember x xs 'P.True++-- | The type of boolean expressions which depend on the value of the attribute(s) @as@ and can be showed as the string+-- type @s@.+newtype Bool' (as :: [Type]) s = Bool { unBool :: X.Bool' s }++-- | 'Bool'' specialised so it can be shown as 'P.String'.+type Bool as = Bool' as P.String++-- | XPath @true()@ value.+true :: S.IsString s => Bool' as s+true = Bool X.true++-- | XPath @false()@ value.+false :: S.IsString s => Bool' as s+false = Bool X.false++-- | The type of simple numeric expressions which depend on the value of the attribute(s) @as@.+newtype Number' (as :: [Type]) s = Number { unNumber :: X.Number' s }++type Number as = Number' as P.String++-- | The type of simple text expressions which depend on the value of the attribute(s) @as@.+newtype Text' (as :: [Type]) s = Text { unText :: X.Text' s }++type Text as = Text' as P.String++-- | The type of path expressions which can be showed as the string type @s@ and are formed by these steps:+--+-- 1. Starting from the context @c@ and moving through the given @axis@.+-- 1. Selecting node(s) of type @n@.+-- 1. Performing zero or more location steps.+-- 1. Finally returning the node(s) of type @rn@.+newtype Path' c axis n rn s = Path { unPath :: X.Path' c s }++-- | 'Path'' specialised so it can be shown as 'P.String'.+type Path c axis n rn = Path' c axis n rn P.String++type AbsolutePath' sc rn = Path' X.RootContext Self (DocumentRoot sc) rn++type AbsolutePath sc rn = (AbsolutePath' sc rn) P.String++type RelativePath' = Path' X.CurrentContext++type RelativePath axis n rn = RelativePath' axis n rn P.String++instance S.IsString s => S.IsString (Text' as s) where+  fromString = Text . S.fromString++-- | Type class for conversion from a schematic value to its underlying, non-schematic version.+class ToNonSchematic t where+  -- | Corresponding non-schematic type.+  type NonSchematic t++  -- | Convert from the schematic to the non-schematic version.+  toNonSchematic :: t -> NonSchematic t++instance ToNonSchematic (Bool' as s) where+  type NonSchematic (Bool' as s) = X.Bool' s++  toNonSchematic = unBool++instance ToNonSchematic (Number' as s) where+  type NonSchematic (Number' as s) = X.Number' s++  toNonSchematic = unNumber++instance ToNonSchematic (Text' as s) where+  type NonSchematic (Text' as s) = X.Text' s++  toNonSchematic = unText++instance ToNonSchematic (Path' c axis n rn s) where+  type NonSchematic (Path' c axis n rn s) = X.Path' c s++  toNonSchematic = unPath++instance ToNonSchematic (Node' n s) where+  type NonSchematic (Node' n s) = X.Node' s++  toNonSchematic = unNode++instance ToNonSchematic (DocumentRoot' sc s) where+  type NonSchematic (DocumentRoot' sc s) = X.DocumentRoot' s++  toNonSchematic = unDocumentRoot++-- This type class is not exposed as this would allow for arbitrary, non-schematic expression to be converted to+-- a schematic version when the underlying expression does not actually conform to the schema.+class FromNonSchematic x t where+  fromNonSchematic :: x -> t++instance FromNonSchematic (X.Bool' s) (Bool' as s) where+  fromNonSchematic = Bool++instance FromNonSchematic (X.Number' s) (Number' as s) where+  fromNonSchematic = Number++instance FromNonSchematic (X.Text' s) (Text' as s) where+  fromNonSchematic = Text++instance FromNonSchematic (X.Path' c s) (Path' c axis n rn s) where+  fromNonSchematic = Path++instance FromNonSchematic (X.Node' s) (Node' n s) where+  fromNonSchematic = Node++instance FromNonSchematic (X.DocumentRoot' s) (DocumentRoot' sc s) where+  fromNonSchematic = DocumentRoot++-- | The XPath @text()@ function.+text :: forall (as :: [Type]) s. S.IsString s => Text' as s+text = Text X.text++-- | The XPath @contains()@ function.+contains :: S.IsString s => Text' as s -> Text' as s -> Bool' as s+contains = binary X.contains++-- | The opposite of 'contains'.+doesNotContain :: S.IsString s => Text' as s -> Text' as s -> Bool' as s+doesNotContain = binary X.doesNotContain++-- | The XPath @count()@ function.+count :: (X.IsContext c, S.IsString s) => Path' c axis n rn s -> Number' as s+count = Number . X.count . unPath++-- | The XPath @position()@ function.+position :: S.IsString s => Number' as s+position = Number X.position++unary :: (ToNonSchematic t, ToNonSchematic u, FromNonSchematic (NonSchematic u) u) =>+         (NonSchematic t -> NonSchematic u) ->+          t ->+          u+unary op x = fromNonSchematic (op $ toNonSchematic x)++binary :: (ToNonSchematic t, ToNonSchematic u, ToNonSchematic v, FromNonSchematic (NonSchematic v) v) =>+          (NonSchematic t -> NonSchematic u -> NonSchematic v) ->+          t ->+          u ->+          v+binary op x y = fromNonSchematic (toNonSchematic x `op` toNonSchematic y)++-- | The XPath @or@ operator.+(||.) :: S.IsString s => Bool' as s -> Bool' as s -> Bool' as s+(||.) = binary (X.||.)+infixr 2 ||.++-- | The XPath @and@ operator.+(&&.) :: S.IsString s => Bool' as s -> Bool' as s -> Bool' as s+(&&.) = binary (X.&&.)+infixr 3 &&.++-- | The XPath @not()@ function.+not :: S.IsString s => Bool' as s -> Bool' as s+not = Bool . X.not . unBool++-- | Access the value of the attribute @a@ of a node (equivalent to XPath's @\@@).+at :: (IsAttribute a, Member a as, S.IsString s) => proxy a -> Text' as s+at proxy = Text (X.at $ attributeName proxy)++-- | Type class for node attributes.+class IsAttribute a where+  -- | Return the name of the attribute.+  attributeName :: S.IsString s => proxy a -> s++type family AttributesUsed t where+  AttributesUsed (Bool' as s) = as+  AttributesUsed (Text' as s) = as+  AttributesUsed (Number' as s) = as++-- | The XPath @=@ operator.+(=.) :: (ToNonSchematic t,+         X.Eq (NonSchematic t),+         S.IsString (X.Showed (NonSchematic t))) =>+         t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(=.) = binary (X.=.)+infix 4 =.++-- | The XPath @!=@ operator.+(/=.) :: (ToNonSchematic t,+          X.Eq (NonSchematic t),+          S.IsString (X.Showed (NonSchematic t))) =>+          t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(/=.) = binary (X./=.)+infix 4 /=.++-- | The XPath @<@ operator.+(<.) :: (ToNonSchematic t,+         X.Ord (NonSchematic t),+         S.IsString (X.Showed (NonSchematic t))) =>+         t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(<.) = binary (X.<.)+infix 4 <.++-- | The XPath @<=@ operator.+(<=.) :: (ToNonSchematic t,+         X.Ord (NonSchematic t),+         S.IsString (X.Showed (NonSchematic t))) =>+         t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(<=.) = binary (X.<=.)+infix 4 <=.++-- | The XPath @>@ operator.+(>.) :: (ToNonSchematic t,+         X.Ord (NonSchematic t),+         S.IsString (X.Showed (NonSchematic t))) =>+         t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(>.) = binary (X.>.)+infix 4 >.++-- | The XPath @>=@ operator.+(>=.) :: (ToNonSchematic t,+         X.Ord (NonSchematic t),+         S.IsString (X.Showed (NonSchematic t))) =>+         t -> t -> Bool' (AttributesUsed t) (X.Showed (NonSchematic t))+(>=.) = binary (X.>=.)+infix 4 >=.++instance S.IsString s => P.Num (Number' a s) where+  (+) = binary (+)+  (*) = binary (*)+  abs = unary P.abs+  signum = unary P.signum+  fromInteger = Number . P.fromInteger+  negate = unary P.negate++-- | Type of an XPath node of type @n@.+newtype Node' (n :: Type) s = Node { unNode :: X.Node' s }++type Node n = Node' n P.String++-- | Type class of node types.+class IsNode n where+  -- | Return the name of the node.+  nodeName :: S.IsString s => proxy n -> s++-- | Create a node expression of the given type.+namedNode :: forall n s. (IsNode n, S.IsString s) => Node' n s+namedNode = Node . X.namedNode $ nodeName (Proxy :: Proxy n)++-- | Type family to constrain the possible relatives of nodes of type @n@ through the given axis.+type family Relatives n axis :: [Type]++-- | Type of the XPath @ancestor::@ axis.+data Ancestor++-- | Type of the XPath @child::@ axis.+data Child++-- | Type of the XPath @descendant::@ axis.+data Descendant++-- | Type of the XPath @descendant-or-self::@ axis.+data DescendantOrSelf++-- | Type of the XPath @following::@ axis.+data Following++-- | Type of the XPath @following-sibling::@ axis.+data FollowingSibling++-- | Type of the XPath @parent::@ axis.+data Parent++-- | Type of the XPath @self::@ axis.+data Self++type instance Relatives n Self = '[n]++-- | Type of the document root for the schema @s@. Useful in forming an XPaths which must begin from the root.+newtype DocumentRoot' sc s = DocumentRoot { unDocumentRoot :: X.DocumentRoot' s }++type DocumentRoot sc = DocumentRoot' sc P.String++type instance Relatives (DocumentRoot' sc s) Ancestor = '[]+type instance Relatives (DocumentRoot' sc s) Following = '[]+type instance Relatives (DocumentRoot' sc s) FollowingSibling = '[]+type instance Relatives (DocumentRoot' sc s) Parent = '[]++-- | The root of the document for the schema @s@.+root' :: DocumentRoot' sc s+root' = DocumentRoot X.root'++root :: DocumentRoot sc+root = root'++-- | Type family to infer of the axis of a location step based on the type of the step.+type family Axis p where+  Axis (Path' c axis n rn s) = axis+  Axis (Node' n s) = Child+  Axis (DocumentRoot' sc s) = Self++-- | Type family to infer the type of the node selected by the first location step in a path.+type family SelectNode p where+  SelectNode (Path' c axis n rn s) = n+  SelectNode (Node' n s) = n+  SelectNode (DocumentRoot' sc s) = DocumentRoot' sc s++-- | Type family to infer the node selected by the last location step in a path.+type family ReturnNode p where+  ReturnNode (Path' c axis n rn s) = rn+  ReturnNode (Node' n s) = n+  ReturnNode (DocumentRoot' sc s) = DocumentRoot' sc s++-- | Constraint for types from which a path can be inferred.+type PathLike p = (ToNonSchematic p, X.PathLike (NonSchematic p))++-- | The XPath @/@ operator.+(/.) :: (Member (SelectNode q) (Relatives (ReturnNode p) (Axis q)),+          PathLike p,+          PathLike q,+          X.SlashOperator (NonSchematic p) (NonSchematic q)) =>+          p ->+          q ->+          Path' (X.Context (NonSchematic p)) (Axis p) (SelectNode p) (ReturnNode q) (X.Showed (NonSchematic q))+(/.) = binary (X./.)+infixl 8 /.++-- | The XPath @//@ operator.+(//.) :: (Member (SelectNode q) (Relatives (ReturnNode p) Descendant),+          PathLike p,+          PathLike q,+          X.DoubleSlashOperator (NonSchematic p) (NonSchematic q)) =>+          p ->+          q ->+          Path' (X.Context (NonSchematic p)) (Axis p) (SelectNode p) (ReturnNode q) (X.Showed (NonSchematic q))+(//.) = binary (X.//.)+infixl 8 //.++-- | Type family which contrains the possible attributes a node of type @n@ may have.+type family Attributes n :: [Type]++-- | Filter the path-like expression using the given predicate(s). The predicates must only make use of the attributes+-- of the type of node selected by the path, otherwise it will not type check.+(#) :: (PathLike p,+        ToNonSchematic p,+        FromNonSchematic (NonSchematic p) p,+        X.Filterable (NonSchematic p)) =>+        p -> [Bool' (Attributes (ReturnNode p)) (X.Showed (NonSchematic p))] -> p+p # preds = fromNonSchematic $ toNonSchematic p X.# (toNonSchematic <$> preds)+infixl 9 #++-- | The XPath @ancestor::@ axis.+ancestor :: Node' n s -> Path' X.CurrentContext Ancestor n n s+ancestor (Node n) = Path $ X.ancestor n++-- | The XPath @child::@ axis.+child :: Node' n s -> Path' X.CurrentContext Child n n s+child (Node n) = Path $ X.child n++-- | The XPath @descendant::@ axis.+descendant :: Node' n s -> Path' X.CurrentContext Descendant n n s+descendant (Node n) = Path $ X.descendant n++-- | The XPath @descendant-or-self::@ axis.+descendantOrSelf :: Node' n s -> Path' X.CurrentContext DescendantOrSelf n n s+descendantOrSelf (Node n) = Path $ X.descendantOrSelf n++-- | The XPath @following::@ axis.+following :: Node' n s -> Path' X.CurrentContext Following n n s+following (Node n) = Path $ X.following n++-- | The XPath @following-sibling::@ axis.+followingSibling :: Node' n s -> Path' X.CurrentContext FollowingSibling n n s+followingSibling (Node n) = Path $ X.followingSibling n++-- | The XPath @parent::@ axis.+parent :: Node' n s -> Path' X.CurrentContext Parent n n s+parent (Node n) = Path $ X.parent n++-- | Display an XPath expression. This is useful for sending the XPath expression to a separate XPath evaluator e.g.+-- a web browser.+show' :: (PathLike p,+          X.IsExpression (NonSchematic p),+          P.Monoid (X.Showed (NonSchematic p)),+          S.IsString (X.Showed (NonSchematic p)),+          P.Show (X.Showed (NonSchematic p))) =>+          p -> X.Showed (NonSchematic p)+show' = X.show' . toNonSchematic++-- | 'show'' specialised to generate 'P.String's.+show :: (PathLike p,+        X.Showed (NonSchematic p) ~ P.String,+        X.IsExpression (NonSchematic p)) =>+        p -> P.String+show = show'
+ src/HaXPath/Schematic/Operators.hs view
@@ -0,0 +1,17 @@+-- | XPath operators which are re-exported from the "HaXPath.Schematic" module for convenience. This module is designed+-- to be imported unqualified.+module HaXPath.Schematic.Operators (+  (#),+  (&&.),+  (/.),+  (//.),+  (/=.),+  (<.),+  (<=.),+  (=.),+  (>.),+  (>=.),+  (||.)+) where++import           HaXPath.Schematic
+ test/HaXPath/Schematic/Test.hs view
@@ -0,0 +1,268 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE FlexibleContexts  #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeFamilies      #-}++module HaXPath.Schematic.Test (suite) where++import           Data.Proxy                  (Proxy (Proxy))+import qualified HaXPath.Schematic           as S+import           HaXPath.Schematic.Operators+import qualified Test.HUnit                  as H++data Schema++data A++instance S.IsNode A where+  nodeName _ = "a"++a :: S.Node A+a = S.namedNode++data B++instance S.IsNode B where+  nodeName _ = "b"++b :: S.Node B+b = S.namedNode++data C++instance S.IsNode C where+  nodeName _ = "c"++c :: S.Node C+c = S.namedNode++data D++instance S.IsNode D where+  nodeName _ = "d"++d :: S.Node D+d = S.namedNode++type Root = S.DocumentRoot Schema++root :: Root+root = S.root++type instance S.Relatives Root S.Child = '[A]++type instance S.Relatives Root S.Descendant = '[A, B, C, D]++type instance S.Relatives A S.Child = '[B]++type instance S.Relatives A S.Descendant = '[B, C]++type instance S.Relatives A S.Following = '[A, B, C, D]++type instance S.Relatives A S.FollowingSibling = '[A]++type instance S.Relatives B S.Ancestor = '[A]++type instance S.Relatives B S.Child = '[C]++type instance S.Relatives B S.Descendant = '[C]++type instance S.Relatives B S.Parent = '[A]++type instance S.Relatives C S.Child = '[D]++data Id++instance S.IsAttribute Id where+  attributeName _ = "id"++id' :: S.Member Id as => S.Text as+id' = S.at (Proxy :: Proxy Id)++data Attr2++instance S.IsAttribute Attr2 where+  attributeName _ = "attr2"++attr2 :: S.Member Attr2 as => S.Text as+attr2 = S.at (Proxy :: Proxy Attr2)++type instance S.Attributes A = '[Attr2, Id]+type instance S.Attributes B = '[Id]+type instance S.Attributes C = '[Id]+type instance S.Attributes D = '[Id]++testAppend :: H.Test+testAppend = H.TestLabel "append" . H.TestCase $ do+  H.assertEqual "ancestor" "/(child::a/child::b)/ancestor::a" (S.show $ root /. a /. b /. S.ancestor a)+  H.assertEqual+    "Child"+    "/(descendant-or-self::node()/child::a)/child::b"+    (S.show $ root //. S.child a /. S.child b)+  H.assertEqual+    "Child(abbrev)"+    "/(descendant-or-self::node()/child::a)/child::b"+    (S.show $ root //. a /. b)+  H.assertEqual+    "Child(abbrev) with brackets"+    "child::a/(child::b/child::c)"+    (S.show $ a /. (b /. c))+  H.assertEqual "descendant" "/descendant::a" (S.show $ root /. S.descendant a)+  H.assertEqual+    "Descendent or self"+    "/((descendant-or-self::node()/child::a)/descendant-or-self::node())/child::b"+    (S.show $ root //. a //. b)+  H.assertEqual "following" "/child::a/following::a" (S.show $ root /. a /. S.following a)+  H.assertEqual "following" "/child::a/following-sibling::a" (S.show $ root /. a /. S.followingSibling a)+  H.assertEqual "parent" "/(child::a/child::b)/parent::a" (S.show $ root /. a /. b /. S.parent a)++testAttribute :: H.Test+testAttribute = H.TestLabel "attribute" . H.TestCase $ do+  H.assertEqual "Attribute equality" "a[@id = \"hello\"]" (S.show $ a # [id' =. "hello"])+  H.assertEqual "Attribute equality" "a[@attr2 = \"hello\"]" (S.show $ a # [attr2 =. "hello"])++testBool :: H.Test+testBool = H.TestLabel "bool" . H.TestCase $ do+  H.assertEqual+    "and"+    "a[(text() = \"abc\") and contains(@id, \"def\")]"+    (S.show $ a # [S.text =. "abc" &&. id' `S.contains` "def"])+  H.assertEqual+    "or"+    "a[(text() = \"abc\") or contains(@id, \"def\")]"+    (S.show $ a # [S.text =. "abc" ||. id' `S.contains` "def"])+  H.assertEqual+    "not"+    "a[(text() = \"abc\") or not(contains(@id, \"def\"))]"+    (S.show $ a # [S.text =. "abc" ||. id' `S.doesNotContain` "def"])+  H.assertEqual+    "!="+    "a[text() != \"abc\"]"+    (S.show $ a # [S.text /=. "abc"])+  H.assertEqual+    "true"+    "a[true()]"+    (S.show $ a # [S.true])+  H.assertEqual+    "false"+    "a[false()]"+    (S.show $ a # [S.false])+  H.assertEqual+    "false"+    "a[false() and (text() != \"abc\")]"+    (S.show $ a # [S.false &&. S.text /=. "abc"])++testContext :: H.Test+testContext = H.TestLabel "context" . H.TestCase $ do+  H.assertEqual "//" "/descendant-or-self::node()/child::a" (S.show $ root //. a)+  H.assertEqual "/" "/child::a" (S.show $ root /. a)++testFunction :: H.Test+testFunction = H.TestLabel "function" . H.TestCase $ do+  H.assertEqual "text()" "a[text() = \"hello\"]" (S.show $ a # [S.text =. "hello"])+  H.assertEqual+    "contains()"+    "a[contains(text(), \"hello\")]"+    (S.show $ a # [S.text `S.contains` "hello"])+  H.assertEqual+    "count() [relative]"+    "a[count(child::b/child::c[@id = \"id\"]) = 3]"+    (S.show $ a # [S.count (b /. c # [id' =. "id"]) =. 3])+  H.assertEqual+    "count() [absolute]"+    "a[count(/(child::a/child::b)/child::c[@id = \"id\"]) = 3]"+    (S.show $ a # [S.count (root /. a /. b /. c # [id' =. "id"]) =. 3])+  H.assertEqual+    "doesNotContain()"+    "a[not(contains(text(), \"hello\"))]"+    (S.show $ a # [S.text `S.doesNotContain` "hello"])+  H.assertEqual "not()" "a[not(@id = \"id\")]" (S.show $ a # [S.not (id' =. "id")])++testNum :: H.Test+testNum = H.TestLabel "num" . H.TestCase $ do+  H.assertEqual "+" "a[(position() + 1) = 2]" (S.show $ a # [S.position + 1 =. 2])+  H.assertEqual "+" "a[(position() + (0 - 1)) = 2]" (S.show $ a # [S.position - 1 =. 2])+  H.assertEqual "*" "a[(position() * 2) = 4]" (S.show $ a # [S.position * 2 =. 4])+  H.assertEqual+    "signum"+    "a[position() = (((0 - 4) > 0) - ((0 - 4) < 0))]"+    (S.show $ a # [S.position =. signum (-4)])+  H.assertEqual+    "abs" "a[position() = ((0 - 4) * (((0 - 4) > 0) - ((0 - 4) < 0)))]"+    (S.show $ a # [S.position =. abs (-4)])++testOrd :: H.Test+testOrd = H.TestLabel "ord" . H.TestCase $ do+  H.assertEqual "<" "a[2 < position()]" (S.show $ a # [2 <. S.position])+  H.assertEqual "<=" "a[2 <= position()]" (S.show $ a # [2 <=. S.position])+  H.assertEqual ">" "a[2 > position()]" (S.show $ a # [2 >. S.position])+  H.assertEqual ">=" "a[2 >= position()]" (S.show $ a # [2 >=. S.position])++testPredicate :: H.Test+testPredicate = H.TestLabel "path" . H.TestCase $ do+  H.assertEqual+    "filter node"+    "/((descendant-or-self::node()/child::a)/child::b)/child::c[@id = \"id\"]"+    (S.show $ root //. a /. b /. c # [id' =. "id"])++  H.assertEqual+    "filter absolute"+    "(/((descendant-or-self::node()/child::a)/child::b)/child::c)[@id = \"id\"]"+    (S.show $ (root //. a /. b /. c) # [id' =. "id"])++  H.assertEqual+    "double filter"+    "(/((descendant-or-self::node()/child::a)/child::b)/child::c[@id = \"id\"])[@id = \"id\"]"+     (S.show $ (root //. a /. b /. c # [id' =. "id"]) # [id' =. "id"])++  H.assertEqual+    "filter in middle"+    "/((descendant-or-self::node()/child::a)/child::b[@id = \"id\"])/child::c"+    (S.show $ root //. a /. (b # [id' =. "id"]) /. c)++  H.assertEqual+    "filter in middle (abbrev)"+    "/((descendant-or-self::node()/child::a)/child::b[@id = \"id\"])/child::c"+    (S.show $ root //. a /. (b # [id' =. "id"]) /. c)++  H.assertEqual+    "filter in middle with 2 nodes"+    "/((descendant-or-self::node()/child::a)/((child::b/child::c)[@id = \"id\"]))/child::d"+    (S.show $ root //. a /. ((b /. c) # [id' =. "id"]) /. d)++  H.assertEqual+    "brackets + brackets"+    "child::a/(child::b/((child::c/child::d)[@id = \"id2\"]))"+    (S.show $ a /. (b /. ((c /. d) # [id' =. "id2"])))++  H.assertEqual+    "filtering bracketed expression"+    "(child::a/child::b)[@id = \"id\"][position() = 2]"+    (S.show $ ((a /. b) # [id' =. "id"]) # [S.position =. 2])++  H.assertEqual+    "filtering bracketed expression with prev"+    "(child::a/((child::b/child::c)[@id = \"id\"]))[position() = 2]"+    (S.show $ (a /. ((b /. c) # [id' =. "id"])) # [S.position =. 2])++  H.assertEqual+    "Two filters"+    "(child::a/child::b)[@id = \"id\"][position() = 2]"+    (S.show $ (a /. b) # [id' =. "id"] # [S.position =. 2])++  H.assertEqual+    "Issue #8"+    "/((descendant-or-self::node()/child::a)[position() = 2])/child::b"+    (S.show $ (root //. a) # [S.position =. 2] /. b)++suite :: H.Test+suite = H.TestLabel "HaXPath.Schematic" $ H.TestList [+    testAppend,+    testAttribute,+    testBool,+    testContext,+    testFunction,+    testNum,+    testOrd,+    testPredicate+  ]
+ test/HaXPath/Test.hs view
@@ -0,0 +1,226 @@+{-# LANGUAGE OverloadedStrings #-}++module HaXPath.Test (suite) where++import           Data.ByteString   (ByteString)+import qualified Data.ByteString.Builder as BSBuilder+import           Data.String       (IsString)+import           Data.Text         (Text)+import qualified Data.Text.Lazy.Builder as TBuilder+import qualified HaXPath           as X+import           HaXPath.Operators+import qualified Test.HUnit        as H++a :: IsString s => X.Node' s+a = X.namedNode "a"++b :: IsString s => X.Node' s+b = X.namedNode "b"++c :: IsString s => X.Node' s+c = X.namedNode "c"++d :: IsString s => X.Node' s+d = X.namedNode "d"++testAppend :: H.Test+testAppend = H.TestLabel "append" . H.TestCase $ do+  H.assertEqual "ancestor" "/ancestor::a" (X.show $ X.root /. X.ancestor a)+  H.assertEqual+    "Child"+    "/(descendant-or-self::node()/child::a)/child::b"+    (X.show $ X.root /. X.descendantOrSelf X.node /. X.child a /. X.child b)+  H.assertEqual+    "Child(abbrev)"+    "/(descendant-or-self::node()/child::a)/child::b"+    (X.show $ X.root //. a /. b)+  H.assertEqual+    "Child(abbrev) with brackets"+    "child::a/(child::b/child::c)"+    (X.show $ a /. (b /. c))+  H.assertEqual "descendant" "/descendant::a" (X.show $ X.root /. X.descendant a)+  H.assertEqual+    "Descendent or self"+    "/((descendant-or-self::node()/child::a)/descendant-or-self::node())/child::b"+    (X.show $ X.root //. a //. b)+  H.assertEqual "following" "/following::a" (X.show $ X.root /. X.following a)+  H.assertEqual "following" "/following-sibling::a" (X.show $ X.root /. X.followingSibling a)+  H.assertEqual "parent" "/parent::a" (X.show $ X.root /. X.parent a)++testAttribute :: H.Test+testAttribute = H.TestLabel "attribute" . H.TestCase $+  H.assertEqual "Attribute equality" "a[@id = \"hello\"]" (X.show $ a # [X.at "id" =. "hello"])++testBool :: H.Test+testBool = H.TestLabel "bool" . H.TestCase $ do+  H.assertEqual+    "and"+    "a[(text() = \"abc\") and contains(@id, \"def\")]"+    (X.show $ a # [X.text =. "abc" &&. X.at "id" `X.contains` "def"])+  H.assertEqual+    "or"+    "a[(text() = \"abc\") or contains(@id, \"def\")]"+    (X.show $ a # [X.text =. "abc" ||. X.at "id" `X.contains` "def"])+  H.assertEqual+    "not"+    "a[(text() = \"abc\") or contains(@id, \"def\")]"+    (X.show $ a # [X.text =. "abc" ||. X.at "id" `X.contains` "def"])+  H.assertEqual+    "!="+    "a[text() != \"abc\"]"+    (X.show $ a # [X.text /=. "abc"])+  H.assertEqual+    "true"+    "a[true()]"+    (X.show $ a # [X.true])+  H.assertEqual+    "false"+    "a[false()]"+    (X.show $ a # [X.false])+  H.assertEqual+    "false"+    "a[false() and (text() != \"abc\")]"+    (X.show $ a # [X.false &&. X.text /=. "abc"])++testContext :: H.Test+testContext = H.TestLabel "context" . H.TestCase $ do+  H.assertEqual "//" "/descendant-or-self::node()/child::a" (X.show $ X.root //. a)+  H.assertEqual "/" "/child::a" (X.show $ X.root /. a)+  H.assertEqual "/ - using operator" "/((a) | (b))" (X.show $ X.root /. (a |. b))++testFunction :: H.Test+testFunction = H.TestLabel "function" . H.TestCase $ do+  H.assertEqual "text()" "a[text() = \"hello\"]" (X.show $ a # [X.text =. "hello"])+  H.assertEqual+    "contains()"+    "a[contains(text(), \"hello\")]"+    (X.show $ a # [X.text `X.contains` "hello"])+  H.assertEqual+    "count() [relative]"+    "a[count(child::b/child::c[@id = \"id\"]) = 3]"+    (X.show $ a # [X.count (b /. c # [X.at "id" =. "id"]) =. 3])+  H.assertEqual+    "count() [absolute]"+    "a[count(/child::b/child::c[@id = \"id\"]) = 3]"+    (X.show $ a # [X.count (X.root /. b /. c # [X.at "id" =. "id"]) =. 3])+  H.assertEqual+    "doesNotContain()"+    "a[not(contains(text(), \"hello\"))]"+    (X.show $ a # [X.text `X.doesNotContain` "hello"])+  H.assertEqual "not()" "a[not(@id = \"id\")]" (X.show $ a # [X.not (X.at "id" =. "id")])++testNum :: H.Test+testNum = H.TestLabel "num" . H.TestCase $ do+  H.assertEqual "+" "a[(position() + 1) = 2]" (X.show $ a # [X.position + 1 =. 2])+  H.assertEqual "+" "a[(position() - 1) = 2]" (X.show $ a # [X.position - 1 =. 2])+  H.assertEqual "*" "a[(position() * 2) = 4]" (X.show $ a # [X.position * 2 =. 4])+  H.assertEqual+    "signum"+    "a[position() = (((0 - 4) > 0) - ((0 - 4) < 0))]"+    (X.show $ a # [X.position =. signum (-4)])+  H.assertEqual+    "abs" "a[position() = ((0 - 4) * (((0 - 4) > 0) - ((0 - 4) < 0)))]"+    (X.show $ a # [X.position =. abs (-4)])++testOrd :: H.Test+testOrd = H.TestLabel "ord" . H.TestCase $ do+  H.assertEqual "<" "a[2 < position()]" (X.show $ a # [2 <. X.position])+  H.assertEqual "<=" "a[2 <= position()]" (X.show $ a # [2 <=. X.position])+  H.assertEqual ">" "a[2 > position()]" (X.show $ a # [2 >. X.position])+  H.assertEqual ">=" "a[2 >= position()]" (X.show $ a # [2 >=. X.position])++testPredicate :: H.Test+testPredicate = H.TestLabel "predicates" . H.TestCase $ do+  H.assertEqual+    "filter node"+    "/((descendant-or-self::node()/child::a)/child::b)/child::c[@id = \"id\"]"+    (X.show $ X.root //. a /. b /. c # [X.at "id" =. "id"])++  H.assertEqual+    "filter absolute"+    "(/((descendant-or-self::node()/child::a)/child::b)/child::c)[@id = \"id\"]"+    (X.show $ (X.root //. a /. b /. c) # [X.at "id" =. "id"])++  H.assertEqual+    "double filter"+    "(/((descendant-or-self::node()/child::a)/child::b)/child::c[@id = \"id\"])[@id = \"id\"]"+     (X.show $ (X.root //. a /. b /. c # [X.at "id" =. "id"]) # [X.at "id" =. "id"])++  H.assertEqual+    "filter in middle"+    "/((descendant-or-self::node()/child::a)/child::b[@id = \"id\"])/child::c"+    (X.show $ X.root //. a /. (b # [X.at "id" =. "id"]) /. c)++  H.assertEqual+    "filter in middle (abbrev)"+    "/((descendant-or-self::node()/child::a)/child::b[@id = \"id\"])/child::c"+    (X.show $ X.root //. a /. (b # [X.at "id" =. "id"]) /. c)++  H.assertEqual+    "filter in middle with 2 nodes"+    "/((descendant-or-self::node()/child::a)/((child::b/child::c)[@id = \"id\"]))/child::d"+    (X.show $ X.root //. a /. ((b /. c) # [X.at "id" =. "id"]) /. d)++  H.assertEqual+    "brackets + brackets"+    "child::a/(child::b/((child::c/child::d)[@id = \"id2\"]))"+    (X.show $ a /. (b /. ((c /. d) # [X.at "id" =. "id2"])))++  H.assertEqual+    "filtering bracketed expression"+    "(child::a/child::b)[@id = \"id\"][position() = 2]"+    (X.show $ ((a /. b) # [X.at "id" =. "id"]) # [X.position =. 2])++  H.assertEqual+    "filtering bracketed expression with prev"+    "(child::a/((child::b/child::c)[@id = \"id\"]))[position() = 2]"+    (X.show $ (a /. ((b /. c) # [X.at "id" =. "id"])) # [X.position =. 2])++  H.assertEqual+    "Two filters"+    "(child::a/child::b)[@id = \"id\"][position() = 2]"+    (X.show $ (a /. b) # [X.at "id" =. "id", X.position =. 2])++  H.assertEqual+    "Issue #8"+    "/(descendant-or-self::node()/child::a[position() = 2])/child::b"+    (X.show $ X.root //. a # [X.position =. 2] /. b)++testShowGeneric :: H.Test+testShowGeneric = H.TestLabel "show generic" . H.TestCase $ do+  H.assertEqual "Show Text" (expectedShow :: Text) (X.show' path)+  H.assertEqual "Show ByteString" (expectedShow :: ByteString) (X.show' path)+  H.assertEqual+    "Show ByteString from builder"+    (BSBuilder.toLazyByteString expectedShow)+    (BSBuilder.toLazyByteString $ X.show' path)+  H.assertEqual+    "Show Text from builder"+    (TBuilder.toLazyText expectedShow)+    (TBuilder.toLazyText $ X.show' path)++  where+    expectedShow :: IsString s => s+    expectedShow = "child::a/child::b[@id = \"hello \\\"world\\\"\"]"++    path :: IsString s => X.Path' X.CurrentContext s+    path = a /. b # [X.at "id" =. "hello \"world\""]++testUnion :: H.Test+testUnion = H.TestLabel "union" . H.TestCase $ do+  H.assertEqual "Union absolute paths" "(/child::a/child::b) | (/child::c)" (X.show $ X.root /. a /. b |. X.root /. c)+  H.assertEqual "Union relative paths" "(child::a/child::b) | (c)" (X.show $ a /. b |. c)++suite :: H.Test+suite = H.TestLabel "HaXPath" $ H.TestList [+    testAppend,+    testAttribute,+    testBool,+    testContext,+    testFunction,+    testNum,+    testOrd,+    testPredicate,+    testShowGeneric,+    testUnion+  ]
+ test/Spec.hs view
@@ -0,0 +1,14 @@+{-# LANGUAGE MultiParamTypeClasses #-}++import qualified HaXPath.Schematic.Test as S+import qualified HaXPath.Test           as X+import qualified System.Exit            as E+import qualified Test.HUnit             as H++main :: IO ()+main = do+  counts <- H.runTestTT $ H.TestList [X.suite, S.suite]+  if H.errors counts > 0 || H.failures counts > 0 then+    E.exitFailure+  else+    E.exitSuccess