packages feed

katydid (empty) → 0.1.0.0

raw patch · 20 files changed

+2372/−0 lines, 20 filesdep +HUnitdep +basedep +containerssetup-changed

Dependencies added: HUnit, base, containers, directory, filepath, hxt, json, katydid, mtl, parsec, regex-tdfa, tasty, tasty-hunit

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Walter Schulze (c) 2016++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * 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.++    * Neither the name of Walter Schulze nor the names of other+      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+OWNER 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,54 @@+# Katydid++[![Build Status](https://travis-ci.org/katydid/katydid-haskell.svg?branch=master)](https://travis-ci.org/katydid/katydid-haskell)++A Haskell implementation of Katydid.++This includes:++  - [Relapse](https://katydid.github.io/katydid-haskell/Relapse.html): Validation Language +  - Parsers: [JSON](https://katydid.github.io/katydid-haskell/Json.html) and [XML](https://katydid.github.io/katydid-haskell/Xml.html)++[Documentation for katydid](http://katydid.github.io/)++[Documentation for katydid-haskell](https://katydid.github.io/katydid-haskell/)++[Documentation for katydid-haskell/Relapse](https://katydid.github.io/katydid-haskell/Relapse.html)++All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes].++## Example++Validating a single structure can be done using the validate function:+```haskell+validate :: Tree t => Refs -> [t] -> Bool+```++, where a tree is a class in the [Parsers](https://katydid.github.io/katydid-haskell/Parsers.html) module:+```haskell+class Tree a where+    getLabel :: a -> Label+    getChildren :: a -> [a]+```++Here is an example that validates a single JSON tree:+```haskell+main = either +    (\err -> putStrLn $ "error:" ++ err) +    (\valid -> if valid +        then putStrLn "dragons exist" +        else putStrLn "dragons are fictional"+    ) $+    Relapse.validate <$> +        runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> +        Json.decodeJSON "{\"DragonsExist\": false}"+```++## Efficiency++If you want to validate multiple trees using the same grammar then the filter function does some internal memoization, which makes a huge difference.++```haskell+filter :: Tree t => Refs -> [[t]] -> [[t]]+```+
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,17 @@+module Main where++import qualified Relapse+import qualified Json+import Control.Monad.Except (runExcept)++main :: IO ()+main = either +    (\err -> putStrLn $ "error:" ++ err) +    (\valid -> if valid +        then putStrLn "dragons exist" +        else putStrLn "dragons are fictional"+    ) $+    Relapse.validate <$> +        runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> +        Json.decodeJSON "{\"DragonsExist\": false}"+
+ katydid.cabal view
@@ -0,0 +1,86 @@+name:                katydid+version:             0.1.0.0+synopsis:            A haskell implementation of Katydid+description:         +  A haskell implementation of Katydid+  .+  This includes:+  .+      - Relapse, a validation Language+      - Parsers for JSON, XML and an abstraction for trees+  .+  You should only need the following modules:+  .+      - The Relapse module is used for validation.+      - The Json and XML modules are used to create Json and XML trees that can be validated.+  .+  If you want to implement your own parser then you can look at the Parsers module+  .++homepage:            https://github.com/katydid/katydid-haskell+license:             BSD3+license-file:        LICENSE+author:              Walter Schulze+maintainer:          awalterschulze@gmail.com+copyright:           Walter Schulze+category:            Data+build-type:          Simple+extra-source-files:  README.md+cabal-version:       >=1.10++library+  hs-source-dirs:      src+  exposed-modules:   Patterns+                     , Derive+                     , MemDerive+                     , Zip+                     , IfExprs+                     , Expr+                     , Simplify+                     , Json+                     , Xml+                     , Parsers+                     , ParsePatterns+                     , VpaDerive+                     , Parser+                     , Relapse+  build-depends:       base >= 4.7 && < 5+                     , containers+                     , json+                     , hxt+                     , regex-tdfa+                     , mtl+                     , parsec+  default-language:    Haskell2010++executable katydid-exe+  hs-source-dirs:      app+  main-is:             Main.hs+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  build-depends:       base+                     , katydid+                     , mtl+  default-language:    Haskell2010++test-suite katydid-test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      test+  main-is:             Spec.hs+  build-depends:       base+                     , katydid+                     , directory+                     , filepath+                     , containers+                     , json+                     , hxt+                     , HUnit+                     , parsec+                     , mtl+                     , tasty-hunit+                     , tasty+  ghc-options:         -threaded -rtsopts -with-rtsopts=-N+  default-language:    Haskell2010++source-repository head+  type:     git+  location: https://github.com/katydid/katydid-haskell
+ src/Derive.hs view
@@ -0,0 +1,142 @@+-- |+-- This module is a simple implementation of the internal derivative algorithm.+--+-- It is intended to be used for explanation purposes.+--+-- This means that it gives up speed for readability.+--+-- Thus it has no type of memoization.++module Derive (+    derive, calls, returns, zipderive+) where++import Data.Foldable (foldlM)+import Control.Monad.Except (Except, mapExcept, throwError)++import Patterns+import Expr+import Parsers+import Simplify+import Zip+import IfExprs++-- | +-- calls returns a compiled if expression tree.+-- Each if expression returns a child pattern, given the input value.+-- In other words calls signature is actually:+--+-- @+--   Refs -> [Pattern] -> Value -> [Pattern]+-- @+--+-- , where the resulting list of patterns are the child patterns,+-- that need to be derived given the trees child values.+calls :: Refs -> [Pattern] -> IfExprs+calls refs ps = compileIfExprs refs $ concatMap (deriveCall refs) ps++deriveCall :: Refs -> Pattern -> [IfExpr]+deriveCall _ Empty = []+deriveCall _ ZAny = []+deriveCall _ (Node v p) = [newIfExpr v p (Not ZAny)]+deriveCall refs (Concat l r)+    | nullable refs l = deriveCall refs l ++ deriveCall refs r+    | otherwise = deriveCall refs l+deriveCall refs (Or l r) = deriveCall refs l ++ deriveCall refs r+deriveCall refs (And l r) = deriveCall refs l ++ deriveCall refs r+deriveCall refs (Interleave l r) = deriveCall refs l ++ deriveCall refs r+deriveCall refs (ZeroOrMore p) = deriveCall refs p+deriveCall refs (Reference name) = deriveCall refs $ lookupRef refs name+deriveCall refs (Not p) = deriveCall refs p+deriveCall refs (Contains p) = deriveCall refs (Concat ZAny (Concat p ZAny))+deriveCall refs (Optional p) = deriveCall refs (Or p Empty)++-- |+-- returns takes a list of patterns and list of bools.+-- The list of bools represent the nullability of the derived child patterns.+-- Each bool will then replace each Node pattern with either an Empty or EmptySet.+-- The lists do not to be the same length, because each Pattern can contain an arbitrary number of Node Patterns.+returns :: Refs -> ([Pattern], [Bool]) -> [Pattern]+returns _ ([], []) = []+returns refs (p:tailps, ns) =+    let (dp, tailns) = deriveReturn refs p ns+        sp = simplify refs dp+    in  sp:returns refs (tailps, tailns)++deriveReturn :: Refs -> Pattern -> [Bool] -> (Pattern, [Bool])+deriveReturn _ Empty ns = (Not ZAny, ns)+deriveReturn _ ZAny ns = (ZAny, ns)+deriveReturn _ Node{} ns +    | head ns = (Empty, tail ns)+    | otherwise = (Not ZAny, tail ns)+deriveReturn refs (Concat l r) ns+    | nullable refs l = +            let (leftDeriv, leftTail) = deriveReturn refs l ns+                (rightDeriv, rightTail) = deriveReturn refs r leftTail+            in  (Or (Concat leftDeriv r) rightDeriv, rightTail)+    | otherwise = +            let (leftDeriv, leftTail) = deriveReturn refs l ns+            in  (Concat leftDeriv r, leftTail)+deriveReturn refs (Or l r) ns = +    let (leftDeriv, leftTail) = deriveReturn refs l ns+        (rightDeriv, rightTail) = deriveReturn refs r leftTail+    in (Or leftDeriv rightDeriv, rightTail)+deriveReturn refs (And l r) ns = +    let (leftDeriv, leftTail) = deriveReturn refs l ns+        (rightDeriv, rightTail) = deriveReturn refs r leftTail+    in (And leftDeriv rightDeriv, rightTail)+deriveReturn refs (Interleave l r) ns = +    let (leftDeriv, leftTail) = deriveReturn refs l ns+        (rightDeriv, rightTail) = deriveReturn refs r leftTail+    in (Or (Interleave leftDeriv r) (Interleave rightDeriv l), rightTail)+deriveReturn refs z@(ZeroOrMore p) ns = +    let (derivp, tailns) = deriveReturn refs p ns+    in  (Concat derivp z, tailns)+deriveReturn refs (Reference name) ns = deriveReturn refs (lookupRef refs name) ns+deriveReturn refs (Not p) ns =+    let (derivp, tailns) = deriveReturn refs p ns+    in  (Not derivp, tailns)+deriveReturn refs (Contains p) ns = deriveReturn refs (Concat ZAny (Concat p ZAny)) ns+deriveReturn refs (Optional p) ns = deriveReturn refs (Or p Empty) ns++onePattern :: Either ValueErr [Pattern] -> Either String Pattern+onePattern (Right [r]) = return r+onePattern (Left e) = throwError $ show e+onePattern (Right rs) = throwError $ "Number of patterns is not one, but " ++ show rs++-- |+-- derive is the classic derivative implementation for trees.+derive :: Tree t => Refs -> [t] -> Except String Pattern+derive g ts = mapExcept onePattern $ foldlM (deriv g) [lookupRef g "main"] ts++deriv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern]+deriv refs ps tree =+    if all unescapable ps then return ps else+    let ifs = calls refs ps+        d = deriv refs+        nulls = map (nullable refs)+    in do {+        childps <- evalIfExprs ifs (getLabel tree);+        childres <- foldlM d childps (getChildren tree);+        return $ returns refs (ps, nulls childres);+    }++-- |+-- zipderive is a slighty optimized version of derivs.+-- It zips its intermediate pattern lists to reduce the state space.+zipderive :: Tree t => Refs -> [t] -> Except String Pattern+zipderive g ts = mapExcept onePattern $ foldlM (zipderiv g) [lookupRef g "main"] ts++zipderiv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern]+zipderiv refs ps tree =+    if all unescapable ps then return ps else+    let ifs = calls refs ps+        d = zipderiv refs+        nulls = map (nullable refs)+    in do {+        childps <- evalIfExprs ifs (getLabel tree);+        (zchildps, zipper) <- return $ zippy childps;+        childres <- foldlM d zchildps (getChildren tree);+        let unzipns = unzipby zipper (nulls childres)+        in return $ returns refs (ps, unzipns)+    }
+ src/Expr.hs view
@@ -0,0 +1,518 @@+{-#LANGUAGE GADTs, StandaloneDeriving #-}++-- |+-- This module contains all the Relapse expressions.+-- +-- It also contains an eval function and a simplfication function for these expressions.+module Expr (+    -- * Expressions+    Expr(..), Bytes, Uint,+    -- * Functions+    simplifyBoolExpr, eval,+    -- * Errors+    ValueErr+) where++import Data.List (isInfixOf, isPrefixOf, isSuffixOf)+import Data.Char (toLower, toUpper)+import Text.Regex.TDFA ((=~))+import Control.Monad.Except (Except, runExcept, throwError)++import Parsers++type Bytes = String+type Uint = Int++data Expr a where+    -- Expr Bool++    Const :: a -> Expr a+    BoolVariable :: Expr Bool++    OrFunc :: Expr Bool -> Expr Bool -> Expr Bool+    AndFunc :: Expr Bool -> Expr Bool -> Expr Bool+    NotFunc :: Expr Bool -> Expr Bool++    BoolEqualFunc :: Expr Bool -> Expr Bool -> Expr Bool+    DoubleEqualFunc :: Expr Double -> Expr Double -> Expr Bool+    IntEqualFunc :: Expr Int -> Expr Int -> Expr Bool+    UintEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool+    StringEqualFunc :: Expr String -> Expr String -> Expr Bool+    BytesEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool++    IntListContainsFunc :: Expr Int -> [Expr Int] -> Expr Bool+    StringListContainsFunc :: Expr String -> [Expr String] -> Expr Bool+    UintListContainsFunc :: Expr Uint -> [Expr Uint] -> Expr Bool+    StringContainsFunc :: Expr String -> Expr String -> Expr Bool++    BoolListElemFunc :: [Expr Bool] -> Expr Int -> Expr Bool++    BytesGreaterOrEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool+    DoubleGreaterOrEqualFunc :: Expr Double -> Expr Double -> Expr Bool+    IntGreaterOrEqualFunc :: Expr Int -> Expr Int -> Expr Bool+    UintGreaterOrEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool++    BytesGreaterThanFunc :: Expr Bytes -> Expr Bytes -> Expr Bool+    DoubleGreaterThanFunc :: Expr Double -> Expr Double -> Expr Bool+    IntGreaterThanFunc :: Expr Int -> Expr Int -> Expr Bool+    UintGreaterThanFunc :: Expr Uint -> Expr Uint -> Expr Bool++    StringHasPrefixFunc :: Expr String -> Expr String -> Expr Bool+    StringHasSuffixFunc :: Expr String -> Expr String -> Expr Bool++    BytesLessOrEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool+    DoubleLessOrEqualFunc :: Expr Double -> Expr Double -> Expr Bool+    IntLessOrEqualFunc :: Expr Int -> Expr Int -> Expr Bool+    UintLessOrEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool++    BytesLessThanFunc :: Expr Bytes -> Expr Bytes -> Expr Bool+    DoubleLessThanFunc :: Expr Double -> Expr Double -> Expr Bool+    IntLessThanFunc :: Expr Int -> Expr Int -> Expr Bool+    UintLessThanFunc :: Expr Uint -> Expr Uint -> Expr Bool++    BytesNotEqualFunc :: Expr Bytes -> Expr Bytes -> Expr Bool+    BoolNotEqualFunc :: Expr Bool -> Expr Bool -> Expr Bool+    DoubleNotEqualFunc :: Expr Double -> Expr Double -> Expr Bool+    IntNotEqualFunc :: Expr Int -> Expr Int -> Expr Bool+    StringNotEqualFunc :: Expr String -> Expr String -> Expr Bool+    UintNotEqualFunc :: Expr Uint -> Expr Uint -> Expr Bool++    BytesTypeFunc :: Expr Bytes -> Expr Bool+    BoolTypeFunc :: Expr Bool -> Expr Bool+    DoubleTypeFunc :: Expr Double -> Expr Bool+    IntTypeFunc :: Expr Int -> Expr Bool+    UintTypeFunc :: Expr Uint -> Expr Bool+    StringTypeFunc :: Expr String -> Expr Bool++    RegexFunc :: Expr String -> Expr String -> Expr Bool++    -- Expr Double++    DoubleVariable :: Expr Double++    DoubleListElemFunc :: [Expr Double] -> Expr Int -> Expr Double++    -- Expr Int++    IntVariable :: Expr Int++    IntListElemFunc :: [Expr Int] -> Expr Int -> Expr Int++    BytesListLengthFunc :: [Expr Bytes] -> Expr Int+    BoolListLengthFunc :: [Expr Bool] -> Expr Int+    BytesLengthFunc :: Expr Bytes -> Expr Int+    DoubleListLengthFunc :: [Expr Double] -> Expr Int+    IntListLengthFunc :: [Expr Int] -> Expr Int+    StringListLengthFunc :: [Expr String] -> Expr Int+    UintListLengthFunc :: [Expr Uint] -> Expr Int+    StringLengthFunc :: Expr String -> Expr Int++    -- Expr Uint++    UintVariable :: Expr Uint++    UintListElemFunc :: [Expr Uint] -> Expr Int -> Expr Uint++    -- Expr String++    StringVariable :: Expr String+    StringListElemFunc :: [Expr String] -> Expr Int -> Expr String+    StringToLowerFunc :: Expr String -> Expr String+    StringToUpperFunc :: Expr String -> Expr String++    -- Expr Bytes++    BytesVariable :: Expr Bytes+    +    BytesListElemFunc :: [Expr Bytes] -> Expr Int -> Expr Bytes++deriving instance Eq a => Eq (Expr a)+deriving instance Ord a => Ord (Expr a)+deriving instance Show a => Show (Expr a)++data ValueErr+    = ErrNotABool String+    | ErrNotAString String+    | ErrNotAnInt String+    | ErrNotADouble String+    | ErrNotAnUint String+    | ErrNotBytes String+    deriving (Eq, Ord, Show)++-- |+-- eval evaluates a boolean expression, given an input label.+eval :: Expr Bool -> Label -> Except ValueErr Bool+eval = ev++ev :: Expr a -> Label -> Except ValueErr a++ev (Const b) _ = return b+ev BoolVariable (Bool b) = return b+ev BoolVariable l = throwError $ ErrNotABool $ show l++ev (OrFunc e1 e2) v = (||) <$> ev e1 v <*> ev e2 v++ev (AndFunc e1 e2) v = (&&) <$> ev e1 v <*> ev e2 v++ev (NotFunc e) v = case runExcept $ ev e v of+    (Right True) -> return False+    _ -> return True++ev (BoolEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (DoubleEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (StringEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesEqualFunc e1 e2) v = eq (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (IntListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es++ev (StringListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es++ev (UintListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es++ev (StringContainsFunc s sub) v = isInfixOf <$> ev sub v <*> ev s v++ev (BoolListElemFunc es i) v =+    (!!) <$>+        mapM (`ev` v) es <*>+        ev i v++ev (DoubleGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesGreaterOrEqualFunc e1 e2) v = ge (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (DoubleGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesGreaterThanFunc e1 e2) v = gt (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (StringHasPrefixFunc e1 e2) v = isPrefixOf <$> ev e2 v <*> ev e1 v++ev (StringHasSuffixFunc e1 e2) v = isSuffixOf <$> ev e2 v <*> ev e1 v++ev (DoubleLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesLessOrEqualFunc e1 e2) v = le (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (DoubleLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesLessThanFunc e1 e2) v = lt (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (BoolNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (DoubleNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (IntNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (UintNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (StringNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)+ev (BytesNotEqualFunc e1 e2) v = ne (runExcept $ ev e1 v) (runExcept $ ev e2 v)++ev (BytesTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False+ev (BoolTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False+ev (DoubleTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False+ev (IntTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False+ev (UintTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False+ev (StringTypeFunc e) v = case runExcept $ ev e v of+    (Right _) -> return True+    (Left _) -> return False++ev (RegexFunc e s) v = (=~) <$> ev s v <*> ev e v++ev DoubleVariable (Number r) = return $ fromRational r+ev DoubleVariable l = throwError $ ErrNotADouble $ show l++ev (DoubleListElemFunc es i) v = +    (!!) <$> +        mapM (`ev` v) es <*> +        ev i v++ev IntVariable (Number r) = return (truncate r)+ev IntVariable l = throwError $ ErrNotAnInt $ show l++ev (IntListElemFunc es i) v =+    (!!) <$>+        mapM (`ev` v) es <*>+        ev i v++ev (BytesListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (BoolListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (BytesLengthFunc e) v = length <$> ev e v++ev (DoubleListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (IntListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (StringListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (UintListLengthFunc es) v = length <$> mapM (`ev` v) es++ev (StringLengthFunc e) v = length <$> ev e v++ev UintVariable (Number r) = return $ truncate r+ev UintVariable l = throwError $ ErrNotAnUint $ show l++ev (UintListElemFunc es i) v =+    (!!) <$>+        mapM (`ev` v) es <*>+        ev i v++ev StringVariable (String s) = return s+ev StringVariable l = throwError $ ErrNotAString $ show l++ev (StringListElemFunc es i) v =+    (!!) <$>+        mapM (`ev` v) es <*>+        ev i v++ev (StringToLowerFunc s) v = map toLower <$> ev s v++ev (StringToUpperFunc s) v = map toUpper <$> ev s v++ev BytesVariable (String s) = return s+ev BytesVariable l = throwError $ ErrNotBytes $ show l++ev (BytesListElemFunc es i) v =+    (!!) <$>+        mapM (`ev` v) es <*>+        ev i v++eq :: (Eq a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+eq (Right v1) (Right v2) = return $ v1 == v2+eq (Left _) _ = return False+eq _ (Left _) = return False++ge :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+ge (Right v1) (Right v2) = return $ v1 >= v2+ge (Left _) _ = return False+ge _ (Left _) = return False++gt :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+gt (Right v1) (Right v2) = return $ v1 > v2+gt (Left _) _ = return False+gt _ (Left _) = return False++le :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+le (Right v1) (Right v2) = return $ v1 <= v2+le (Left _) _ = return False+le _ (Left _) = return False++lt :: (Ord a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+lt (Right v1) (Right v2) = return $ v1 < v2+lt (Left _) _ = return False+lt _ (Left _) = return False++ne :: (Eq a) => Either ValueErr a -> Either ValueErr a -> Except ValueErr Bool+ne (Right v1) (Right v2) = return $ v1 /= v2+ne (Left _) _ = return False+ne _ (Left _) = return False++-- |+-- simplifyBoolExpr returns an equivalent, but simpler version of the input boolean expression.+simplifyBoolExpr :: Expr Bool -> Expr Bool+simplifyBoolExpr = simplifyExpr++simplifyExpr :: Expr a -> Expr a+simplifyExpr (BoolEqualFunc (Const b1) (Const b2)) = Const $ b1 == b2+simplifyExpr v@(Const _) = v+simplifyExpr v@BoolVariable = v++simplifyExpr (OrFunc v1 v2) = simplifyOrFunc (simplifyExpr v1) (simplifyExpr v2)+simplifyExpr (AndFunc v1 v2) = simplifyAndFunc (simplifyExpr v1) (simplifyExpr v2)+simplifyExpr (NotFunc v) = simplifyNotFunc (simplifyExpr v)++simplifyExpr (BoolEqualFunc e1 e2) = BoolEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleEqualFunc e1 e2) = DoubleEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntEqualFunc e1 e2) = IntEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintEqualFunc e1 e2) = UintEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (StringEqualFunc e1 e2) = StringEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (BytesEqualFunc e1 e2) = BytesEqualFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (IntListContainsFunc e es) = IntListContainsFunc (simplifyExpr e) (map simplifyExpr es)+simplifyExpr (StringListContainsFunc e es) = StringListContainsFunc (simplifyExpr e) (map simplifyExpr es)+simplifyExpr (UintListContainsFunc e es) = UintListContainsFunc (simplifyExpr e) (map simplifyExpr es)+simplifyExpr (StringContainsFunc e1 e2) = StringContainsFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BoolListElemFunc es e) = BoolListElemFunc (map simplifyExpr es) (simplifyExpr e)++simplifyExpr (BytesGreaterOrEqualFunc e1 e2) = BytesGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleGreaterOrEqualFunc e1 e2) = DoubleGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntGreaterOrEqualFunc e1 e2) = IntGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintGreaterOrEqualFunc e1 e2) = UintGreaterOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BytesGreaterThanFunc e1 e2) = BytesGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleGreaterThanFunc e1 e2) = DoubleGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntGreaterThanFunc e1 e2) = IntGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintGreaterThanFunc e1 e2) = UintGreaterThanFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (StringHasPrefixFunc e1 e2) = StringHasPrefixFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (StringHasSuffixFunc e1 e2) = StringHasSuffixFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BytesLessOrEqualFunc e1 e2) = BytesLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleLessOrEqualFunc e1 e2) = DoubleLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntLessOrEqualFunc e1 e2) = IntLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintLessOrEqualFunc e1 e2) = UintLessOrEqualFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BytesLessThanFunc e1 e2) = BytesLessThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleLessThanFunc e1 e2) = DoubleLessThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntLessThanFunc e1 e2) = IntLessThanFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintLessThanFunc e1 e2) = UintLessThanFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BoolNotEqualFunc e1 e2) = BoolNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (DoubleNotEqualFunc e1 e2) = DoubleNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (IntNotEqualFunc e1 e2) = IntNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (UintNotEqualFunc e1 e2) = UintNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (StringNotEqualFunc e1 e2) = StringNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)+simplifyExpr (BytesNotEqualFunc e1 e2) = BytesNotEqualFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (BytesTypeFunc e) = BytesTypeFunc (simplifyExpr e)+simplifyExpr (BoolTypeFunc e) = BoolTypeFunc (simplifyExpr e)+simplifyExpr (DoubleTypeFunc e) = DoubleTypeFunc (simplifyExpr e)+simplifyExpr (IntTypeFunc e) = IntTypeFunc (simplifyExpr e)+simplifyExpr (UintTypeFunc e) = UintTypeFunc (simplifyExpr e)+simplifyExpr (StringTypeFunc e) = StringTypeFunc (simplifyExpr e)++simplifyExpr (RegexFunc e1 e2) = RegexFunc (simplifyExpr e1) (simplifyExpr e2)++simplifyExpr (DoubleListElemFunc es e) = DoubleListElemFunc (map simplifyExpr es) (simplifyExpr e)++simplifyExpr (IntListElemFunc es e) = IntListElemFunc (map simplifyExpr es) (simplifyExpr e)+simplifyExpr (BytesListLengthFunc es) = Const (length es)+simplifyExpr (BoolListLengthFunc es) = Const (length es)+simplifyExpr (BytesLengthFunc e) = case simplifyExpr e of+        (Const b) -> Const (length b)+        b -> BytesLengthFunc b+simplifyExpr (DoubleListLengthFunc es) = Const (length es)+simplifyExpr (IntListLengthFunc es) = Const (length es)+simplifyExpr (StringListLengthFunc es) = Const (length es)+simplifyExpr (UintListLengthFunc es) = Const (length es)+simplifyExpr (StringLengthFunc e) = case simplifyExpr e of+        (Const b) -> Const (length b)+        b -> StringLengthFunc b++simplifyExpr (UintListElemFunc es e) = UintListElemFunc (map simplifyExpr es) (simplifyExpr e)++simplifyExpr (StringListElemFunc es e) = StringListElemFunc (map simplifyExpr es) (simplifyExpr e)+simplifyExpr (StringToLowerFunc e) = case simplifyExpr e of+        (Const s) -> Const $ map toLower s+        s -> s+simplifyExpr (StringToUpperFunc e) = case simplifyExpr e of+        (Const s) -> Const $ map toUpper s+        s -> s++simplifyExpr (BytesListElemFunc es e) = BytesListElemFunc (map simplifyExpr es) (simplifyExpr e)++simplifyExpr e = e++simplifyOrFunc :: Expr Bool -> Expr Bool -> Expr Bool+simplifyOrFunc true@(Const True) _ = true+simplifyOrFunc _ true@(Const True) = true+simplifyOrFunc (Const False) v = v+simplifyOrFunc v (Const False) = v+simplifyOrFunc v1 v2+    | v1 == v2  = v1+    | v1 == simplifyNotFunc v2 = Const True+    | simplifyNotFunc v1 == v2 = Const True+    | otherwise = OrFunc v1 v2++simplifyAndFunc :: Expr Bool -> Expr Bool -> Expr Bool+simplifyAndFunc (Const True) v = v+simplifyAndFunc v (Const True) = v+simplifyAndFunc false@(Const False) _ = false+simplifyAndFunc _ false@(Const False) = false++simplifyAndFunc v1@(StringEqualFunc s1 s2) (StringEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, StringVariable, Const c2, StringVariable) -> if c1 == c2 then v1 else Const False+    (Const c1, StringVariable, StringVariable, Const c2) -> if c1 == c2 then v1 else Const False+    (StringVariable, Const c1, Const c2, StringVariable) -> if c1 == c2 then v1 else Const False+    (StringVariable, Const c1, StringVariable, Const c2) -> if c1 == c2 then v1 else Const False+simplifyAndFunc v1@(StringEqualFunc s1 s2) (StringNotEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, StringVariable, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, StringVariable, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (StringVariable, Const c1, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False+    (StringVariable, Const c1, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False+simplifyAndFunc v1@(StringNotEqualFunc s1 s2) (StringEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, StringVariable, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, StringVariable, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (StringVariable, Const c1, Const c2, StringVariable) -> if c1 /= c2 then v1 else Const False+    (StringVariable, Const c1, StringVariable, Const c2) -> if c1 /= c2 then v1 else Const False++simplifyAndFunc v1@(IntEqualFunc s1 s2) (IntEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, IntVariable, Const c2, IntVariable) -> if c1 == c2 then v1 else Const False+    (Const c1, IntVariable, IntVariable, Const c2) -> if c1 == c2 then v1 else Const False+    (IntVariable, Const c1, Const c2, IntVariable) -> if c1 == c2 then v1 else Const False+    (IntVariable, Const c1, IntVariable, Const c2) -> if c1 == c2 then v1 else Const False+simplifyAndFunc v1@(IntEqualFunc s1 s2) (IntNotEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, IntVariable, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, IntVariable, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (IntVariable, Const c1, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False+    (IntVariable, Const c1, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False+simplifyAndFunc v1@(IntNotEqualFunc s1 s2) (IntEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, IntVariable, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, IntVariable, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (IntVariable, Const c1, Const c2, IntVariable) -> if c1 /= c2 then v1 else Const False+    (IntVariable, Const c1, IntVariable, Const c2) -> if c1 /= c2 then v1 else Const False++simplifyAndFunc v1@(UintEqualFunc s1 s2) (UintEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, UintVariable, Const c2, UintVariable) -> if c1 == c2 then v1 else Const False+    (Const c1, UintVariable, UintVariable, Const c2) -> if c1 == c2 then v1 else Const False+    (UintVariable, Const c1, Const c2, UintVariable) -> if c1 == c2 then v1 else Const False+    (UintVariable, Const c1, UintVariable, Const c2) -> if c1 == c2 then v1 else Const False+simplifyAndFunc v1@(UintEqualFunc s1 s2) (UintNotEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, UintVariable, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, UintVariable, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (UintVariable, Const c1, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False+    (UintVariable, Const c1, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False+simplifyAndFunc v1@(UintNotEqualFunc s1 s2) (UintEqualFunc s1' s2') = +    case (s1, s2, s1', s2') of+    (Const c1, UintVariable, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False+    (Const c1, UintVariable, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False+    (UintVariable, Const c1, Const c2, UintVariable) -> if c1 /= c2 then v1 else Const False+    (UintVariable, Const c1, UintVariable, Const c2) -> if c1 /= c2 then v1 else Const False++simplifyAndFunc v1 v2+    | v1 == v2  = v1+    | v1 == simplifyNotFunc v2 = Const False+    | simplifyNotFunc v1 == v2 = Const False+    | otherwise = AndFunc v1 v2++simplifyNotFunc :: Expr Bool -> Expr Bool+simplifyNotFunc (NotFunc v) = v+simplifyNotFunc (Const True) = Const False+simplifyNotFunc (Const False) = Const True+simplifyNotFunc (AndFunc e1 e2) = simplifyOrFunc (simplifyNotFunc e1) (simplifyNotFunc e2)+simplifyNotFunc (OrFunc e1 e2) = simplifyAndFunc (simplifyNotFunc e1) (simplifyNotFunc e2)+simplifyNotFunc (BoolEqualFunc e1 e2) = BoolNotEqualFunc e1 e2+simplifyNotFunc (DoubleEqualFunc e1 e2) = DoubleNotEqualFunc e1 e2+simplifyNotFunc (IntEqualFunc e1 e2) = IntNotEqualFunc e1 e2+simplifyNotFunc (UintEqualFunc e1 e2) = UintNotEqualFunc e1 e2+simplifyNotFunc (StringEqualFunc e1 e2) = StringNotEqualFunc e1 e2+simplifyNotFunc (BytesEqualFunc e1 e2) = BytesNotEqualFunc e1 e2+simplifyNotFunc (BoolNotEqualFunc e1 e2) = BoolEqualFunc e1 e2+simplifyNotFunc (DoubleNotEqualFunc e1 e2) = DoubleEqualFunc e1 e2+simplifyNotFunc (IntNotEqualFunc e1 e2) = IntEqualFunc e1 e2+simplifyNotFunc (UintNotEqualFunc e1 e2) = UintEqualFunc e1 e2+simplifyNotFunc (StringNotEqualFunc e1 e2) = StringEqualFunc e1 e2+simplifyNotFunc (BytesNotEqualFunc e1 e2) = BytesEqualFunc e1 e2+simplifyNotFunc v = NotFunc v
+ src/IfExprs.hs view
@@ -0,0 +1,83 @@+-- |+-- This is an internal relapse module.+--+-- It contains multiple implementations of if expressions.++module IfExprs (+    IfExprs, IfExpr, newIfExpr,+    evalIfExprs, compileIfExprs,+    ZippedIfExprs, zipIfExprs, evalZippedIfExprs+) where++import Control.Monad.Except (Except)++import Patterns+import Expr+import Simplify+import Zip+import Parsers++newtype IfExpr = IfExpr (Expr Bool, Pattern, Pattern)++newIfExpr :: Expr Bool -> Pattern -> Pattern -> IfExpr+newIfExpr c t e = IfExpr (c, t, e)++data IfExprs+    = Cond {+        cond :: Expr Bool+        , thn :: IfExprs+        , els :: IfExprs+    }+    | Ret [Pattern]++compileIfExprs :: Refs -> [IfExpr] -> IfExprs+compileIfExprs _ [] = Ret []+compileIfExprs refs (e:es) = let (IfExpr ifExpr) = simplifyIf refs e+    in addIfExpr ifExpr (compileIfExprs refs es)++evalIfExprs :: IfExprs -> Label -> Except ValueErr [Pattern]+evalIfExprs (Ret ps) _ = return ps+evalIfExprs (Cond c t e) l = do {+    b <- eval c l;+    if b then evalIfExprs t l else evalIfExprs e l+}++simplifyIf :: Refs -> IfExpr -> IfExpr+simplifyIf refs (IfExpr (c, t, e)) =+    let scond = simplifyBoolExpr c+        sthn  = simplify refs t+        sels  = simplify refs e+    in if sthn == sels then IfExpr (Const True, sthn, sels) else IfExpr (scond, sthn, sels)++addIfExpr :: (Expr Bool, Pattern, Pattern) -> IfExprs -> IfExprs+addIfExpr (c, t, e) (Ret ps) =+    Cond c (Ret (t:ps)) (Ret (e:ps))+addIfExpr (c, t, e) (Cond cs ts es)+    | c == cs = Cond cs (addRet t ts) (addRet e es)+    | Const False == simplifyBoolExpr (AndFunc c cs) = Cond cs (addRet e ts) (addIfExpr (c, t, e) es)+    | Const False == simplifyBoolExpr (AndFunc (NotFunc c) cs) = Cond cs (addIfExpr (c, t, e) ts) (addRet t es)+    | otherwise = Cond cs (addIfExpr (c, t, e) ts) (addIfExpr (c, t, e) es)++addRet :: Pattern -> IfExprs -> IfExprs+addRet p (Ret ps) = Ret (p:ps)+addRet p (Cond c t e) = Cond c (addRet p t) (addRet p e)++data ZippedIfExprs+    = ZippedCond {+        zcond :: Expr Bool+        , zthn :: ZippedIfExprs+        , zels :: ZippedIfExprs+    }+    | ZippedRet [Pattern] Zipper++zipIfExprs :: IfExprs -> ZippedIfExprs+zipIfExprs (Cond c t e) = ZippedCond c (zipIfExprs t) (zipIfExprs e)+zipIfExprs (Ret ps) = let (zps, zs) = zippy ps in ZippedRet zps zs++evalZippedIfExprs :: ZippedIfExprs -> Label -> Except ValueErr ([Pattern], Zipper)+evalZippedIfExprs (ZippedRet ps zs) _ = return (ps, zs)+evalZippedIfExprs (ZippedCond c t e) v = do {+    b <- eval c v;+    if b then evalZippedIfExprs t v else evalZippedIfExprs e v+}+
+ src/Json.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- This module contains the Json Parser.++module Json (+    decodeJSON, JsonTree+) where++import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject)++import qualified Data.Tree as DataTree+import Parsers++instance Tree JsonTree where+    getLabel (DataTree.Node l _) = l+    getChildren (DataTree.Node _ cs) = cs++-- |+-- JsonTree is a tree that can be validated by Relapse.+type JsonTree = DataTree.Tree Label++-- |+-- decodeJSON returns a JsonTree, given an input string.+decodeJSON :: String -> Either String [JsonTree]+decodeJSON s = case decode s of+    (Error e) -> Left e+    (Ok v) -> Right (uValue v)++uValue :: JSValue -> [JsonTree]+uValue JSNull = []+uValue (JSBool b) = [DataTree.Node (Bool b) []]+uValue (JSRational _ r) = [DataTree.Node (Number r) []]+uValue (JSString s) = [DataTree.Node (String (fromJSString s)) []]+uValue (JSArray vs) = uArray 0 vs+uValue (JSObject o) = uObject $ fromJSObject o++uArray :: Int -> [JSValue] -> [JsonTree]+uArray _ [] = []+uArray index (v:vs) = DataTree.Node (Number (toRational index)) (uValue v):uArray (index+1) vs++uObject :: [(String, JSValue)] -> [JsonTree]+uObject = map uKeyValue++uKeyValue :: (String, JSValue) -> JsonTree+uKeyValue (name, value) = DataTree.Node (String name) (uValue value)
+ src/MemDerive.hs view
@@ -0,0 +1,97 @@+-- |+-- This module is an efficient implementation of the derivative algorithm for trees.+--+-- It is intended to be used for production purposes.+--+-- This means that it gives up some readability for speed.+--+-- This module provides memoization of the nullable, calls and returns functions.++module MemDerive (+    derive, Mem, newMem, nullable, validate+) where++import qualified Data.Map.Strict as M+import Control.Monad.State (State, runState, lift, state)+import Control.Monad.Except (ExceptT, runExceptT, Except, throwError, runExcept)++import qualified Derive+import qualified Patterns+import Patterns (Refs, Pattern)+import IfExprs+import Expr+import Zip+import Parsers++mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)+mem f k m+    | M.member k m = (m M.! k, m)+    | otherwise = let res = f k+        in (res, M.insert k res m)++type Nullable = M.Map Pattern Bool+type Calls = M.Map [Pattern] IfExprs+type Returns = M.Map ([Pattern], [Bool]) [Pattern]++-- |+-- Mem is the object used to store memoized results of the nullable, calls and returns functions.+newtype Mem = Mem (Nullable, Calls, Returns)++-- |+-- newMem creates a object used for memoization by the validate function.+-- Each grammar should create its own memoize object.+newMem :: Mem+newMem = Mem (M.empty, M.empty, M.empty)++-- |+-- nullable returns whether a pattern is nullable and memoizes the results.+nullable :: Refs -> Pattern -> State Mem Bool+nullable refs k = state $ \(Mem (n, c, r)) -> let (v', n') = mem (Patterns.nullable refs) k n;+    in (v', Mem (n', c, r))++calls :: Refs -> [Pattern] -> State Mem IfExprs+calls refs k = state $ \(Mem (n, c, r)) -> let (v', c') = mem (Derive.calls refs) k c;+    in (v', Mem (n, c', r))++returns :: Refs -> ([Pattern], [Bool]) -> State Mem [Pattern]+returns refs k = state $ \(Mem (n, c, r)) -> let (v', r') = mem (Derive.returns refs) k r;+    in (v', Mem (n, c, r'))++mderive :: Tree t => Refs -> [Pattern] -> [t] -> ExceptT ValueErr (State Mem) [Pattern]+mderive _ ps [] = return ps+mderive refs ps (tree:ts) = do {+    ifs <- lift $ calls refs ps;+    childps <- case runExcept $ evalIfExprs ifs (getLabel tree) of+        (Left l) -> throwError l+        (Right r) -> return r+    ;+    (zchildps, zipper) <- return $ zippy childps;+    childres <- mderive refs zchildps (getChildren tree);+    nulls <- lift $ mapM (nullable refs) childres;+    let unzipns = unzipby zipper nulls+    ;+    rs <- lift $ returns refs (ps, unzipns);+    mderive refs rs ts+}++-- |+-- derive is the classic derivative implementation for trees.+derive :: Tree t => Refs -> [t] -> Except String Pattern+derive refs ts =+    let start = [Patterns.lookupRef refs "main"]+        (res, _) = runState (runExceptT $ mderive refs start ts) newMem+    in case res of+        (Left l) -> throwError $ show l+        (Right [r]) -> return r+        (Right rs) -> throwError $ "not a single pattern: " ++ show rs++-- |+-- validate is the uses the derivative implementation for trees and+-- return whether tree is valid, given the input grammar and start pattern.+validate :: Tree t => Refs -> Pattern -> [t] -> (State Mem) Bool+validate refs start tree = do {+        rs <- runExceptT (mderive refs [start] tree);+        case rs of+        (Right [r]) -> nullable refs r+        _ -> return False+    }
+ src/ParsePatterns.hs view
@@ -0,0 +1,418 @@+{-#LANGUAGE GADTs #-}++-- |+-- This is an internal relapse module.+--+-- It contains relapse grammar parsing helper functions and+--+-- it also contains a parser for the JSON serialized relapse AST.++module ParsePatterns (+    ParsedExpr(..), newBuiltIn, newFunction, fromJson+) where++import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject)++import Patterns+import Expr++data ParsedExpr +    = BoolExpr (Expr Bool)+    | DoubleExpr (Expr Double)+    | IntExpr (Expr Int)+    | UintExpr (Expr Uint)+    | StringExpr (Expr String)+    | BytesExpr (Expr Bytes)+    | BoolListExpr [Expr Bool]+    | DoubleListExpr [Expr Double]+    | IntListExpr [Expr Int]+    | UintListExpr [Expr Uint]+    | StringListExpr [Expr String]+    | BytesListExpr [Expr Bytes]+    deriving Show++-- |+-- fromJson parses the relapse AST that has been serialized to JSON.+fromJson :: String -> Either String Refs+fromJson s = unmarshal $ decode s++unmarshal :: Result JSValue -> Either String Refs+unmarshal (Error err) = fail err+unmarshal (Ok (JSObject o)) = uRefs $ fromJSObject o+unmarshal (Ok j) = fail $ "unexpected jsvalue = " ++ show j++uRefs :: [(String, JSValue)] -> Either String Refs+uRefs [] = return emptyRef+uRefs (("TopPattern", JSObject pattern):pairs) = do {+    p <- uPattern (fromJSObject pattern);+    rs <- uRefs pairs;+    return $ newRef "main" p `union` rs+}+uRefs (("PatternDecls", JSArray patternDecls):pairs) = do {+    p <- uPatternDecls patternDecls;+    rs <- uRefs pairs;+    return $ p `union` rs+}+uRefs (_:pairs) = uRefs pairs++uPatternDecls :: [JSValue] -> Either String Refs+uPatternDecls [] = return emptyRef+uPatternDecls (JSObject o:patternDecls) = do {+    left <- uPatternDecl (fromJSObject o);+    right <- uPatternDecls patternDecls;+    return $ left `union` right+}++uPatternDecl :: [(String, JSValue)] -> Either String Refs+uPatternDecl kvs = do {+    name <- getString kvs "Name";+    p <- getObject kvs "Pattern";+    pattern <- uPattern p;+    return $ newRef name pattern+}++uPattern :: [(String, JSValue)] -> Either String Pattern+uPattern [("Empty", _)] = return Empty+uPattern [("TreeNode", JSObject o)] = uTreeNode (fromJSObject o)+uPattern [("LeafNode", JSObject o)] = uLeafNode (fromJSObject o)+uPattern [("Concat", JSObject o)] = uLeftRight Concat (fromJSObject o)+uPattern [("Or", JSObject o)] = uLeftRight Or (fromJSObject o)+uPattern [("And", JSObject o)] = uLeftRight And (fromJSObject o)+uPattern [("ZeroOrMore", JSObject o)] = uZeroOrMore (fromJSObject o)+uPattern [("Reference", JSObject o)] = uReference (fromJSObject o)+uPattern [("Not", JSObject o)] = uNot (fromJSObject o)+uPattern [("ZAny", JSObject o)] = return ZAny+uPattern [("Contains", JSObject o)] = uContains (fromJSObject o)+uPattern [("Optional", JSObject o)] = uOptional (fromJSObject o)+uPattern [("Interleave", JSObject o)] = uLeftRight Interleave (fromJSObject o)++uTreeNode :: [(String, JSValue)] -> Either String Pattern+uTreeNode kvs = do {+    name <- getObject kvs "Name";+    nameExpr <- uNameExpr name;+    p <- getObject kvs "Pattern";+    pattern <- uPattern p;+    return $ Node nameExpr pattern+}++uLeafNode :: [(String, JSValue)] -> Either String Pattern+uLeafNode kvs = flip Node Empty <$> (getObject kvs "Expr" >>= uBoolExpr)++uReference :: [(String, JSValue)] -> Either String Pattern+uReference kvs = Reference <$> getString kvs "Name"++uLeftRight :: (Pattern -> Pattern -> Pattern) -> [(String, JSValue)] -> Either String Pattern+uLeftRight combine kvs = do {+    left <- getObject kvs "LeftPattern";+    leftPattern <- uPattern left;+    right <- getObject kvs "RightPattern";+    rightPattern <- uPattern right;+    return $ combine leftPattern rightPattern+}++uZeroOrMore :: [(String, JSValue)] -> Either String Pattern+uZeroOrMore kvs = ZeroOrMore <$> (getObject kvs "Pattern" >>= uPattern)++uNot :: [(String, JSValue)] -> Either String Pattern+uNot kvs = Not <$> (getObject kvs "Pattern" >>= uPattern)++uContains :: [(String, JSValue)] -> Either String Pattern+uContains kvs = Contains <$> (getObject kvs "Pattern" >>= uPattern)++uOptional :: [(String, JSValue)] -> Either String Pattern+uOptional kvs = Optional <$> (getObject kvs "Pattern" >>= uPattern)++uNameExpr :: [(String, JSValue)] -> Either String (Expr Bool)+uNameExpr [("Name", JSObject o)] = return $ uName (fromJSObject o)+uNameExpr [("AnyName", JSObject o)] = return $ Const True+uNameExpr [("AnyNameEither", JSObject o)] = uNameEither (fromJSObject o)+uNameExpr [("NameChoice", JSObject o)] = uNameChoice (fromJSObject o)++uName :: [(String, JSValue)] -> Expr Bool+uName kvs = uName' $ head $ filter (\(k,v) -> (k /= "Before")) kvs++uName' :: (String, JSValue) -> Expr Bool+uName' ("DoubleValue", JSRational _ num) = DoubleEqualFunc (Const (fromRational num)) DoubleVariable+uName' ("IntValue", JSRational _ num) = IntEqualFunc (Const $ truncate num) IntVariable+uName' ("UintValue", JSRational _ num) = UintEqualFunc (Const $ truncate num) UintVariable+uName' ("BoolValue", JSBool b) = BoolEqualFunc (Const b) BoolVariable+uName' ("StringValue", JSString s) = StringEqualFunc (Const $ fromJSString s) StringVariable+uName' ("BytesValue", JSString s) = BytesEqualFunc (Const $ fromJSString s) BytesVariable++uNameEither :: [(String, JSValue)] -> Either String (Expr Bool)+uNameEither kvs = NotFunc <$> (getObject kvs "Either" >>= uNameExpr)++uNameChoice :: [(String, JSValue)] -> Either String (Expr Bool)+uNameChoice kvs = do {+    left <- getObject kvs "Left";+    leftName <- uNameExpr left;+    right <- getObject kvs "Right";+    rightName <- uNameExpr right;+    return $ OrFunc leftName rightName+}++uBoolExpr :: [(String, JSValue)] -> Either String (Expr Bool)+uBoolExpr kvs = uExprs kvs >>= (\e ->+    case e of+        (BoolExpr v) -> return v+        _ -> fail $ "not a BoolExpr, but a " ++ show e+    )++uDoubleExpr :: [(String, JSValue)] -> Either String (Expr Double)+uDoubleExpr kvs = uExprs kvs >>= (\e ->+    case e of+        (DoubleExpr v) -> return v+        _ -> fail $ "not a DoubleExpr, but a " ++ show e+    )++uIntExpr :: [(String, JSValue)] -> Either String (Expr Int)+uIntExpr kvs = uExprs kvs >>= (\e ->+    case e of+        (IntExpr v) -> return v+        _ -> fail $ "not a IntExpr, but a " ++ show e+    )++uUintExpr :: [(String, JSValue)] -> Either String (Expr Uint)+uUintExpr kvs = uExprs kvs >>= (\e -> +    case e of+        (UintExpr v) -> return v+        _ -> fail $ "not a UintExpr, but a " ++ show e+    )++uStringExpr :: [(String, JSValue)] -> Either String (Expr String)+uStringExpr kvs = uExprs kvs >>= (\e -> +    case e of+        (StringExpr v) -> return v+        _ -> fail $ "not a StringExpr, but a " ++ show e+    )++uBytesExpr :: [(String, JSValue)] -> Either String (Expr Bytes)+uBytesExpr kvs = uExprs kvs >>= (\e -> +    case e of+        (BytesExpr v) -> return v+        _ -> fail $ "not a BytesExpr, but a " ++ show e+    )++uExprs :: [(String, JSValue)] -> Either String ParsedExpr+uExprs kvs = uExpr $ head $ filter (\(k,v) -> k /= "RightArrow" && k /= "Comma") kvs ++uExpr :: (String, JSValue) -> Either String ParsedExpr+uExpr ("Terminal", JSObject o) = return $ uTerminals $ fromJSObject o+uExpr ("List", JSObject o) = uList $ fromJSObject o+uExpr ("Function", JSObject o) = uFunction $ fromJSObject o+uExpr ("BuiltIn", JSObject o) = uBuiltIn $ fromJSObject o++uTerminals :: [(String, JSValue)] -> ParsedExpr+uTerminals kvs = uTerminal $ head $ filter (\(k,v) -> k /= "Before" && k /= "Literal") kvs++uTerminal :: (String, JSValue) -> ParsedExpr+uTerminal ("DoubleValue", JSRational _ n) = DoubleExpr (Const (fromRational n))+uTerminal ("IntValue", JSRational _ n) = IntExpr (Const $ truncate n)+uTerminal ("UintValue", JSRational _ n) = UintExpr (Const $ truncate n)+uTerminal ("BoolValue", JSBool b) = BoolExpr (Const b)+uTerminal ("StringValue", JSString s) = StringExpr (Const $ fromJSString s)+uTerminal ("BytesValue", JSString s) = BytesExpr (Const $ fromJSString s) -- TODO bytes+uTerminal ("Variable", JSObject o) = uVariable $ fromJSObject o++uVariable :: [(String, JSValue)] -> ParsedExpr+uVariable [("Type", JSRational _ 101)] = DoubleExpr DoubleVariable+uVariable [("Type", JSRational _ 103)] = IntExpr IntVariable+uVariable [("Type", JSRational _ 104)] = UintExpr UintVariable+uVariable [("Type", JSRational _ 108)] = BoolExpr BoolVariable+uVariable [("Type", JSRational _ 109)] = StringExpr StringVariable+uVariable [("Type", JSRational _ 112)] = BytesExpr BytesVariable++uList :: [(String, JSValue)] -> Either String ParsedExpr+uList kvs = do {+    arr <- getArrayOfObjects kvs "Elems";+    typ <- getInt kvs "Type";+    case typ of+    101 -> DoubleListExpr <$> mapM uDoubleExpr arr+    103 -> IntListExpr <$> mapM uIntExpr arr+    104 -> UintListExpr <$> mapM uUintExpr arr+    108 -> BoolListExpr <$> mapM uBoolExpr arr+    109 -> StringListExpr <$> mapM uStringExpr arr+    112 -> BytesListExpr <$> mapM uBytesExpr arr+    201 -> DoubleListExpr <$> mapM uDoubleExpr arr+    203 -> IntListExpr <$> mapM uIntExpr arr+    204 -> UintListExpr <$> mapM uUintExpr arr+    208 -> BoolListExpr <$> mapM uBoolExpr arr+    209 -> StringListExpr <$> mapM uStringExpr arr+    212 -> BytesListExpr <$> mapM uBytesExpr arr+}++uFunction :: [(String, JSValue)] -> Either String ParsedExpr+uFunction kvs = do {+    name <- getString kvs "Name";+    arrayObjects <- getArrayOfObjects kvs "Params";+    exprs <- mapM uExprs arrayObjects;+    newFunction name exprs+}++-- |+-- newFunction parsers a relapse function to a relapse expression.+newFunction :: String -> [ParsedExpr] -> Either String ParsedExpr+newFunction "not" [BoolExpr b] = Right $ BoolExpr $ NotFunc b+newFunction "and" [BoolExpr b1, BoolExpr b2] = Right $ BoolExpr $ AndFunc b1 b2+newFunction "or" [BoolExpr b1, BoolExpr b2] = Right $ BoolExpr $ OrFunc b1 b2++newFunction "contains" [IntExpr i,IntListExpr is] = Right $ BoolExpr $ IntListContainsFunc i is+newFunction "contains" [StringExpr s, StringListExpr ss] = Right $ BoolExpr $ StringListContainsFunc s ss+newFunction "contains" [UintExpr u, UintListExpr us] = Right $ BoolExpr $ UintListContainsFunc u us+newFunction "contains" [StringExpr s, StringExpr ss] = Right $ BoolExpr $ StringContainsFunc s ss++newFunction "elem" [BytesListExpr es, IntExpr i] = Right $ BytesExpr $ BytesListElemFunc es i+newFunction "elem" [BoolListExpr es, IntExpr i] = Right $ BoolExpr $ BoolListElemFunc es i+newFunction "elem" [DoubleListExpr es, IntExpr i] = Right $ DoubleExpr $ DoubleListElemFunc es i+newFunction "elem" [IntListExpr es, IntExpr i] = Right $ IntExpr $ IntListElemFunc es i+newFunction "elem" [StringListExpr es, IntExpr i] = Right $ StringExpr $ StringListElemFunc es i+newFunction "elem" [UintListExpr es, IntExpr i] = Right $ UintExpr $ UintListElemFunc es i++newFunction "eq" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesEqualFunc v1 v2+newFunction "eq" [BoolExpr v1, BoolExpr v2] = Right $ BoolExpr $ BoolEqualFunc v1 v2+newFunction "eq" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleEqualFunc v1 v2+newFunction "eq" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntEqualFunc v1 v2+newFunction "eq" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringEqualFunc v1 v2+newFunction "eq" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintEqualFunc v1 v2++newFunction "eqFold" _ = Left "eqFold function is not supported"++newFunction "ge" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesGreaterOrEqualFunc v1 v2+newFunction "ge" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleGreaterOrEqualFunc v1 v2+newFunction "ge" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntGreaterOrEqualFunc v1 v2+newFunction "ge" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintGreaterOrEqualFunc v1 v2++newFunction "gt" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesGreaterThanFunc v1 v2+newFunction "gt" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleGreaterThanFunc v1 v2+newFunction "gt" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntGreaterThanFunc v1 v2+newFunction "gt" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintGreaterThanFunc v1 v2++newFunction "hasPrefix" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringHasPrefixFunc v1 v2+newFunction "hasSuffix" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringHasSuffixFunc v1 v2++newFunction "le" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesLessOrEqualFunc v1 v2+newFunction "le" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleLessOrEqualFunc v1 v2+newFunction "le" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntLessOrEqualFunc v1 v2+newFunction "le" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintLessOrEqualFunc v1 v2++newFunction "length" [BytesListExpr vs] = Right $ IntExpr $ BytesListLengthFunc vs+newFunction "length" [BoolListExpr vs] = Right $ IntExpr $ BoolListLengthFunc vs+newFunction "length" [BytesExpr vs] = Right $ IntExpr $ BytesLengthFunc vs+newFunction "length" [DoubleListExpr vs] = Right $ IntExpr $ DoubleListLengthFunc vs+newFunction "length" [IntListExpr vs] = Right $ IntExpr $ IntListLengthFunc vs+newFunction "length" [StringListExpr vs] = Right $ IntExpr $ StringListLengthFunc vs+newFunction "length" [UintListExpr vs] = Right $ IntExpr $ UintListLengthFunc vs+newFunction "length" [StringExpr vs] = Right $ IntExpr $ StringLengthFunc vs++newFunction "lt" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesLessThanFunc v1 v2+newFunction "lt" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleLessThanFunc v1 v2+newFunction "lt" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntLessThanFunc v1 v2+newFunction "lt" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintLessThanFunc v1 v2++newFunction "ne" [BytesExpr v1, BytesExpr v2] = Right $ BoolExpr $ BytesNotEqualFunc v1 v2+newFunction "ne" [BoolExpr v1, BoolExpr v2] = Right $ BoolExpr $ BoolNotEqualFunc v1 v2+newFunction "ne" [DoubleExpr v1, DoubleExpr v2] = Right $ BoolExpr $ DoubleNotEqualFunc v1 v2+newFunction "ne" [IntExpr v1, IntExpr v2] = Right $ BoolExpr $ IntNotEqualFunc v1 v2+newFunction "ne" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ StringNotEqualFunc v1 v2+newFunction "ne" [UintExpr v1, UintExpr v2] = Right $ BoolExpr $ UintNotEqualFunc v1 v2++newFunction "now" _ = Left "now function is not supported"++newFunction "print" _ = Left "print function is not supported"++newFunction "range" _ = Left "range function is not supported"++newFunction "toLower" [StringExpr s] = Right $ StringExpr $ StringToLowerFunc s+newFunction "toUpper" [StringExpr s] = Right $ StringExpr $ StringToUpperFunc s++newFunction "type" [BytesExpr b] = Right $ BoolExpr $ BytesTypeFunc b+newFunction "type" [BoolExpr b] = Right $ BoolExpr $ BoolTypeFunc b+newFunction "type" [DoubleExpr b] = Right $ BoolExpr $ DoubleTypeFunc b+newFunction "type" [IntExpr b] = Right $ BoolExpr $ IntTypeFunc b+newFunction "type" [UintExpr b] = Right $ BoolExpr $ UintTypeFunc b+newFunction "type" [StringExpr b] = Right $ BoolExpr $ StringTypeFunc b++newFunction "regex" [StringExpr v1, StringExpr v2] = Right $ BoolExpr $ RegexFunc v1 v2++newFunction s t = Left $ "unknown function: " ++ s ++ " for types: " ++ show t++uBuiltIn :: [(String, JSValue)] -> Either String ParsedExpr+uBuiltIn kvs = do {+    exprObject <- getObject kvs "Expr";+    symbolObject <- getObject kvs "Symbol";+    symbol <- getString symbolObject "Value";+    exprs <- uExprs exprObject;+    newBuiltIn symbol exprs;+}++-- |+-- newBuiltIn parsers a builtin function to a relapse expression.+newBuiltIn :: String -> ParsedExpr -> Either String ParsedExpr+newBuiltIn symbol constExpr = funcName symbol >>= (\name ->+        if name /= "type" then+            newFunction name [constToVar constExpr, constExpr]+        else+            newFunction name [constExpr]+    )++constToVar :: ParsedExpr -> ParsedExpr+constToVar (BoolExpr Const{}) = BoolExpr BoolVariable+constToVar (DoubleExpr Const{}) = DoubleExpr DoubleVariable+constToVar (IntExpr Const{}) = IntExpr IntVariable+constToVar (UintExpr Const{}) = UintExpr UintVariable+constToVar (BytesExpr Const{}) = BytesExpr BytesVariable+constToVar (StringExpr Const{}) = StringExpr StringVariable++funcName :: String -> Either String String+funcName "==" = return "eq"+funcName "!=" = return "ne"+funcName "<" = return "lt"+funcName ">" = return "gt"+funcName "<=" = return "le"+funcName ">=" = return "ge"+funcName "~=" = return "regex"+funcName "*=" = return "contains"+funcName "^=" = return "hasPrefix"+funcName "$=" = return "hasSuffix"+funcName "::" = return "type"+funcName name = fail $ "unexpected funcName: <" ++ name ++ ">"++-- JSON helper functions++getField :: [(String, JSValue)] -> String -> Either String JSValue+getField pairs name = let filtered = filter (\(k,_) -> (k == name)) pairs+    in case filtered of+    [] -> fail $ "no field with name: " ++ name+    vs -> return $ snd $ head vs++getString :: [(String, JSValue)] -> String -> Either String String+getString pairs name = getField pairs name >>= (\v -> +    case v of+        (JSString s) -> return $ fromJSString s+        _ -> fail $ name ++ " is not a JSString, but a " ++ show v+    )++getInt :: [(String, JSValue)] -> String -> Either String Int+getInt pairs name = getField pairs name >>= (\v ->+    case v of+        (JSRational _ n) -> return $ truncate n+        _ -> fail $ name ++ " is not a JSRational, but a " ++ show v+    )++getArrayOfObjects :: [(String, JSValue)] -> String -> Either String [[(String, JSValue)]]+getArrayOfObjects pairs name = getField pairs name >>= (\v ->+    case v of+        (JSArray vs) -> mapM assertObject vs+        _ -> fail $ name ++ " is not a JSArray, but a " ++ show v+    )++assertObject :: JSValue -> Either String [(String, JSValue)]+assertObject (JSObject o) = return $ fromJSObject o+assertObject v = fail $ "not an JSObject, but a " ++ show v++getObject :: [(String, JSValue)] -> String -> Either String [(String, JSValue)]+getObject pairs name = getField pairs name >>= (\v -> +    case v of+        (JSObject o) -> return $ fromJSObject o+        _ -> fail $ name ++ " is not an JSObject, but a " ++ show v+    )
+ src/Parser.hs view
@@ -0,0 +1,366 @@+-- |+-- This module parses the Relapse Grammar using the Parsec Library.++module Parser (+    -- * Parse Grammar+    parseGrammar+    -- * Internal functions+    -- | These functions are exposed for testing purposes.+    , grammar, pattern, nameExpr, expr, +    idLit, bytesCastLit, stringLit, doubleCastLit, uintCastLit, intLit, ws+) where++import Text.ParserCombinators.Parsec+import Numeric (readDec, readOct, readHex, readFloat)+import Data.Char (chr)++import Expr+import Patterns+import ParsePatterns++-- | parseGrammar parses the Relapse Grammar.+parseGrammar :: String -> Either ParseError Refs+parseGrammar = parse (grammar <* eof) ""++infixl 4 <++>+(<++>) :: CharParser () String -> CharParser () String -> CharParser () String+f <++> g = (++) <$> f <*> g++infixr 5 <::>+(<::>) :: CharParser () Char -> CharParser () String -> CharParser () String+f <::> g = (:) <$> f <*> g++empty :: CharParser () String+empty = return ""++opt :: CharParser () Char -> CharParser () String+opt p = (:"") <$> p <|> empty++_lineComment :: CharParser () ()+_lineComment = char '/' *> many (noneOf "\n") <* char '\n' *> return ()++_blockComment :: CharParser () ()+_blockComment = char '*' *> many (noneOf "*") <* char '*' <* char '/' *> return ()++_comment :: CharParser () ()+_comment = char '/' *> (_lineComment <|> _blockComment)++_ws :: CharParser () ()+_ws = _comment <|> () <$ space++ws :: CharParser () ()+ws = () <$ many _ws++bool :: CharParser () Bool+bool = True <$ string "true"+    <|> False <$ string "false"++_decimalLit :: CharParser () Int+_decimalLit = oneOf "123456789" <::> many digit >>= _read readDec++_octalLit :: CharParser () Int+_octalLit = many1 octDigit >>= _read readOct++_hexLit :: CharParser () Int+_hexLit = many1 hexDigit >>= _read readHex++_read :: ReadS a -> String -> CharParser () a+_read read s = case read s of+    [(n, "")]   -> return n+    ((n, ""):_) -> return n+    _           -> fail "digit"++_optionalSign :: (Num a) => CharParser () a+_optionalSign = -1 <$ char '-' <|> return 1++_signedIntLit :: CharParser () Int+_signedIntLit = (*) <$> _optionalSign <*> _intLit++_intLit :: CharParser () Int+_intLit = _decimalLit +    <|> char '0' *> (_octalLit +                    <|> (oneOf "xX" *> _hexLit)+                    <|> return 0+    )++intLit :: CharParser () Int+intLit = string "int(" *> _signedIntLit <* char ')'+    <|> _signedIntLit+    <?> "int_lit"++uintCastLit :: CharParser () Int+uintCastLit = string "uint(" *> _intLit <* char ')'++_exponent :: CharParser () String+_exponent = oneOf "eE" <::> opt (oneOf "+-") <++> many1 digit++_floatLit :: CharParser () Double+_floatLit = do+    i <- many1 digit+    e <- _exponent +        <|> ((string "." <|> empty) <++> +            (_exponent +            <|> many1 digit <++> +                (_exponent+                <|> empty)+            )+        ) +        <|> empty+    _read readFloat (i ++ e)++doubleCastLit :: CharParser () Double+doubleCastLit = string "double(" *> ((*) <$> _optionalSign <*> _floatLit) <* char ')'++idLit :: CharParser () String+idLit = (letter <|> char '_') <::> many (alphaNum <|> char '_')++_qualid :: CharParser () String+_qualid = idLit <++> (concat <$> many (char '.' <::> idLit))++_bigUValue :: CharParser () Char+_bigUValue = char 'U' *> do {+    hs <- count 8 hexDigit;+    n <- _read readHex hs;+    return $ toEnum n+}++_littleUValue :: CharParser () Char+_littleUValue = char 'u' *> do { +    hs <- count 4 hexDigit;+    n <- _read readHex hs;+    return $ toEnum n+}++_escapedChar :: CharParser () Char+_escapedChar = choice (zipWith (\c r -> r <$ char c) "abnfrtv'\\\"/" "\a\b\n\f\r\t\v\'\\\"/")++_unicodeValue :: CharParser () Char+_unicodeValue = (char '\\' *> +    (_bigUValue +        <|> _littleUValue +        <|> _hexByteUValue +        <|> _escapedChar+        <|> _octalByteUValue)+    ) <|> noneOf "\\\""++_interpretedString :: CharParser () String+_interpretedString = between (char '"') (char '"') (many _unicodeValue)++_rawString :: CharParser () String+_rawString = between (char '`') (char '`') (many $ noneOf "`")++stringLit :: CharParser () String+stringLit = _rawString <|> _interpretedString++_hexByteUValue :: CharParser () Char+_hexByteUValue = char 'x' *> do {+    hs <- count 2 hexDigit;+    n <- _read readHex hs;+    return $ chr n+}++_octalByteUValue :: CharParser () Char+_octalByteUValue = do {+    os <- count 3 octDigit;+    n <- _read readOct os;+    return $ toEnum n+}++_byteLit :: CharParser () Char+_byteLit = do {+    i <- _intLit;+    if i > 255 then+        fail $ "too large for byte: " ++ show i+    else+        return $ chr i+}++_byteElem :: CharParser () Char+_byteElem = _byteLit <|> between (char '\'') (char '\'') (_unicodeValue <|> _octalByteUValue <|> _hexByteUValue)++bytesCastLit :: CharParser () String+bytesCastLit = string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}'++_literal :: CharParser () ParsedExpr+_literal = BoolExpr . Const <$> bool+    <|> IntExpr . Const <$> intLit+    <|> UintExpr . Const <$> uintCastLit+    <|> DoubleExpr . Const <$> doubleCastLit+    <|> StringExpr . Const <$> stringLit+    <|> BytesExpr . Const <$> bytesCastLit++_terminal :: CharParser () ParsedExpr+_terminal = (char '$' *> (+    BoolExpr BoolVariable <$ string "bool"+    <|> IntExpr IntVariable <$ string "int"+    <|> UintExpr UintVariable <$ string "uint"+    <|> DoubleExpr DoubleVariable <$ string "double"+    <|> StringExpr StringVariable <$ string "string"+    <|> BytesExpr BytesVariable <$ string "[]byte" ))+    <|> _literal++_builtinSymbol :: CharParser () String+_builtinSymbol = string "==" +    <|> string "!=" +    <|> char '<' <::> opt (char '=')+    <|> char '>' <::> opt (char '=')+    <|> string "~="+    <|> string "*="+    <|> string "^="+    <|> string "$="+    <|> string "::"++check :: Either String ParsedExpr -> CharParser () ParsedExpr+check (Right r) = return r+check (Left l) = fail l++_builtin :: CharParser () ParsedExpr+_builtin = newBuiltIn <$> _builtinSymbol <*> (ws *> _expr) >>= check++_function :: CharParser () ParsedExpr+_function = newFunction <$> idLit <*> (char '(' *> sepBy (ws *> _expr <* ws) (char ',') <* char ')') >>= check++_listType :: CharParser () String+_listType = string "[]" <++> (+    string "bool"+    <|> string "int"+    <|> string "uint"+    <|> string "double"+    <|> string "string"+    <|> string "[]byte" )++_mustBool :: ParsedExpr -> CharParser () (Expr Bool)+_mustBool (BoolExpr e) = return e+_mustBool e = fail $ "want BoolExpr, got: " ++ show e++_mustInt :: ParsedExpr -> CharParser () (Expr Int)+_mustInt (IntExpr e) = return e+_mustInt e = fail $ "want IntExpr, got: " ++ show e++_mustUint :: ParsedExpr -> CharParser () (Expr Uint)+_mustUint (UintExpr e) = return e+_mustUint e = fail $ "want UintExpr, got: " ++ show e++_mustDouble :: ParsedExpr -> CharParser () (Expr Double)+_mustDouble (DoubleExpr e) = return e+_mustDouble e = fail $ "want DoubleExpr, got: " ++ show e++_mustString :: ParsedExpr -> CharParser () (Expr String)+_mustString (StringExpr e) = return e+_mustString e = fail $ "want StringExpr, got: " ++ show e++_mustBytes :: ParsedExpr -> CharParser () (Expr Bytes)+_mustBytes (BytesExpr e) = return e+_mustBytes e = fail $ "want BytesExpr, got: " ++ show e++newList :: String -> [ParsedExpr] -> CharParser () ParsedExpr+newList "[]bool" es = BoolListExpr <$> mapM _mustBool es+newList "[]int" es = IntListExpr <$> mapM _mustInt es+newList "[]uint" es = UintListExpr <$> mapM _mustUint es+newList "[]double" es = DoubleListExpr <$> mapM _mustDouble es+newList "[]string" es = StringListExpr <$> mapM _mustString es+newList "[][]byte" es = BytesListExpr <$> mapM _mustBytes es++_list :: CharParser () ParsedExpr+_list = do {+    ltype <- _listType;+    es <- ws *> char '{' *> sepBy (ws *> _expr <* ws) (char ',') <* char '}';+    newList ltype es+}++_expr :: CharParser () ParsedExpr+_expr = try _terminal <|> _list <|> _function++expr :: CharParser () (Expr Bool)+expr = (try _terminal <|> _builtin <|> _function) >>= _mustBool++_name :: CharParser () (Expr Bool)+_name = (newBuiltIn "==" <$> (_literal <|> (StringExpr . Const <$> idLit))) >>= check >>= _mustBool++sepBy2 :: CharParser () a -> String -> CharParser () [a]+sepBy2 p sep = do {+    x1 <- p;+    string sep;+    x2 <- p;+    xs <- many (try (string sep *> p));+    return (x1:x2:xs)+}++_nameChoice :: CharParser () (Expr Bool)+_nameChoice = foldl1 OrFunc <$> sepBy2 (ws *> nameExpr <* ws) "|"++nameExpr :: CharParser () (Expr Bool)+nameExpr =  (Const True <$ char '_')+    <|> (NotFunc <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')'))+    <|> (char '(' *> ws *> _nameChoice <* ws <* char ')')+    <|> _name++_concatPattern :: CharParser () Pattern+_concatPattern = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern <* ws) ",") <* optional (char ',' <* ws) <* char ']'++_interleavePattern :: CharParser () Pattern+_interleavePattern = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern <* ws) ";") <* optional (char ';' <* ws) <* char '}'++_parenPattern :: CharParser () Pattern+_parenPattern = do {+    char '(';+    ws;+    first <- pattern;+    ws;+    ( char ')' *> ws *>+        (+            ZeroOrMore first <$ char '*'+            <|> Optional first <$ char '?'+        )+    ) <|> ( +        (+            (first <$ char '|' >>= _orList) <|> +            (first <$ char '&' >>= _andList)+        ) <* char ')'+    )+}++_orList :: Pattern -> CharParser () Pattern+_orList p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern <* ws) (char '|')++_andList :: Pattern -> CharParser () Pattern+_andList p = And p . foldl1 And <$> sepBy1 (ws *> pattern <* ws) (char '&')++_refPattern :: CharParser () Pattern+_refPattern = Reference <$> (char '@' *> ws *> idLit)++_notPattern :: CharParser () Pattern+_notPattern = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern <* ws <* char ')')++_emptyPattern :: CharParser () Pattern+_emptyPattern = Empty <$ string "<empty>"++_zanyPattern :: CharParser () Pattern+_zanyPattern = ZAny <$ string "*"++_containsPattern :: CharParser () Pattern+_containsPattern = Contains <$> (char '.' *> pattern)++_treenodePattern :: CharParser () Pattern+_treenodePattern = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern) <|> _depthPattern ) )++_depthPattern :: CharParser () Pattern+_depthPattern = _concatPattern <|> _interleavePattern <|> _containsPattern +    <|> flip Node Empty <$> ( (string "->" *> expr ) <|> (_builtin >>= _mustBool) )++pattern :: CharParser () Pattern+pattern = _zanyPattern+    <|> _parenPattern+    <|> _refPattern+    <|> try _emptyPattern+    <|> try _treenodePattern+    <|> try _depthPattern+    <|> _notPattern+    +_patternDecl :: CharParser () Refs+_patternDecl = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern)++grammar :: CharParser () Refs+grammar = ws *> (foldl1 union <$> many1 (_patternDecl <* ws))+    <|> union <$> (newRef "main" <$> pattern) <*> (foldl union emptyRef <$> many (ws *> _patternDecl <* ws))+
+ src/Parsers.hs view
@@ -0,0 +1,18 @@+-- |+-- This module describes the abstract tree that can be validated by Relapse.+--+-- The JSON and XML parsers both are both versions of this type class.++module Parsers (+    Tree(..), Label(..)+) where++data Label+    = String String+    | Number Rational+    | Bool Bool+    deriving (Show, Eq, Ord)++class Tree a where+    getLabel :: a -> Label+    getChildren :: a -> [a]
+ src/Patterns.hs view
@@ -0,0 +1,109 @@+-- |+-- This module describes the patterns supported by Relapse.+--+-- It also contains some simple functions for the map of references that a Relapse grammar consists of.+--+-- Finally it also contains some very simple pattern functions.+module Patterns (+    Pattern(..), +    Refs, emptyRef, union, newRef, reverseLookupRef, lookupRef, hasRecursion,+    nullable, unescapable+) where++import qualified Data.Map.Strict as M+import qualified Data.Set as S++import Expr++-- |+-- Pattern recursively describes a Relapse Pattern.+data Pattern+    = Empty+    | ZAny+    | Node (Expr Bool) Pattern+    | Or Pattern Pattern+    | And Pattern Pattern+    | Not Pattern+    | Concat Pattern Pattern+    | Interleave Pattern Pattern+    | ZeroOrMore Pattern+    | Optional Pattern+    | Contains Pattern+    | Reference String+    deriving (Eq, Ord, Show)++-- |+-- The nullable function returns whether a pattern is nullable.+-- This means that the pattern matches the empty string.+nullable :: Refs -> Pattern -> Bool+nullable _ Empty = True+nullable _ ZAny = True+nullable _ Node{} = False+nullable refs (Or l r) = nullable refs l || nullable refs r+nullable refs (And l r) = nullable refs l && nullable refs r+nullable refs (Not p) = not $ nullable refs p+nullable refs (Concat l r) = nullable refs l && nullable refs r+nullable refs (Interleave l r) = nullable refs l && nullable refs r+nullable _ (ZeroOrMore _) = True+nullable _ (Optional _) = True+nullable refs (Contains p) = nullable refs p+nullable refs (Reference name) = nullable refs $ lookupRef refs name++-- |+-- unescapable is used for short circuiting.+-- A part of the tree can be skipped if all patterns are unescapable.+unescapable :: Pattern -> Bool+unescapable ZAny = True+unescapable (Not ZAny) = True+unescapable _ = False++-- |+-- Refs is a map from reference name to pattern and describes a relapse grammar.+newtype Refs = Refs (M.Map String Pattern)+    deriving (Show, Eq)++-- |+-- lookupRef looks up a pattern in the reference map, given a reference name.+lookupRef :: Refs -> String -> Pattern+lookupRef (Refs m) name = m M.! name++-- |+-- reverseLookupRef returns the reference name for a given pattern.+reverseLookupRef :: Pattern -> Refs -> Maybe String+reverseLookupRef p (Refs m) = case M.keys $ M.filter (== p) m of+    []      -> Nothing+    (k:_)  -> Just k++-- |+-- newRef returns a new reference map given a single pattern and its reference name.+newRef :: String -> Pattern -> Refs+newRef key value = Refs $ M.singleton key value++-- |+-- emptyRef returns an empty reference map.+emptyRef :: Refs+emptyRef = Refs M.empty++-- |+-- union returns the union of two reference maps.+union :: Refs -> Refs -> Refs+union (Refs m1) (Refs m2) = Refs $ M.union m1 m2 ++-- |+-- hasRecursion returns whether an relapse grammar has any recursion, starting from the "main" reference.+hasRecursion :: Refs -> Bool+hasRecursion refs = hasRec refs (S.singleton "main") (lookupRef refs "main")++hasRec :: Refs -> S.Set String -> Pattern -> Bool+hasRec _ _ Empty = False+hasRec _ _ ZAny = False+hasRec _ _ Node{} = False+hasRec refs set (Or l r) = hasRec refs set l || hasRec refs set r+hasRec refs set (And l r) = hasRec refs set l || hasRec refs set r+hasRec refs set (Not p) = hasRec refs set p+hasRec refs set (Concat l r) = hasRec refs set l || (nullable refs l && hasRec refs set r)+hasRec refs set (Interleave l r) = hasRec refs set l || hasRec refs set r+hasRec _ _ (ZeroOrMore _) = False+hasRec refs set (Optional p) = hasRec refs set p+hasRec refs set (Contains p) = hasRec refs set p+hasRec refs set (Reference name) = S.member name set || hasRec refs (S.insert name set) (lookupRef refs name)
+ src/Relapse.hs view
@@ -0,0 +1,52 @@+-- |+-- This module provides an implementation of the relapse validation language.+--+-- Relapse is intended to be used for validation of trees or filtering of lists of trees.+--+-- Katydid currently provides two types of trees out of the box: Json and XML, +-- but relapse supports any type of tree as long the type +-- is of the Tree typeclass provided by the Parsers module.+--+-- The validate and filter functions expects a Tree to be a list of trees, +-- since not all serialization formats have a single root.+-- For example, valid json like "[1, 2]" does not have a single root.+-- Relapse can also validate these types of trees.  +-- If your tree has a single root, simply provide a singleton list as input.++module Relapse (+    parseGrammar, validate, filter+) where++import Prelude hiding (filter)+import Control.Monad.Except (Except, throwError, return)+import Control.Monad.State (runState)+import Control.Monad (filterM)++import qualified Parser+import Patterns (Refs)+import qualified Patterns+import qualified MemDerive+import Parsers++-- |+-- parseGrammar parses the relapse grammar and returns either a parsed grammar (Refs, for the list of references) or an error string.+parseGrammar :: String -> Except String Refs+parseGrammar grammarString = case Parser.parseGrammar grammarString of+    (Left l) -> throwError (show l)+    (Right r) -> return r++-- |+-- validate returns whether a tree is valid, given the grammar (Refs).+validate :: Tree t => Refs -> [t] -> Bool+validate refs tree = case filter refs [tree] of+    [] -> False+    _ -> True++-- |+-- filter returns a filtered list of trees, given the grammar (Refs).+filter :: Tree t => Refs -> [[t]] -> [[t]]+filter refs trees = +    let start = Patterns.lookupRef refs "main"+        f = filterM (MemDerive.validate refs start) trees+        (r, _) = runState f MemDerive.newMem+    in r
+ src/Simplify.hs view
@@ -0,0 +1,134 @@+{-#LANGUAGE GADTs #-}++-- |+-- This module simplifies Relapse patterns.++module Simplify (+    simplify  +) where++import qualified Data.Set as S++import Patterns+import Expr++-- |+-- simplify simplifies an input pattern to an equivalent simpler pattern.+simplify :: Refs -> Pattern -> Pattern+simplify refs pattern =+    let simp = simplify' refs+    in case pattern of+    Empty -> Empty+    ZAny -> ZAny+    (Node v p) -> simplifyNode (simplifyBoolExpr v) (simp p)+    (Concat p1 p2) -> simplifyConcat (simp p1) (simp p2)+    (Or p1 p2) -> simplifyOr refs (simp p1) (simp p2)+    (And p1 p2) -> simplifyAnd refs (simp p1) (simp p2)+    (ZeroOrMore p) -> simplifyZeroOrMore (simp p)+    (Not p) -> simplifyNot (simp p)+    (Optional p) -> simplifyOptional (simp p)+    (Interleave p1 p2) -> simplifyInterleave (simp p1) (simp p2)+    (Contains p) -> simplifyContains (simp p)+    p@(Reference _) -> p++simplify' :: Refs -> Pattern -> Pattern+simplify' refs p = checkRef refs $ simplify refs p++simplifyNode :: Expr Bool -> Pattern -> Pattern+simplifyNode (Const False) _ = Not ZAny+simplifyNode v p = Node v p++simplifyConcat :: Pattern -> Pattern -> Pattern+simplifyConcat (Not ZAny) _ = Not ZAny+simplifyConcat _ (Not ZAny) = Not ZAny+simplifyConcat (Concat p1 p2) p3 = +    simplifyConcat p1 (Concat p2 p3)+simplifyConcat Empty p = p+simplifyConcat p Empty = p+simplifyConcat ZAny (Concat p ZAny) = Contains p+simplifyConcat p1 p2 = Concat p1 p2++simplifyOr :: Refs -> Pattern -> Pattern -> Pattern+simplifyOr _ (Not ZAny) p = p+simplifyOr _ p (Not ZAny) = p+simplifyOr _ ZAny _ = ZAny+simplifyOr _ _ ZAny = ZAny+simplifyOr _ (Node v1 Empty) (Node v2 Empty) = Node (OrFunc v1 v2) Empty+simplifyOr refs Empty p +    | nullable refs p = p+    | otherwise = Or Empty p+simplifyOr refs p Empty+    | nullable refs p = p +    | otherwise = Or Empty p+simplifyOr _ p1 p2 = bin Or $ simplifyChildren Or $ S.toAscList $ setOfOrs p1 `S.union` setOfOrs p2++simplifyChildren :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> [Pattern]+simplifyChildren _ [] = []+simplifyChildren _ [p] = [p]+simplifyChildren op (p1@(Node v1 c1):(p2@(Node v2 c2):ps))+    | v1 == v2 = simplifyChildren op $ Node v1 (op c1 c2):ps+    | otherwise = p1:simplifyChildren op (p2:ps)+simplifyChildren op (p:ps) = p:simplifyChildren op ps++bin :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> Pattern+bin op [p] = p+bin op [p1,p2] = op p1 p2+bin op (p:ps) = op p (bin op ps)++setOfOrs :: Pattern -> S.Set Pattern+setOfOrs (Or p1 p2) = setOfOrs p1 `S.union` setOfOrs p2+setOfOrs p = S.singleton p++simplifyAnd :: Refs -> Pattern -> Pattern -> Pattern+simplifyAnd _ (Not ZAny) _ = Not ZAny+simplifyAnd _ _ (Not ZAny) = Not ZAny+simplifyAnd _ ZAny p = p+simplifyAnd _ p ZAny = p+simplifyAnd _ (Node v1 Empty) (Node v2 Empty) = Node (AndFunc v1 v2) Empty+simplifyAnd refs Empty p+    | nullable refs p = Empty+    | otherwise = Not ZAny+simplifyAnd refs p Empty+    | nullable refs p = Empty+    | otherwise = Not ZAny+simplifyAnd _ p1 p2 = bin And $ simplifyChildren And $ S.toAscList $ setOfAnds p1 `S.union` setOfAnds p2++setOfAnds :: Pattern -> S.Set Pattern+setOfAnds (And p1 p2) = setOfAnds p1 `S.union` setOfAnds p2+setOfAnds p = S.singleton p++simplifyZeroOrMore :: Pattern -> Pattern+simplifyZeroOrMore (ZeroOrMore p) = ZeroOrMore p+simplifyZeroOrMore p = ZeroOrMore p++simplifyNot :: Pattern -> Pattern+simplifyNot (Not p) = p+simplifyNot p = Not p++simplifyOptional :: Pattern -> Pattern+simplifyOptional Empty = Empty+simplifyOptional p = Optional p++simplifyInterleave :: Pattern -> Pattern -> Pattern+simplifyInterleave (Not ZAny) _ = Not ZAny+simplifyInterleave _ (Not ZAny) = Not ZAny+simplifyInterleave Empty p = p+simplifyInterleave p Empty = p+simplifyInterleave ZAny ZAny = ZAny+simplifyInterleave p1 p2 = bin Interleave $ S.toAscList $ setOfInterleaves p1 `S.union` setOfInterleaves p2++setOfInterleaves :: Pattern -> S.Set Pattern+setOfInterleaves (Interleave p1 p2) = setOfInterleaves p1 `S.union` setOfInterleaves p2+setOfInterleaves p = S.singleton p++simplifyContains :: Pattern -> Pattern+simplifyContains Empty = ZAny+simplifyContains ZAny = ZAny+simplifyContains (Not ZAny) = Not ZAny+simplifyContains p = Contains p++checkRef :: Refs -> Pattern -> Pattern+checkRef refs p = case reverseLookupRef p refs of+    Nothing     -> p+    (Just k)    -> Reference k+
+ src/VpaDerive.hs view
@@ -0,0 +1,96 @@+-- |+-- This module contains a VPA (Visual Pushdown Automaton) implementation of the internal derivative algorithm.+--+-- It is intended to be used for explanation purposes.+--+-- It shows how out algorithm is effective equivalent to a visual pushdown automaton.++module VpaDerive (+    derive      +) where++import qualified Data.Map.Strict as M+import Control.Monad.State (State, runState, state, lift)+import Data.Foldable (foldlM)+import Control.Monad.Except (Except, ExceptT, throwError, runExcept, runExceptT)++import qualified Derive+import Patterns (Refs, Pattern)+import qualified Patterns+import IfExprs+import Expr+import Zip+import Parsers++mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)+mem f k m+    | M.member k m = (m M.! k, m)+    | otherwise = let res = f k+        in (res, M.insert k res m)++type VpaState = [Pattern]+type StackElm = ([Pattern], Zipper)++type Calls = M.Map VpaState ZippedIfExprs+type Nullable = M.Map [Pattern] [Bool]+type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern]++newtype Vpa = Vpa (Nullable, Calls, Returns, Refs)++newVpa :: Refs -> Vpa+newVpa refs = Vpa (M.empty, M.empty, M.empty, refs)++nullable :: [Pattern] -> State Vpa [Bool]+nullable key = state $ \(Vpa (n, c, r, refs)) -> let (v', n') = mem (map $ Patterns.nullable refs) key n;+    in (v', Vpa (n', c, r, refs))++calls :: [Pattern] -> State Vpa ZippedIfExprs+calls key = state $ \(Vpa (n, c, r, refs)) -> let (v', c') = mem (zipIfExprs . Derive.calls refs) key c;+    in (v', Vpa (n, c', r, refs))++vpacall :: VpaState -> Label -> ExceptT ValueErr (State Vpa) (StackElm, VpaState)+vpacall vpastate label = do {+    zifexprs <- lift $ calls vpastate;+    (nextstate, zipper) <- case runExcept $ evalZippedIfExprs zifexprs label of+        (Left l) -> throwError l+        (Right r) -> return r+    ;+    let stackelm = (vpastate, zipper)+    ; +    return (stackelm, nextstate)+}++returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern]+returns key = state $ \(Vpa (n, c, r, refs)) -> +    let (v', r') = mem (\(ps, zipper, znulls) -> +            Derive.returns refs (ps, unzipby zipper znulls)) key r+    in (v', Vpa (n, c, r', refs))++vpareturn :: StackElm -> VpaState -> State Vpa VpaState+vpareturn (vpastate, zipper) current = do {+    zipnulls <- nullable current;+    returns (vpastate, zipper, zipnulls)+}++deriv :: Tree t => VpaState -> t -> ExceptT ValueErr (State Vpa) VpaState+deriv current tree = do {+    (stackelm, nextstate) <- vpacall current (getLabel tree);+    resstate <- foldlM deriv nextstate (getChildren tree);+    lift $ vpareturn stackelm resstate+}++foldLT :: Tree t => Vpa -> VpaState -> [t] -> Except ValueErr [Pattern]+foldLT _ current [] = return current+foldLT m current (t:ts) = +    let (newstate, newm) = runState (runExceptT $ deriv current t) m+    in case newstate of+        (Left l) -> throwError l+        (Right r) -> foldLT newm r ts++derive :: Tree t => Refs -> [t] -> Except String Pattern+derive refs ts = +    let start = [Patterns.lookupRef refs "main"]+    in case runExcept $ foldLT (newVpa refs) start ts of+        (Left l) -> throwError $ show l+        (Right [r]) -> return r+        (Right rs) -> throwError $ "Number of patterns is not one, but " ++ show rs
+ src/Xml.hs view
@@ -0,0 +1,41 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- This module contains the XML Parser.++module Xml (+    decodeXML+) where++import Text.Read (readMaybe)+import Text.XML.HXT.DOM.TypeDefs (XmlTree, XNode(..), blobToString, localPart)+import Text.XML.HXT.Parser.XmlParsec (xread)+import Data.Tree.NTree.TypeDefs (NTree(..))++import Parsers++instance Tree XmlTree where+    getLabel (NTree n _ ) = either (String . ("XML Parse Error:" ++)) id (xmlLabel n)+    getChildren (NTree _ cs) = cs++-- |+-- decodeXML returns a XmlTree, given an input string.+decodeXML :: String -> [XmlTree]+decodeXML = xread++xmlLabel :: XNode -> Either String Label+xmlLabel (XText s) = return $ parseLabel s+xmlLabel (XBlob b) = return $ parseLabel $ blobToString b+xmlLabel x@(XCharRef _) = fail $ "XCharRef not supported" ++ show x+xmlLabel x@(XEntityRef _) = fail $ "XEntityRef not supported" ++ show x+xmlLabel x@(XCmt _) = fail $ "XCmt not supported" ++ show x+xmlLabel (XCdata s) = return $ parseLabel s+xmlLabel x@XPi{} = fail $ "XPi not supported" ++ show x+xmlLabel (XTag qname attrs) = return $ parseLabel (localPart qname) -- TODO attrs should be part of the children returned by getChildren+xmlLabel x@XDTD{} = fail $ "XDTD not supported" ++ show x+xmlLabel (XAttr qname) = return $ parseLabel (localPart qname)+xmlLabel x@XError{} = fail $ "XError not supported" ++ show x++-- TODO what about other leaf types+parseLabel :: String -> Label+parseLabel s = maybe (String s) (Number . toRational) (readMaybe s :: Maybe Int)
+ src/Zip.hs view
@@ -0,0 +1,41 @@+-- |+-- This is an internal relapse module.+--+-- It zips patterns to reduce the state space.++module Zip (+    Zipper, zippy, unzipby+) where++import qualified Data.Set as S+import Data.List (elemIndex)++import Patterns++data ZipEntry = ZipVal Int | ZipZAny | ZipNotZAny+    deriving (Eq, Ord)++newtype Zipper = Zipper [ZipEntry]+    deriving (Eq, Ord)++zippy :: [Pattern] -> ([Pattern], Zipper)+zippy ps =+    let s = S.fromList ps+        s' = S.delete ZAny s+        s'' = S.delete (Not ZAny) s'+        l = S.toAscList s''+    in (l, Zipper $ map (indexOf l) ps)++indexOf :: [Pattern] -> Pattern -> ZipEntry+indexOf _ ZAny = ZipZAny+indexOf _ (Not ZAny) = ZipNotZAny+indexOf ps p = case elemIndex p ps of+    (Just i) -> ZipVal i++unzipby :: Zipper -> [Bool] -> [Bool]+unzipby (Zipper z) bs = map (ofIndexb bs) z++ofIndexb :: [Bool] -> ZipEntry -> Bool+ofIndexb _ ZipZAny = True+ofIndexb _ ZipNotZAny = False+ofIndexb bs (ZipVal i) = bs !! i
+ test/Spec.hs view
@@ -0,0 +1,22 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- This module runs the relapse parsing and validation tests.+module Main where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HUnit++import qualified ParserSpec+import qualified Suite+import qualified RelapseSpec++main :: IO ()+main = do {+    testSuiteCases <- Suite.readTestCases;+    T.defaultMain $ T.testGroup "Tests" [+        ParserSpec.tests+        , RelapseSpec.tests+        , Suite.tests testSuiteCases+    ]+}