diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -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 diff --git a/HaXPath.cabal b/HaXPath.cabal new file mode 100644 --- /dev/null +++ b/HaXPath.cabal @@ -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 diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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 + + + + + + +``` +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 diff --git a/examples/HaXPath/Examples.hs b/examples/HaXPath/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/HaXPath/Examples.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaXPath.Examples where + +import qualified HaXPath as X +import HaXPath.Operators + +-- Create XPath nodes for elements , , , +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) diff --git a/examples/HaXPath/Schematic/Examples.hs b/examples/HaXPath/Schematic/Examples.hs new file mode 100644 --- /dev/null +++ b/examples/HaXPath/Schematic/Examples.hs @@ -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 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 node. +menu :: S.Node Menu +menu = S.namedNode + +-- Type of the node. +data Item + +instance S.IsNode Item where + nodeName _ = "item" + +-- An 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 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 does not have a price +-- root /. menu # price =. "$7.50" + +-- The following will not type check because cannot exist at the top level of the document +-- root /. item diff --git a/examples/Main.hs b/examples/Main.hs new file mode 100644 --- /dev/null +++ b/examples/Main.hs @@ -0,0 +1,7 @@ +module Main where + +import HaXPath.Examples () +import HaXPath.Schematic.Examples () + +main :: IO () +main = pure () diff --git a/src/HaXPath.hs b/src/HaXPath.hs new file mode 100644 --- /dev/null +++ b/src/HaXPath.hs @@ -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 diff --git a/src/HaXPath/Operators.hs b/src/HaXPath/Operators.hs new file mode 100644 --- /dev/null +++ b/src/HaXPath/Operators.hs @@ -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 diff --git a/src/HaXPath/Schematic.hs b/src/HaXPath/Schematic.hs new file mode 100644 --- /dev/null +++ b/src/HaXPath/Schematic.hs @@ -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' diff --git a/src/HaXPath/Schematic/Operators.hs b/src/HaXPath/Schematic/Operators.hs new file mode 100644 --- /dev/null +++ b/src/HaXPath/Schematic/Operators.hs @@ -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 diff --git a/test/HaXPath/Schematic/Test.hs b/test/HaXPath/Schematic/Test.hs new file mode 100644 --- /dev/null +++ b/test/HaXPath/Schematic/Test.hs @@ -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 + ] diff --git a/test/HaXPath/Test.hs b/test/HaXPath/Test.hs new file mode 100644 --- /dev/null +++ b/test/HaXPath/Test.hs @@ -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 + ] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -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