katydid 0.2.0.1 → 0.3.0.0
raw patch · 35 files changed
+2543/−1434 lines, 35 filesdep +bytestringdep +eitherdep +extra
Dependencies added: bytestring, either, extra, ilist, primes
Files
- README.md +52/−4
- app/Main.hs +1/−2
- bench/Benchmarks.hs +3/−4
- katydid.cabal +23/−4
- src/Ast.hs +117/−0
- src/Derive.hs +100/−78
- src/Expr.hs +435/−440
- src/Exprs.hs +86/−0
- src/Exprs/Compare.hs +191/−0
- src/Exprs/Contains.hs +48/−0
- src/Exprs/Elem.hs +35/−0
- src/Exprs/Length.hs +54/−0
- src/Exprs/Logic.hs +128/−0
- src/Exprs/Strings.hs +107/−0
- src/Exprs/Type.hs +36/−0
- src/Exprs/Var.hs +126/−0
- src/IfExprs.hs +20/−18
- src/Json.hs +8/−4
- src/MemDerive.hs +34/−44
- src/ParsePatterns.hs +0/−420
- src/Parser.hs +127/−112
- src/Parsers.hs +13/−2
- src/Patterns.hs +0/−109
- src/Relapse.hs +31/−17
- src/Simplify.hs +28/−26
- src/Smart.hs +417/−0
- src/VpaDerive.hs +32/−31
- src/Xml.hs +3/−2
- src/Zip.hs +9/−3
- test/DeriveSpec.hs +48/−0
- test/ParserSpec.hs +102/−83
- test/RelapseSpec.hs +17/−7
- test/Spec.hs +2/−0
- test/Suite.hs +31/−24
- test/UserDefinedFuncs.hs +79/−0
README.md view
@@ -4,6 +4,8 @@ A Haskell implementation of Katydid. ++ This includes: - [Relapse](https://katydid.github.io/katydid-haskell/Relapse.html): Validation Language @@ -17,13 +19,13 @@ All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes]. -[Hackage](https://hackage.haskell.org/package/katydid-0.1.0.0).+[Hackage](https://hackage.haskell.org/package/katydid-0.1.0.0) ## Example Validating a single structure can be done using the validate function: ```haskell-validate :: Tree t => Refs -> [t] -> Bool+validate :: Tree t => Grammar -> [t] -> Bool ``` , where a tree is a class in the [Parsers](https://katydid.github.io/katydid-haskell/Parsers.html) module:@@ -42,7 +44,7 @@ else putStrLn "dragons are fictional" ) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> + Relapse.parse ".DragonsExist == true" <*> Json.decodeJSON "{\"DragonsExist\": false}" ``` @@ -51,6 +53,52 @@ 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]]+filter :: Tree t => Grammar -> [[t]] -> [[t]] ``` +## User Defined Functions++If you want to create your own extra functions for operating on the leaves,+then you can inject them into the parse function:++```haskell+main = either+ (\err -> putStrLn $ "error:" ++ err)+ (\valid -> if valid+ then putStrLn "prime birthday !!!"+ else putStrLn "JOMO"+ ) $+ Relapse.validate <$>+ Relapse.parseWithUDFs userLib ".Survived->isPrime($int)" <*>+ Json.decodeJSON "{\"Survived\": 104743}"+```++Defining your own user library to inject is easy.+The `Expr` library provides many useful helper functions:++```haskell+import Data.Numbers.Primes (isPrime)+import Expr++userLib :: String -> [AnyExpr] -> Either String AnyExpr+userLib "isPrime" args = mkIsPrime args+userLib n _ = throwError $ "undefined function: " ++ n++mkIsPrime :: [AnyExpr] -> Either String AnyExpr+mkIsPrime args = do {+ arg <- assertArgs1 "isPrime" args;+ mkBoolExpr . isPrimeExpr <$> assertInt arg;+}++isPrimeExpr :: Integral a => Expr a -> Expr Bool+isPrimeExpr numExpr = trimBool Expr {+ desc = mkDesc "isPrime" [desc numExpr]+ , eval = \fieldValue -> isPrime <$> eval numExpr fieldValue+}+```++## Roadmap++ - Protobuf parser+ - Profile and Optimize (bring up to par with Go version)+ - Typed DSL (Combinator)
app/Main.hs view
@@ -2,7 +2,6 @@ import qualified Relapse import qualified Json-import Control.Monad.Except (runExcept) main :: IO () main = either @@ -12,6 +11,6 @@ else putStrLn "dragons are fictional" ) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar ".DragonsExist == true") <*> + Relapse.parse ".DragonsExist == true" <*> Json.decodeJSON "{\"DragonsExist\": false}"
bench/Benchmarks.hs view
@@ -6,8 +6,7 @@ main :: IO () main = do { benches <- readBenches;- benchmarks <- return $ map (\benchcase ->- B.bench (benchname benchcase) $ B.perBatchEnv (stretch benchcase) runBench- ) benches;- B.defaultMain benchmarks;+ B.defaultMain $ map (\benchcase ->+ B.bench (benchname benchcase) $ + B.perBatchEnv (stretch benchcase) runBench) benches; }
katydid.cabal view
@@ -1,5 +1,5 @@ name: katydid-version: 0.2.0.1+version: 0.3.0.0 synopsis: A haskell implementation of Katydid description: A haskell implementation of Katydid@@ -30,20 +30,29 @@ library hs-source-dirs: src- exposed-modules: Patterns+ exposed-modules: Ast , Derive , MemDerive , Zip , IfExprs , Expr+ , Exprs.Compare+ , Exprs.Contains+ , Exprs.Elem+ , Exprs.Length+ , Exprs.Logic+ , Exprs.Strings+ , Exprs.Type+ , Exprs.Var+ , Exprs , Simplify , Json , Xml , Parsers- , ParsePatterns , VpaDerive , Parser , Relapse+ , Smart build-depends: base >= 4.7 && < 5 , containers , json@@ -52,6 +61,11 @@ , mtl , parsec , deepseq+ , text+ , bytestring+ , either+ , extra+ , ilist default-language: Haskell2010 executable katydid-exe@@ -79,9 +93,14 @@ , mtl , tasty-hunit , tasty- other-modules: ParserSpec+ , text+ , primes+ , ilist+ other-modules: UserDefinedFuncs+ , ParserSpec , RelapseSpec , Suite+ , DeriveSpec ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010
+ src/Ast.hs view
@@ -0,0 +1,117 @@+-- |+-- This module describes the Relapse's abstract syntax tree.+--+-- 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 Ast (+ Pattern(..)+ , Grammar, emptyRef, union, newRef, reverseLookupRef, lookupRef, hasRecursion, listRefs+ , nullable+) where++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Control.Monad.Extra ((||^), (&&^))++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 :: Grammar -> Pattern -> Either String Bool+nullable _ Empty = Right True+nullable _ ZAny = Right True+nullable _ Node{} = Right False+nullable g (Or l r) = nullable g l ||^ nullable g r+nullable g (And l r) = nullable g l &&^ nullable g r+nullable g (Not p) = not <$> nullable g p+nullable g (Concat l r) = nullable g l &&^ nullable g r+nullable g (Interleave l r) = nullable g l &&^ nullable g r+nullable _ (ZeroOrMore _) = Right True+nullable _ (Optional _) = Right True+nullable g (Contains p) = nullable g p+nullable g (Reference refName) = lookupRef g refName >>= nullable g++-- |+-- Refs is a map from reference name to pattern and describes a relapse grammar.+newtype Grammar = Grammar (M.Map String Pattern)+ deriving (Show, Eq)++-- |+-- lookupRef looks up a pattern in the reference map, given a reference name.+lookupRef :: Grammar -> String -> Either String Pattern+lookupRef (Grammar m) refName = case M.lookup refName m of+ Nothing -> Left $ "missing reference: " ++ refName+ (Just p) -> Right p++-- |+-- listRefs returns the list of reference names.+listRefs :: Grammar -> [String]+listRefs (Grammar m) = M.keys m++-- |+-- reverseLookupRef returns the reference name for a given pattern.+reverseLookupRef :: Pattern -> Grammar -> Maybe String+reverseLookupRef p (Grammar 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 -> Grammar+newRef key value = Grammar $ M.singleton key value++-- |+-- emptyRef returns an empty reference map.+emptyRef :: Grammar+emptyRef = Grammar M.empty++-- |+-- union returns the union of two reference maps.+union :: Grammar -> Grammar -> Grammar+union (Grammar m1) (Grammar m2) = Grammar $ M.union m1 m2 ++-- |+-- hasRecursion returns whether an relapse grammar has any recursion, starting from the "main" reference.+hasRecursion :: Grammar -> Either String Bool+hasRecursion g = do {+ mainPat <- lookupRef g "main";+ hasRec g (S.singleton "main") mainPat +}++hasRec :: Grammar -> S.Set String -> Pattern -> Either String Bool+hasRec _ _ Empty = Right False+hasRec _ _ ZAny = Right False+hasRec _ _ Node{} = Right False+hasRec g set (Or l r) = hasRec g set l ||^ hasRec g set r+hasRec g set (And l r) = hasRec g set l ||^ hasRec g set r+hasRec g set (Not p) = hasRec g set p+hasRec g set (Concat l r) = hasRec g set l ||^ (nullable g l &&^ hasRec g set r)+hasRec g set (Interleave l r) = hasRec g set l ||^ hasRec g set r+hasRec g set (ZeroOrMore p) = hasRec g set p+hasRec g set (Optional p) = hasRec g set p+hasRec g set (Contains p) = hasRec g set p+hasRec g set (Reference refName) = if S.member refName set+ then Right True+ else do {+ pat <- lookupRef g refName;+ hasRec g (S.insert refName set) pat;+ }
src/Derive.hs view
@@ -9,13 +9,15 @@ module Derive ( derive, calls, returns, zipderive+ -- * Internal functions+ -- | These functions are exposed for testing purposes.+ , removeOneForEach ) where import Data.Foldable (foldlM)-import Control.Monad.Except (Except, mapExcept, throwError)+import Data.List.Index (imap) -import Patterns-import Expr+import Smart import Parsers import Simplify import Zip@@ -32,111 +34,131 @@ -- -- , 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 (\p -> deriveCall refs p []) ps+calls :: Grammar -> [Pattern] -> IfExprs+calls g ps = compileIfExprs $ concatMap (\p -> deriveCall g p []) ps -deriveCall :: Refs -> Pattern -> [IfExpr]-> [IfExpr]+deriveCall :: Grammar -> Pattern -> [IfExpr] -> [IfExpr] deriveCall _ Empty res = res deriveCall _ ZAny res = res-deriveCall _ (Node v p) res = (newIfExpr v p (Not ZAny)) : res-deriveCall refs (Concat l r) res- | nullable refs l = deriveCall refs l (deriveCall refs r res)- | otherwise = deriveCall refs l res-deriveCall refs (Or l r) res = deriveCall refs l (deriveCall refs r res)-deriveCall refs (And l r) res = deriveCall refs l (deriveCall refs r res)-deriveCall refs (Interleave l r) res = deriveCall refs l (deriveCall refs r res)-deriveCall refs (ZeroOrMore p) res = deriveCall refs p res-deriveCall refs (Reference name) res = deriveCall refs (lookupRef refs name) res-deriveCall refs (Not p) res = deriveCall refs p res-deriveCall refs (Contains p) res = deriveCall refs (Concat ZAny (Concat p ZAny)) res-deriveCall refs (Optional p) res = deriveCall refs (Or p Empty) res+deriveCall _ Node{expr=v,pat=p} res = newIfExpr v p emptySet : res+deriveCall g Concat{left=l,right=r} res+ | nullable l = deriveCall g l (deriveCall g r res)+ | otherwise = deriveCall g l res+deriveCall g Or{pats=ps} res = foldr (deriveCall g) res ps+deriveCall g And{pats=ps} res = foldr (deriveCall g) res ps+deriveCall g Interleave{pats=ps} res = foldr (deriveCall g) res ps+deriveCall g ZeroOrMore{pat=p} res = deriveCall g p res+deriveCall g Reference{refName=name} res = deriveCall g (lookupRef g name) res+deriveCall g Not{pat=p} res = deriveCall g p res+deriveCall g Contains{pat=p} res = deriveCall g p res+deriveCall g Optional{pat=p} res = deriveCall g p res -- | -- 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 :: Grammar -> ([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)+returns g (p:tailps, ns) =+ let (dp, tailns) = deriveReturn g p ns+ in dp:returns g (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+mapReturn :: Grammar -> [Pattern] -> [Bool] -> ([Pattern], [Bool])+mapReturn g ps ns = foldl (\(dps, tailns) p ->+ let (dp, tailoftail) = deriveReturn g p tailns+ in (dp:dps, tailoftail)+ ) ([], ns) ps -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+deriveReturn :: Grammar -> Pattern -> [Bool] -> (Pattern, [Bool])+deriveReturn _ Empty ns = (emptySet, ns)+deriveReturn _ ZAny ns = (zanyPat, ns)+deriveReturn _ Node{} ns+ | head ns = (emptyPat, tail ns)+ | otherwise = (emptySet, tail ns)+deriveReturn g Concat{left=l,right=r} ns+ | nullable l =+ let (dl, ltail) = deriveReturn g l ns+ (dr, rtail) = deriveReturn g r ltail+ in (orPat (concatPat dl r) dr, rtail)+ | otherwise =+ let (dl, ltail) = deriveReturn g l ns+ in (concatPat dl r, ltail)+deriveReturn g Or{pats=ps} ns =+ let (dps, tailns) = mapReturn g ps ns+ in (foldl1 orPat dps, tailns)+deriveReturn g And{pats=ps} ns =+ let (dps, tailns) = mapReturn g ps ns+ in (foldl1 andPat dps, tailns)+deriveReturn g Interleave{pats=ps} ns =+ let (dps, tailns) = mapReturn g ps ns+ pps = reverse $ removeOneForEach ps+ ips = zipWith (:) dps pps+ ors = map (foldl1 interleavePat) ips+ in (foldl1 orPat ors, tailns)+deriveReturn g z@ZeroOrMore{pat=p} ns =+ let (dp, tailns) = deriveReturn g p ns+ in (concatPat dp z, tailns)+deriveReturn g Reference{refName=name} ns = deriveReturn g (lookupRef g name) ns+deriveReturn g Not{pat=p} ns =+ let (dp, tailns) = deriveReturn g p ns+ in (notPat dp, tailns)+deriveReturn g c@Contains{pat=p} ns =+ let (dp, tailns) = deriveReturn g p ns+ in (orPat c (containsPat dp), tailns)+deriveReturn g Optional{pat=p} ns = deriveReturn g p ns +-- | For internal testing.+-- removeOneForEach creates N copies of the list removing the n'th element from each.+removeOneForEach :: [a] -> [[a]]+removeOneForEach xs = imap (\index list ->+ let (start,end) = splitAt index list+ in start ++ tail end+ ) (replicate (length xs) xs)+ -- | -- 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+derive :: Tree t => Grammar -> [t] -> Either String Pattern+derive g ts = do {+ ps <- foldlM (deriv g) [lookupMain g] ts;+ if length ps == 1 + then return $ head ps+ else Left $ "Number of patterns is not one, but " ++ show ps+} -deriv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern]-deriv refs ps tree =+deriv :: Tree t => Grammar -> [Pattern] -> t -> Either String [Pattern]+deriv g ps tree = if all unescapable ps then return ps else- let ifs = calls refs ps- d = deriv refs- nulls = map (nullable refs)+ let ifs = calls g ps+ d = deriv g+ nulls = map nullable in do { childps <- evalIfExprs ifs (getLabel tree); childres <- foldlM d childps (getChildren tree);- return $ returns refs (ps, nulls childres);+ return $ returns g (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+zipderive :: Tree t => Grammar -> [t] -> Either String Pattern+zipderive g ts = do {+ ps <- foldlM (zipderiv g) [lookupMain g] ts;+ if length ps == 1 + then return $ head ps+ else Left $ "Number of patterns is not one, but " ++ show ps+} -zipderiv :: Tree t => Refs -> [Pattern] -> t -> Except ValueErr [Pattern]-zipderiv refs ps tree =+zipderiv :: Tree t => Grammar -> [Pattern] -> t -> Either String [Pattern]+zipderiv g ps tree = if all unescapable ps then return ps else- let ifs = calls refs ps- d = zipderiv refs- nulls = map (nullable refs)+ let ifs = calls g ps+ d = zipderiv g+ nulls = map nullable 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)+ in return $ returns g (ps, unzipns) }
src/Expr.hs view
@@ -1,518 +1,513 @@-{-#LANGUAGE GADTs, StandaloneDeriving #-}- -- |--- This module contains all the Relapse expressions.--- --- It also contains an eval function and a simplfication function for these expressions.+-- This module contains all the functions you need to implement a Relapse expression.+ module Expr (- -- * Expressions- Expr(..), Bytes, Uint,- -- * Functions- simplifyBoolExpr, eval,- -- * Errors- ValueErr+ Desc(..), mkDesc+ , AnyExpr(..), AnyFunc(..)+ , Expr(..), Func, params, name, hasVar+ , hashWithName, hashList, hashString+ , evalConst, isConst+ , assertArgs1, assertArgs2+ , mkBoolExpr, mkIntExpr, mkStringExpr, mkDoubleExpr, mkBytesExpr, mkUintExpr+ , assertBool, assertInt, assertString, assertDouble, assertBytes, assertUint+ , boolExpr, intExpr, stringExpr, doubleExpr, bytesExpr, uintExpr+ , trimBool, trimInt, trimString, trimDouble, trimBytes, trimUint+ , mkBoolsExpr, mkIntsExpr, mkStringsExpr, mkDoublesExpr, mkListOfBytesExpr, mkUintsExpr+ , assertBools, assertInts, assertStrings, assertDoubles, assertListOfBytes, assertUints+ , boolsExpr, intsExpr, stringsExpr, doublesExpr, listOfBytesExpr, uintsExpr ) 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)+import Data.Char (ord)+import Data.List (intercalate)+import Data.Text (Text, unpack, pack)+import Data.ByteString (ByteString) -data ValueErr- = ErrNotABool String- | ErrNotAString String- | ErrNotAnInt String- | ErrNotADouble String- | ErrNotAnUint String- | ErrNotBytes String- deriving (Eq, Ord, Show)+import qualified Parsers -- |--- 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+-- assertArgs1 asserts that the list of arguments is only one argument and +-- returns the argument or an error message +-- containing the function name that was passed in as an argument to assertArgs1.+assertArgs1 :: String -> [AnyExpr] -> Either String AnyExpr+assertArgs1 _ [e1] = Right e1+assertArgs1 exprName es = Left $ exprName ++ ": expected one argument, but got " ++ show (length es) ++ ": " ++ show es -ev (Const b) _ = return b-ev BoolVariable (Bool b) = return b-ev BoolVariable l = throwError $ ErrNotABool $ show l+-- |+-- assertArgs2 asserts that the list of arguments is only two arguments and +-- returns the two arguments or an error message +-- containing the function name that was passed in as an argument to assertArgs2.+assertArgs2 :: String -> [AnyExpr] -> Either String (AnyExpr, AnyExpr)+assertArgs2 _ [e1, e2] = Right (e1, e2)+assertArgs2 exprName es = Left $ exprName ++ ": expected two arguments, but got " ++ show (length es) ++ ": " ++ show es -ev (OrFunc e1 e2) v = (||) <$> ev e1 v <*> ev e2 v+-- |+-- Desc is the description of a function, +-- especially built to make comparisons of user defined expressions possible.+data Desc = Desc {+ _name :: String+ , _toStr :: String+ , _hash :: Int+ , _params :: [Desc]+ , _hasVar :: Bool+} -ev (AndFunc e1 e2) v = (&&) <$> ev e1 v <*> ev e2 v+-- |+-- mkDesc makes a description from a function name and a list of the argument's descriptions.+mkDesc :: String -> [Desc] -> Desc+mkDesc n ps = Desc {+ _name = n+ , _toStr = n ++ "(" ++ intercalate "," (map show ps) ++ ")"+ , _hash = hashWithName n ps+ , _params = ps+ , _hasVar = any _hasVar ps+} -ev (NotFunc e) v = case runExcept $ ev e v of- (Right True) -> return False- _ -> return True+instance Show Desc where+ show = _toStr -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)+instance Ord Desc where+ compare = cmp -ev (IntListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es+instance Eq Desc where+ (==) a b = cmp a b == EQ -ev (StringListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es+-- |+-- AnyExpr is used by the Relapse parser to represent an Expression that can return any type of value, +-- where any is a predefined list of possible types represented by AnyFunc.+data AnyExpr = AnyExpr {+ _desc :: Desc+ , _eval :: AnyFunc+} -ev (UintListContainsFunc e es) v = elem <$> ev e v <*> mapM (`ev` v) es+-- |+-- Func represents the evaluation function part of a user defined expression.+-- This function takes a label from a tree parser and returns a value or an error string.+type Func a = (Parsers.Label -> Either String a) -ev (StringContainsFunc s sub) v = isInfixOf <$> ev sub v <*> ev s v+instance Show AnyExpr where+ show a = show (_desc a) -ev (BoolListElemFunc es i) v =- (!!) <$>- mapM (`ev` v) es <*>- ev i v+instance Eq AnyExpr where+ (==) a b = _desc a == _desc b -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)+instance Ord AnyExpr where+ compare a b = cmp (_desc a) (_desc b) -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)+-- |+-- AnyFunc is used by the Relapse parser and represents the list all supported types of functions.+data AnyFunc = BoolFunc (Func Bool)+ | IntFunc (Func Int)+ | StringFunc (Func Text)+ | DoubleFunc (Func Double)+ | UintFunc (Func Word)+ | BytesFunc (Func ByteString)+ | BoolsFunc (Func [Bool])+ | IntsFunc (Func [Int])+ | StringsFunc (Func [Text])+ | DoublesFunc (Func [Double])+ | UintsFunc (Func [Word])+ | ListOfBytesFunc (Func [ByteString]) -ev (StringHasPrefixFunc e1 e2) v = isPrefixOf <$> ev e2 v <*> ev e1 v+-- |+-- Expr represents a user defined expression, +-- which consists of a description for comparisons and an evaluation function.+data Expr a = Expr {+ desc :: Desc+ , eval :: Func a+} -ev (StringHasSuffixFunc e1 e2) v = isSuffixOf <$> ev e2 v <*> ev e1 v+instance Show (Expr a) where+ show e = show (desc e) -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)+instance Eq (Expr a) where+ (==) x y = desc x == desc y -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)+instance Ord (Expr a) where+ compare x y = cmp (desc x) (desc y) -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)+-- |+-- params returns the descriptions of the parameters of the user defined expression.+params :: Expr a -> [Desc]+params = _params . desc -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+-- |+-- name returns the name of the user defined expression.+name :: Expr a -> String+name = _name . desc -ev (RegexFunc e s) v = (=~) <$> ev s v <*> ev e v+-- |+-- hasVar returns whether the expression or any of its children contains a variable expression.+hasVar :: Expr a -> Bool+hasVar = _hasVar . desc -ev DoubleVariable (Number r) = return $ fromRational r-ev DoubleVariable l = throwError $ ErrNotADouble $ show l+-- |+-- mkBoolExpr generalises a bool expression to any expression.+mkBoolExpr :: Expr Bool -> AnyExpr+mkBoolExpr (Expr desc eval) = AnyExpr desc (BoolFunc eval) -ev (DoubleListElemFunc es i) v = - (!!) <$> - mapM (`ev` v) es <*> - ev i v+-- |+-- assertBool asserts that any expression is actually a bool expression.+assertBool :: AnyExpr -> Either String (Expr Bool)+assertBool (AnyExpr desc (BoolFunc eval)) = Right $ Expr desc eval+assertBool (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bool" -ev IntVariable (Number r) = return (truncate r)-ev IntVariable l = throwError $ ErrNotAnInt $ show l+-- |+-- mkIntExpr generalises an int expression to any expression.+mkIntExpr :: Expr Int -> AnyExpr+mkIntExpr (Expr desc eval) = AnyExpr desc (IntFunc eval) -ev (IntListElemFunc es i) v =- (!!) <$>- mapM (`ev` v) es <*>- ev i v+-- |+-- assertInt asserts that any expression is actually an int expression.+assertInt :: AnyExpr -> Either String (Expr Int)+assertInt (AnyExpr desc (IntFunc eval)) = Right $ Expr desc eval+assertInt (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type int" -ev (BytesListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- mkDoubleExpr generalises a double expression to any expression.+mkDoubleExpr :: Expr Double -> AnyExpr+mkDoubleExpr (Expr desc eval) = AnyExpr desc (DoubleFunc eval) -ev (BoolListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- assertDouble asserts that any expression is actually a double expression.+assertDouble :: AnyExpr -> Either String (Expr Double)+assertDouble (AnyExpr desc (DoubleFunc eval)) = Right $ Expr desc eval+assertDouble (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type double" -ev (BytesLengthFunc e) v = length <$> ev e v+-- |+-- mkStringExpr generalises a string expression to any expression.+mkStringExpr :: Expr Text -> AnyExpr+mkStringExpr (Expr desc eval) = AnyExpr desc (StringFunc eval) -ev (DoubleListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- assertString asserts that any expression is actually a string expression.+assertString :: AnyExpr -> Either String (Expr Text)+assertString (AnyExpr desc (StringFunc eval)) = Right $ Expr desc eval+assertString (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type string" -ev (IntListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- mkUintExpr generalises a uint expression to any expression.+mkUintExpr :: Expr Word -> AnyExpr+mkUintExpr (Expr desc eval) = AnyExpr desc (UintFunc eval) -ev (StringListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- assertUint asserts that any expression is actually a uint expression.+assertUint :: AnyExpr -> Either String (Expr Word)+assertUint (AnyExpr desc (UintFunc eval)) = Right $ Expr desc eval+assertUint (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type uint" -ev (UintListLengthFunc es) v = length <$> mapM (`ev` v) es+-- |+-- mkBytesExpr generalises a bytes expression to any expression.+mkBytesExpr :: Expr ByteString -> AnyExpr+mkBytesExpr (Expr desc eval) = AnyExpr desc (BytesFunc eval) -ev (StringLengthFunc e) v = length <$> ev e v+-- |+-- assertBytes asserts that any expression is actually a bytes expression.+assertBytes :: AnyExpr -> Either String (Expr ByteString)+assertBytes (AnyExpr desc (BytesFunc eval)) = Right $ Expr desc eval+assertBytes (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bytes" -ev UintVariable (Number r) = return $ truncate r-ev UintVariable l = throwError $ ErrNotAnUint $ show l+-- |+-- mkBoolsExpr generalises a list of bools expression to any expression.+mkBoolsExpr :: Expr [Bool] -> AnyExpr+mkBoolsExpr (Expr desc eval) = AnyExpr desc (BoolsFunc eval) -ev (UintListElemFunc es i) v =- (!!) <$>- mapM (`ev` v) es <*>- ev i v+-- |+-- assertBools asserts that any expression is actually a list of bools expression.+assertBools :: AnyExpr -> Either String (Expr [Bool])+assertBools (AnyExpr desc (BoolsFunc eval)) = Right $ Expr desc eval+assertBools (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bools" -ev StringVariable (String s) = return s-ev StringVariable l = throwError $ ErrNotAString $ show l+-- |+-- mkIntsExpr generalises a list of ints expression to any expression.+mkIntsExpr :: Expr [Int] -> AnyExpr+mkIntsExpr (Expr desc eval) = AnyExpr desc (IntsFunc eval) -ev (StringListElemFunc es i) v =- (!!) <$>- mapM (`ev` v) es <*>- ev i v+-- |+-- assertInts asserts that any expression is actually a list of ints expression.+assertInts :: AnyExpr -> Either String (Expr [Int])+assertInts (AnyExpr desc (IntsFunc eval)) = Right $ Expr desc eval+assertInts (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type ints" -ev (StringToLowerFunc s) v = map toLower <$> ev s v+-- |+-- mkUintsExpr generalises a list of uints expression to any expression.+mkUintsExpr :: Expr [Word] -> AnyExpr+mkUintsExpr (Expr desc eval) = AnyExpr desc (UintsFunc eval) -ev (StringToUpperFunc s) v = map toUpper <$> ev s v+-- |+-- assertUints asserts that any expression is actually a list of uints expression.+assertUints :: AnyExpr -> Either String (Expr [Word])+assertUints (AnyExpr desc (UintsFunc eval)) = Right $ Expr desc eval+assertUints (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type uints" -ev BytesVariable (String s) = return s-ev BytesVariable l = throwError $ ErrNotBytes $ show l+-- |+-- mkDoublesExpr generalises a list of doubles expression to any expression.+mkDoublesExpr :: Expr [Double] -> AnyExpr+mkDoublesExpr (Expr desc eval) = AnyExpr desc (DoublesFunc eval) -ev (BytesListElemFunc es i) v =- (!!) <$>- mapM (`ev` v) es <*>- ev i v+-- |+-- assertDoubles asserts that any expression is actually a list of doubles expression.+assertDoubles :: AnyExpr -> Either String (Expr [Double])+assertDoubles (AnyExpr desc (DoublesFunc eval)) = Right $ Expr desc eval+assertDoubles (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type doubles" -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+-- |+-- mkStringsExpr generalises a list of strings expression to any expression.+mkStringsExpr :: Expr [Text] -> AnyExpr+mkStringsExpr (Expr desc eval) = AnyExpr desc (StringsFunc eval) -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+-- |+-- assertStrings asserts that any expression is actually a list of strings expression.+assertStrings :: AnyExpr -> Either String (Expr [Text])+assertStrings (AnyExpr desc (StringsFunc eval)) = Right $ Expr desc eval+assertStrings (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type strings" -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+-- |+-- mkListOfBytesExpr generalises a list of bytes expression to any expression.+mkListOfBytesExpr :: Expr [ByteString] -> AnyExpr+mkListOfBytesExpr (Expr desc eval) = AnyExpr desc (ListOfBytesFunc eval) -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+-- |+-- assertListOfBytes asserts that any expression is actually a list of bytes expression.+assertListOfBytes :: AnyExpr -> Either String (Expr [ByteString])+assertListOfBytes (AnyExpr desc (ListOfBytesFunc eval)) = Right $ Expr desc eval+assertListOfBytes (AnyExpr desc _) = Left $ "expected <" ++ show desc ++ "> to be of type bytes" -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+(<>) :: Ordering -> Ordering -> Ordering+(<>) EQ c = c+(<>) c _ = c -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+-- cmp is an efficient comparison function for expressions.+-- It is very important that cmp is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries.+cmp :: Desc -> Desc -> Ordering+cmp a b = compare (_hash a) (_hash b) <>+ compare (_name a) (_name b) <>+ compare (length (_params a)) (length (_params b)) <>+ foldl (<>) EQ (zipWith cmp (_params a) (_params b)) <>+ compare (_toStr a) (_toStr b) -- |--- 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)+-- hashWithName calculates a hash of the function name and its parameters.+hashWithName :: String -> [Desc] -> Int+hashWithName s ds = hashList (31*17 + hashString s) (map _hash ds) -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)+-- |+-- hashString calcuates a hash of a string.+hashString :: String -> Int+hashString s = hashList 0 (map ord s) -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)+-- |+-- hashList folds a list of hashes into one, given a seed and the list.+hashList :: Int -> [Int] -> Int+hashList = foldl (\acc h -> 31*acc + h) -simplifyExpr (BoolListElemFunc es e) = BoolListElemFunc (map simplifyExpr es) (simplifyExpr e)+noLabel :: Parsers.Label+noLabel = Parsers.String (pack "not a label, trying constant evaluation") -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)+-- |+-- evalConst tries to evaluate a constant expression and +-- either returns the resulting constant value or nothing.+evalConst :: Expr a -> Maybe a+evalConst e = if hasVar e+ then Nothing+ else case eval e noLabel of+ (Left _) -> Nothing+ (Right v) -> Just v -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)+-- |+-- isConst returns whether the input description is one of the six possible constant values.+isConst :: Desc -> Bool+isConst d = not (null (_params d)) && case _name d of+ "bool" -> True+ "int" -> True+ "uint" -> True+ "double" -> True+ "string" -> True+ "[]byte" -> True+ _ -> False -simplifyExpr (StringHasPrefixFunc e1 e2) = StringHasPrefixFunc (simplifyExpr e1) (simplifyExpr e2)-simplifyExpr (StringHasSuffixFunc e1 e2) = StringHasSuffixFunc (simplifyExpr e1) (simplifyExpr e2)+-- |+-- boolExpr creates a constant bool expression from a input value.+boolExpr :: Bool -> Expr Bool +boolExpr b = Expr {+ desc = Desc {+ _name = "bool"+ , _toStr = if b then "true" else "false"+ , _hash = if b then 3 else 5+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return b+} -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)+-- |+-- intExpr creates a constant int expression from a input value.+intExpr :: Int -> Expr Int+intExpr i = Expr {+ desc = Desc {+ _name = "int"+ , _toStr = show i+ , _hash = i+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return i+} -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)+-- |+-- doubleExpr creates a constant double expression from a input value.+doubleExpr :: Double -> Expr Double+doubleExpr d = Expr {+ desc = Desc {+ _name = "double"+ , _toStr = show d+ , _hash = truncate d+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return d+} -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)+-- |+-- uintExpr creates a constant uint expression from a input value.+uintExpr :: Word -> Expr Word+uintExpr i = Expr {+ desc = Desc {+ _name = "uint"+ , _toStr = show i+ , _hash = hashString (show i)+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return i+} -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)+-- |+-- stringExpr creates a constant string expression from a input value.+stringExpr :: Text -> Expr Text+stringExpr s = Expr {+ desc = Desc {+ _name = "string"+ , _toStr = show s+ , _hash = hashString (unpack s)+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return s+} -simplifyExpr (RegexFunc e1 e2) = RegexFunc (simplifyExpr e1) (simplifyExpr e2)+-- |+-- bytesExpr creates a constant bytes expression from a input value.+bytesExpr :: ByteString -> Expr ByteString+bytesExpr b = Expr {+ desc = Desc {+ _name = "bytes"+ , _toStr = "[]byte{" ++ show b ++ "}"+ , _hash = hashString (show b)+ , _params = []+ , _hasVar = False+ }+ , eval = const $ return b+} -simplifyExpr (DoubleListElemFunc es e) = DoubleListElemFunc (map simplifyExpr es) (simplifyExpr e)+-- |+-- trimBool tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimBool :: Expr Bool -> Expr Bool+trimBool e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> boolExpr v -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+-- |+-- trimInt tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimInt :: Expr Int -> Expr Int+trimInt e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> intExpr v -simplifyExpr (UintListElemFunc es e) = UintListElemFunc (map simplifyExpr es) (simplifyExpr e)+-- |+-- trimUint tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimUint :: Expr Word -> Expr Word+trimUint e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> uintExpr v -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+-- |+-- trimString tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimString :: Expr Text -> Expr Text+trimString e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> stringExpr v -simplifyExpr (BytesListElemFunc es e) = BytesListElemFunc (map simplifyExpr es) (simplifyExpr e)+-- |+-- trimDouble tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimDouble :: Expr Double -> Expr Double+trimDouble e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> doubleExpr v -simplifyExpr e = e+-- |+-- trimBytes tries to reduce an expression to a single constant expression,+-- if it does not contain a variable.+trimBytes :: Expr ByteString -> Expr ByteString+trimBytes e = if hasVar e + then e+ else case eval e noLabel of+ (Left _) -> e+ (Right v) -> bytesExpr v -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+-- |+-- boolsExpr sequences a list of expressions that each return a bool, +-- to a single expression that returns a list of bools.+boolsExpr :: [Expr Bool] -> Expr [Bool]+boolsExpr = seqExprs "[]bool" -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+-- |+-- intsExpr sequences a list of expressions that each return an int, +-- to a single expression that returns a list of ints.+intsExpr :: [Expr Int] -> Expr [Int]+intsExpr = seqExprs "[]int" -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+-- |+-- stringsExpr sequences a list of expressions that each return a string, +-- to a single expression that returns a list of strings.+stringsExpr :: [Expr Text] -> Expr [Text]+stringsExpr = seqExprs "[]string" -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+-- |+-- doublesExpr sequences a list of expressions that each return a double, +-- to a single expression that returns a list of doubles.+doublesExpr :: [Expr Double] -> Expr [Double]+doublesExpr = seqExprs "[]double" -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+-- |+-- listOfBytesExpr sequences a list of expressions that each return bytes, +-- to a single expression that returns a list of bytes.+listOfBytesExpr :: [Expr ByteString] -> Expr [ByteString]+listOfBytesExpr = seqExprs "[][]byte" -simplifyAndFunc v1 v2- | v1 == v2 = v1- | v1 == simplifyNotFunc v2 = Const False- | simplifyNotFunc v1 == v2 = Const False- | otherwise = AndFunc v1 v2+-- |+-- uintsExpr sequences a list of expressions that each return a uint, +-- to a single expression that returns a list of uints.+uintsExpr :: [Expr Word] -> Expr [Word]+uintsExpr = seqExprs "[]uint" -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+seqExprs :: String -> [Expr a] -> Expr [a]+seqExprs n es = Expr {+ desc = mkDesc n (map desc es)+ , eval = \v -> mapM (`eval` v) es+}
+ src/Exprs.hs view
@@ -0,0 +1,86 @@+-- |+-- This module contains the standard library of expressions, used by the Relapse parser.++module Exprs (+ mkBuiltIn+ , mkExpr+ , MkFunc+ , stdOnly+) where++import Expr+import Exprs.Compare+import Exprs.Contains+import Exprs.Elem+import Exprs.Length+import Exprs.Logic+import Exprs.Strings+import Exprs.Type+import Exprs.Var++-- |+-- MkFunc is used by the parser to create a function from a name and arguments.+type MkFunc = String -> [AnyExpr] -> Either String AnyExpr++-- |+-- mkExpr is a grouping of all the standard library functions as one MkFunc.+mkExpr :: String -> [AnyExpr] -> Either String AnyExpr+mkExpr "eq" es = mkEqExpr es+mkExpr "ne" es = mkNeExpr es+mkExpr "ge" es = mkGeExpr es+mkExpr "gt" es = mkGtExpr es+mkExpr "le" es = mkLeExpr es+mkExpr "lt" es = mkLtExpr es+mkExpr "contains" es = mkContainsExpr es+mkExpr "elem" es = mkElemExpr es+mkExpr "length" es = mkLengthExpr es+mkExpr "not" es = mkNotExpr es+mkExpr "and" es = mkAndExpr es+mkExpr "or" es = mkOrExpr es+mkExpr "hasPrefix" es = mkHasPrefixExpr es+mkExpr "hasSuffix" es = mkHasSuffixExpr es+mkExpr "regex" es = mkRegexExpr es+mkExpr "toLower" es = mkToLowerExpr es+mkExpr "toUpper" es = mkToUpperExpr es+mkExpr "type" es = mkTypeExpr es+mkExpr n _ = Left $ "unknown function: " ++ n++-- |+-- stdOnly contains no functions, which means that when it is combined +-- (in Relapse parser) with mkExpr the parser will have access to only the standard library.+stdOnly :: String -> [AnyExpr] -> Either String AnyExpr+stdOnly n _ = Left $ "unknown function: " ++ n++-- |+-- mkBuiltIn parsers a builtin function to a relapse expression.+mkBuiltIn :: String -> AnyExpr -> Either String AnyExpr+mkBuiltIn symbol constExpr = funcName symbol >>= (\n ->+ if n == "type" then+ mkExpr n [constExpr]+ else if n == "regex" then+ mkExpr n [constExpr, constToVar constExpr]+ else+ mkExpr n [constToVar constExpr, constExpr]+ )++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 n = fail $ "unexpected funcName: <" ++ n ++ ">"++constToVar :: AnyExpr -> AnyExpr+constToVar (AnyExpr _ (BoolFunc _)) = mkBoolExpr varBoolExpr+constToVar (AnyExpr _ (IntFunc _)) = mkIntExpr varIntExpr+constToVar (AnyExpr _ (UintFunc _)) = mkUintExpr varUintExpr+constToVar (AnyExpr _ (DoubleFunc _)) = mkDoubleExpr varDoubleExpr+constToVar (AnyExpr _ (StringFunc _)) = mkStringExpr varStringExpr+constToVar (AnyExpr _ (BytesFunc _)) = mkBytesExpr varBytesExpr
+ src/Exprs/Compare.hs view
@@ -0,0 +1,191 @@+-- |+-- This module contains the Relapse compare expressions: +-- equal, not equal, greater than, greater than or equal, less than and less than or equal.+module Exprs.Compare (+ mkEqExpr, eqExpr+ , mkNeExpr, neExpr+ , mkGeExpr, geExpr+ , mkLeExpr, leExpr+ , mkGtExpr, gtExpr+ , mkLtExpr, ltExpr+) where++import Expr++-- |+-- mkEqExpr dynamically creates an eq (equal) expression, if the two input types are the same.+mkEqExpr :: [AnyExpr] -> Either String AnyExpr+mkEqExpr es = do {+ (e1, e2) <- assertArgs2 "eq" es;+ case e1 of+ (AnyExpr _ (BoolFunc _)) -> mkEqExpr' <$> assertBool e1 <*> assertBool e2+ (AnyExpr _ (IntFunc _)) -> mkEqExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkEqExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkEqExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (StringFunc _)) -> mkEqExpr' <$> assertString e1 <*> assertString e2+ (AnyExpr _ (BytesFunc _)) -> mkEqExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkEqExpr' :: (Eq a) => Expr a -> Expr a -> AnyExpr+mkEqExpr' e f = mkBoolExpr $ eqExpr e f++-- |+-- eqExpr creates an eq (equal) expression that returns true if the two evaluated input expressions are equal+-- and both don't evaluate to an error.+eqExpr :: (Eq a) => Expr a -> Expr a -> Expr Bool+eqExpr a b = trimBool Expr {+ desc = mkDesc "eq" [desc a, desc b]+ , eval = \v -> eq (eval a v) (eval b v)+}++eq :: (Eq a) => Either String a -> Either String a -> Either String Bool+eq (Right v1) (Right v2) = return $ v1 == v2+eq (Left _) _ = return False+eq _ (Left _) = return False++-- |+-- mkNeExpr dynamically creates a ne (not equal) expression, if the two input types are the same.+mkNeExpr :: [AnyExpr] -> Either String AnyExpr+mkNeExpr es = do {+ (e1, e2) <- assertArgs2 "ne" es;+ case e1 of+ (AnyExpr _ (BoolFunc _)) -> mkNeExpr' <$> assertBool e1 <*> assertBool e2+ (AnyExpr _ (IntFunc _)) -> mkNeExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkNeExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkNeExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (StringFunc _)) -> mkNeExpr' <$> assertString e1 <*> assertString e2+ (AnyExpr _ (BytesFunc _)) -> mkNeExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkNeExpr' :: (Eq a) => Expr a -> Expr a -> AnyExpr+mkNeExpr' e f = mkBoolExpr $ neExpr e f++-- |+-- neExpr creates a ne (not equal) expression that returns true if the two evaluated input expressions are not equal+-- and both don't evaluate to an error.+neExpr :: (Eq a) => Expr a -> Expr a -> Expr Bool+neExpr a b = trimBool Expr {+ desc = mkDesc "ne" [desc a, desc b]+ , eval = \v -> ne (eval a v) (eval b v)+}++ne :: (Eq a) => Either String a -> Either String a -> Either String Bool+ne (Right v1) (Right v2) = return $ v1 /= v2+ne (Left _) _ = return False+ne _ (Left _) = return False++-- |+-- mkGeExpr dynamically creates a ge (greater than or equal) expression, if the two input types are the same.+mkGeExpr :: [AnyExpr] -> Either String AnyExpr+mkGeExpr es = do {+ (e1, e2) <- assertArgs2 "ge" es;+ case e1 of+ (AnyExpr _ (IntFunc _)) -> mkGeExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkGeExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkGeExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (BytesFunc _)) -> mkGeExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkGeExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr+mkGeExpr' e f = mkBoolExpr $ geExpr e f++-- |+-- geExpr creates a ge (greater than or equal) expression that returns true if the first evaluated expression is greater than or equal to the second+-- and both don't evaluate to an error.+geExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool+geExpr a b = trimBool Expr {+ desc = mkDesc "ge" [desc a, desc b]+ , eval = \v -> ge (eval a v) (eval b v)+}++ge :: (Ord a) => Either String a -> Either String a -> Either String Bool+ge (Right v1) (Right v2) = return $ v1 >= v2+ge (Left _) _ = return False+ge _ (Left _) = return False++-- |+-- mkGtExpr dynamically creates a gt (greater than) expression, if the two input types are the same.+mkGtExpr :: [AnyExpr] -> Either String AnyExpr+mkGtExpr es = do {+ (e1, e2) <- assertArgs2 "gt" es;+ case e1 of+ (AnyExpr _ (IntFunc _)) -> mkGtExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkGtExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkGtExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (BytesFunc _)) -> mkGtExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkGtExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr+mkGtExpr' e f = mkBoolExpr $ gtExpr e f++-- |+-- gtExpr creates a gt (greater than) expression that returns true if the first evaluated expression is greater than the second+-- and both don't evaluate to an error.+gtExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool+gtExpr a b = trimBool Expr {+ desc = mkDesc "gt" [desc a, desc b]+ , eval = \v -> gt (eval a v) (eval b v)+}++gt :: (Ord a) => Either String a -> Either String a -> Either String Bool+gt (Right v1) (Right v2) = return $ v1 > v2+gt (Left _) _ = return False+gt _ (Left _) = return False++-- |+-- mkLeExpr dynamically creates a le (less than or equal) expression, if the two input types are the same.+mkLeExpr :: [AnyExpr] -> Either String AnyExpr+mkLeExpr es = do {+ (e1, e2) <- assertArgs2 "le" es;+ case e1 of+ (AnyExpr _ (IntFunc _)) -> mkLeExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkLeExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkLeExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (BytesFunc _)) -> mkLeExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkLeExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr+mkLeExpr' e f = mkBoolExpr $ leExpr e f++-- |+-- leExpr creates a le (less than or equal) expression that returns true if the first evaluated expression is less than or equal to the second+-- and both don't evaluate to an error.+leExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool+leExpr a b = trimBool Expr {+ desc = mkDesc "le" [desc a, desc b]+ , eval = \v -> le (eval a v) (eval b v)+}++le :: (Ord a) => Either String a -> Either String a -> Either String Bool+le (Right v1) (Right v2) = return $ v1 <= v2+le (Left _) _ = return False+le _ (Left _) = return False++-- |+-- mkLtExpr dynamically creates a lt (less than) expression, if the two input types are the same.+mkLtExpr :: [AnyExpr] -> Either String AnyExpr+mkLtExpr es = do {+ (e1, e2) <- assertArgs2 "lt" es;+ case e1 of+ (AnyExpr _ (IntFunc _)) -> mkLtExpr' <$> assertInt e1 <*> assertInt e2+ (AnyExpr _ (UintFunc _)) -> mkLtExpr' <$> assertUint e1 <*> assertUint e2+ (AnyExpr _ (DoubleFunc _)) -> mkLtExpr' <$> assertDouble e1 <*> assertDouble e2+ (AnyExpr _ (BytesFunc _)) -> mkLtExpr' <$> assertBytes e1 <*> assertBytes e2+}++mkLtExpr' :: (Ord a) => Expr a -> Expr a -> AnyExpr+mkLtExpr' e f = mkBoolExpr $ ltExpr e f++-- |+-- ltExpr creates a lt (less than) expression that returns true if the first evaluated expression is less than the second+-- and both don't evaluate to an error.+ltExpr :: (Ord a) => Expr a -> Expr a -> Expr Bool+ltExpr a b = trimBool Expr {+ desc = mkDesc "lt" [desc a, desc b]+ , eval = \v -> lt (eval a v) (eval b v)+}++lt :: (Ord a) => Either String a -> Either String a -> Either String Bool+lt (Right v1) (Right v2) = return $ v1 < v2+lt (Left _) _ = return False+lt _ (Left _) = return False
+ src/Exprs/Contains.hs view
@@ -0,0 +1,48 @@+-- |+-- This module contains the Relapse contains expressions.+module Exprs.Contains (+ mkContainsExpr+ , containsStringExpr+ , containsExpr+) where++import qualified Data.Text as Text++import Expr++-- |+-- mkContainsExpr dynamically creates a contains expression, if the two input types are:+-- +-- * String and String where the second string is the possible substring.+-- * A List of :Strings, Ints or Uints paired with a String, Int or Uint respectively.+mkContainsExpr :: [AnyExpr] -> Either String AnyExpr+mkContainsExpr es = do {+ (e1, e2) <- assertArgs2 "contains" es;+ case e2 of+ (AnyExpr _ (StringFunc _)) -> mkContainsStringExpr' <$> assertString e1 <*> assertString e2+ (AnyExpr _ (StringsFunc _)) -> mkContainsExpr' <$> assertString e1 <*> assertStrings e2+ (AnyExpr _ (IntsFunc _)) -> mkContainsExpr' <$> assertInt e1 <*> assertInts e2+ (AnyExpr _ (UintsFunc _)) -> mkContainsExpr' <$> assertUint e1 <*> assertUints e2+}++mkContainsStringExpr' :: Expr Text.Text -> Expr Text.Text -> AnyExpr+mkContainsStringExpr' e f = mkBoolExpr $ containsStringExpr e f++-- |+-- containsStringExpr creates a contains expression that returns true if the second string is a substring of the first.+containsStringExpr :: Expr Text.Text -> Expr Text.Text -> Expr Bool+containsStringExpr s sub = trimBool Expr {+ desc = mkDesc "contains" [desc s, desc sub]+ , eval = \v -> Text.isInfixOf <$> eval sub v <*> eval s v+}++mkContainsExpr' :: (Eq a) => Expr a -> Expr [a] -> AnyExpr+mkContainsExpr' e f = mkBoolExpr $ containsExpr e f++-- |+-- containsExpr creates a contains expression that returns true if the first argument is an element in the second list argument.+containsExpr :: (Eq a) => Expr a -> Expr [a] -> Expr Bool+containsExpr e es = trimBool Expr {+ desc = mkDesc "contains" [desc e, desc es]+ , eval = \v -> elem <$> eval e v <*> eval es v+}
+ src/Exprs/Elem.hs view
@@ -0,0 +1,35 @@+-- |+-- This module contains the Relapse elem expression.+module Exprs.Elem (+ mkElemExpr+ , elemExpr+) where++import Expr++-- |+-- mkElemExpr dynamically creates an elem expression, if the first argument is a list and the second an int index.+mkElemExpr :: [AnyExpr] -> Either String AnyExpr+mkElemExpr es = do {+ (e1, e2) <- assertArgs2 "elem" es;+ case e1 of+ (AnyExpr _ (BoolsFunc _)) -> mkElemExpr' mkBoolExpr <$> assertBools e1 <*> assertInt e2+ (AnyExpr _ (IntsFunc _)) -> mkElemExpr' mkIntExpr <$> assertInts e1 <*> assertInt e2+ (AnyExpr _ (UintsFunc _)) -> mkElemExpr' mkUintExpr <$> assertUints e1 <*> assertInt e2+ (AnyExpr _ (DoublesFunc _)) -> mkElemExpr' mkDoubleExpr <$> assertDoubles e1 <*> assertInt e2+ (AnyExpr _ (StringsFunc _)) -> mkElemExpr' mkStringExpr <$> assertStrings e1 <*> assertInt e2+ (AnyExpr _ (ListOfBytesFunc _)) -> mkElemExpr' mkBytesExpr <$> assertListOfBytes e1 <*> assertInt e2+}++mkElemExpr' :: (Expr a -> AnyExpr) -> Expr [a] -> Expr Int -> AnyExpr+mkElemExpr' mk list index = mk $ elemExpr list index++-- | +-- elemExpr creates an expression that returns an element from the list at the specified index.+-- Trimming this function would cause it to become non generic.+-- It is not necessary to trim each function, since it is just an optimization.+elemExpr :: Expr [a] -> Expr Int -> Expr a+elemExpr a b = Expr {+ desc = mkDesc "elem" [desc a, desc b]+ , eval = \v -> (!!) <$> eval a v <*> eval b v+}
+ src/Exprs/Length.hs view
@@ -0,0 +1,54 @@+-- |+-- This module contains the Relapse length expressions.+module Exprs.Length (+ mkLengthExpr+ , lengthListExpr+ , lengthStringExpr+ , lengthBytesExpr+) where++import qualified Data.Text as Text+import qualified Data.ByteString as ByteString++import Expr++-- |+-- mkLengthExpr dynamically creates a length expression, if the single argument is a list, string or bytes.+mkLengthExpr :: [AnyExpr] -> Either String AnyExpr+mkLengthExpr es = do {+ e <- assertArgs1 "length" es;+ case e of+ (AnyExpr _ (BoolsFunc _)) -> mkIntExpr . lengthListExpr <$> assertBools e;+ (AnyExpr _ (IntsFunc _)) -> mkIntExpr . lengthListExpr <$> assertInts e;+ (AnyExpr _ (UintsFunc _)) -> mkIntExpr . lengthListExpr <$> assertUints e;+ (AnyExpr _ (DoublesFunc _)) -> mkIntExpr . lengthListExpr <$> assertDoubles e;+ (AnyExpr _ (StringsFunc _)) -> mkIntExpr . lengthListExpr <$> assertStrings e;+ (AnyExpr _ (ListOfBytesFunc _)) -> mkIntExpr . lengthListExpr <$> assertListOfBytes e;+ (AnyExpr _ (StringFunc _)) -> mkIntExpr . lengthStringExpr <$> assertString e;+ (AnyExpr _ (BytesFunc _)) -> mkIntExpr . lengthBytesExpr <$> assertBytes e;+}++-- |+-- lengthListExpr creates a length expression, that returns the length of a list.+lengthListExpr :: Expr [a] -> Expr Int+lengthListExpr e = trimInt Expr {+ desc = mkDesc "length" [desc e]+ , eval = \v -> length <$> eval e v+}++-- |+-- lengthStringExpr creates a length expression, that returns the length of a string.+lengthStringExpr :: Expr Text.Text -> Expr Int+lengthStringExpr e = trimInt Expr {+ desc = mkDesc "length" [desc e]+ , eval = \v -> Text.length <$> eval e v+}++-- |+-- lengthBytesExpr creates a length expression, that returns the length of bytes.+lengthBytesExpr :: Expr ByteString.ByteString -> Expr Int+lengthBytesExpr e = trimInt Expr {+ desc = mkDesc "length" [desc e]+ , eval = \v -> ByteString.length <$> eval e v+}+
+ src/Exprs/Logic.hs view
@@ -0,0 +1,128 @@+-- |+-- This module contains the Relapse logic expressions: not, and, or. +module Exprs.Logic (+ mkNotExpr, notExpr+ , mkAndExpr, andExpr+ , mkOrExpr, orExpr+) where++import Expr+import Exprs.Var++-- |+-- mkNotExpr dynamically creates a not expression, if the single argument is a bool expression.+mkNotExpr :: [AnyExpr] -> Either String AnyExpr+mkNotExpr es = do {+ e <- assertArgs1 "not" es;+ b <- assertBool e;+ return $ mkBoolExpr (notExpr b);+}++-- |+-- notExpr creates a not expression, that returns true is the argument expression returns an error or false.+notExpr :: Expr Bool -> Expr Bool+notExpr e = trimBool Expr {+ desc = notDesc (desc e)+ , eval = \v -> case eval e v of+ (Left _) -> return True+ (Right b) -> return $ not b+}++-- notDesc superficially pushes not operators down to normalize functions.+-- Normalizing functions increases the chances of finding equal expressions and being able to simplify patterns.+notDesc :: Desc -> Desc+notDesc d+ | _name d == "not" = + let child0 = head $ _params d+ in mkDesc (_name child0) (_params child0)+ | _name d == "and" =+ let [left, right] = _params d+ in mkDesc "or" [mkDesc "not" [left], mkDesc "not" [right]]+ | _name d == "or" =+ let [left, right] = _params d+ in mkDesc "and" [mkDesc "not" [left], mkDesc "not" [right]]+ | _name d == "ne" = mkDesc "eq" $ _params d+ | _name d == "eq" = mkDesc "ne" $ _params d+ | otherwise = mkDesc "not" [d]++-- |+-- mkAndExpr dynamically creates an and expression, if the two arguments are both bool expressions.+mkAndExpr :: [AnyExpr] -> Either String AnyExpr+mkAndExpr es = do {+ (e1, e2) <- assertArgs2 "and" es;+ b1 <- assertBool e1;+ b2 <- assertBool e2;+ return $ mkBoolExpr $ andExpr b1 b2;+}++-- |+-- andExpr creates an and expression that returns true if both arguments are true.+andExpr :: Expr Bool -> Expr Bool -> Expr Bool+andExpr a b = case (evalConst a, evalConst b) of+ (Just False, _) -> boolExpr False+ (_, Just False) -> boolExpr False+ (Just True, _) -> b+ (_, Just True) -> a+ _ -> andExpr' a b++-- andExpr' creates an `and` expression, but assumes that both expressions have a var.+andExpr' :: Expr Bool -> Expr Bool -> Expr Bool+andExpr' a b+ | a == b = a+ | name a == "not" && head (params a) == desc b = boolExpr False+ | name b == "not" && head (params b) == desc a = boolExpr False+ | name a == "eq" && name b == "eq" = case (varAndConst a, varAndConst b) of+ (Just ca, Just cb) -> if ca == cb then a else boolExpr False+ _ -> defaultAnd a b+ | name a == "eq" && name b == "ne" = case (varAndConst a, varAndConst b) of+ (Just ca, Just cb) -> if ca == cb then boolExpr False else a+ _ -> defaultAnd a b+ | name a == "ne" && name b == "eq" = case (varAndConst a, varAndConst b) of+ (Just ca, Just cb) -> if ca == cb then boolExpr False else b+ _ -> defaultAnd a b+ | otherwise = defaultAnd a b++defaultAnd :: Expr Bool -> Expr Bool -> Expr Bool+defaultAnd a b = Expr {+ desc = mkDesc "and" [desc a, desc b]+ , eval = \v -> (&&) <$> eval a v <*> eval b v+}++varAndConst :: Expr Bool -> Maybe Desc+varAndConst e = let ps = params e+ in if length ps /= 2 then Nothing+ else let [a,b] = ps in+ if isVar a && isConst b then Just b+ else if isVar b && isConst a then Just a+ else Nothing++-- |+-- mkOrExpr dynamically creates an or expression, if the two arguments are both bool expressions.+mkOrExpr :: [AnyExpr] -> Either String AnyExpr+mkOrExpr es = do {+ (e1, e2) <- assertArgs2 "or" es;+ b1 <- assertBool e1;+ b2 <- assertBool e2;+ return $ mkBoolExpr $ orExpr b1 b2;+}++-- |+-- orExpr creates an or expression that returns true if either argument is true.+orExpr :: Expr Bool -> Expr Bool -> Expr Bool+orExpr a b = case (evalConst a, evalConst b) of+ (Just True, _) -> boolExpr True+ (_, Just True) -> boolExpr True+ (Just False, _) -> b+ (_, Just False) -> a+ _ -> orExpr' a b++-- orExpr' creates an `or` expression, but assumes that both expressions have a var.+orExpr' :: Expr Bool -> Expr Bool -> Expr Bool+orExpr' a b+ | a == b = a+ | name a == "not" && head (params a) == desc b = boolExpr True+ | name b == "not" && head (params b) == desc a = boolExpr True+ | otherwise = Expr {+ desc = mkDesc "or" [desc a, desc b]+ , eval = \v -> (||) <$> eval a v <*> eval b v+ }
+ src/Exprs/Strings.hs view
@@ -0,0 +1,107 @@+-- |+-- This module contains the Relapse string expressions.++module Exprs.Strings (+ mkHasPrefixExpr, hasPrefixExpr+ , mkHasSuffixExpr, hasSuffixExpr+ , mkRegexExpr, regexExpr+ , mkToLowerExpr, toLowerExpr+ , mkToUpperExpr, toUpperExpr+) where++import Text.Regex.TDFA ((=~))+import Data.Text (Text, isPrefixOf, isSuffixOf, toLower, toUpper, unpack)++import Expr++-- |+-- mkHasPrefixExpr dynamically creates a hasPrefix expression.+mkHasPrefixExpr :: [AnyExpr] -> Either String AnyExpr+mkHasPrefixExpr es = do {+ (e1, e2) <- assertArgs2 "hasPrefix" es;+ s1 <- assertString e1;+ s2 <- assertString e2;+ return $ mkBoolExpr $ hasPrefixExpr s1 s2;+}++-- |+-- hasPrefixExpr creates a hasPrefix expression that returns true if the second is a prefix of the first.+hasPrefixExpr :: Expr Text -> Expr Text -> Expr Bool+hasPrefixExpr e1 e2 = trimBool Expr {+ desc = mkDesc "hasPrefix" [desc e1, desc e2]+ , eval = \v -> isPrefixOf <$> eval e2 v <*> eval e1 v+}++-- |+-- mkHasSuffixExpr dynamically creates a hasSuffix expression.+mkHasSuffixExpr :: [AnyExpr] -> Either String AnyExpr+mkHasSuffixExpr es = do {+ (e1, e2) <- assertArgs2 "hasSuffix" es;+ s1 <- assertString e1;+ s2 <- assertString e2;+ return $ mkBoolExpr $ hasSuffixExpr s1 s2;+}++-- |+-- hasSuffixExpr creates a hasSuffix expression that returns true if the second is a suffix of the first.+hasSuffixExpr :: Expr Text -> Expr Text -> Expr Bool+hasSuffixExpr e1 e2 = trimBool Expr {+ desc = mkDesc "hasSuffix" [desc e1, desc e2]+ , eval = \v -> isSuffixOf <$> eval e2 v <*> eval e1 v+}++-- |+-- mkRegexExpr dynamically creates a regex expression.+mkRegexExpr :: [AnyExpr] -> Either String AnyExpr+mkRegexExpr es = do {+ (e1, e2) <- assertArgs2 "regex" es;+ e <- assertString e1;+ s <- assertString e2;+ return $ mkBoolExpr $ regexExpr e s;+}++-- |+-- regexExpr creates a regex expression that returns true if the first expression matches the second string. +regexExpr :: Expr Text -> Expr Text -> Expr Bool+regexExpr e s = trimBool Expr {+ desc = mkDesc "regex" [desc e, desc s]+ , eval = \v -> do {+ s1 <- eval s v;+ e1 <- eval e v;+ return $ (=~) (unpack s1) (unpack e1);+ }+}++-- |+-- mkToLowerExpr dynamically creates a toLower expression.+mkToLowerExpr :: [AnyExpr] -> Either String AnyExpr+mkToLowerExpr es = do {+ e <- assertArgs1 "toLower" es;+ s <- assertString e;+ return $ mkStringExpr $ toLowerExpr s;+}++-- |+-- toLowerExpr creates a toLower expression that converts the input string to a lowercase string.+toLowerExpr :: Expr Text -> Expr Text+toLowerExpr e = trimString Expr {+ desc = mkDesc "toLower" [desc e]+ , eval = \v -> toLower <$> eval e v+}++-- |+-- mkToUpperExpr dynamically creates a toUpper expression.+mkToUpperExpr :: [AnyExpr] -> Either String AnyExpr+mkToUpperExpr es = do {+ e <- assertArgs1 "toUpper" es;+ s <- assertString e;+ return $ mkStringExpr $ toUpperExpr s;+}++-- |+-- toUpperExpr creates a toUpper expression that converts the input string to an uppercase string.+toUpperExpr :: Expr Text -> Expr Text+toUpperExpr e = trimString Expr {+ desc = mkDesc "toUpper" [desc e]+ , eval = \v -> toUpper <$> eval e v+}
+ src/Exprs/Type.hs view
@@ -0,0 +1,36 @@+-- |+-- This module contains the Relapse type expression.++module Exprs.Type (+ mkTypeExpr+ , typeExpr+) where++import Expr++-- |+-- mkTypeExpr is used by the parser to create a type expression for the specific input type.+mkTypeExpr :: [AnyExpr] -> Either String AnyExpr+mkTypeExpr es = do {+ e <- assertArgs1 "type" es; + case e of+ (AnyExpr _ (BoolFunc _)) -> mkBoolExpr . typeExpr <$> assertBool e;+ (AnyExpr _ (IntFunc _)) -> mkBoolExpr . typeExpr <$> assertInt e;+ (AnyExpr _ (UintFunc _)) -> mkBoolExpr . typeExpr <$> assertUint e;+ (AnyExpr _ (DoubleFunc _)) -> mkBoolExpr . typeExpr <$> assertDouble e;+ (AnyExpr _ (StringFunc _)) -> mkBoolExpr . typeExpr <$> assertString e;+ (AnyExpr _ (BytesFunc _)) -> mkBoolExpr . typeExpr <$> assertBytes e;+}++-- |+-- typeExpr creates an expression that returns true if the containing expression does not return an error.+-- For example: `(typeExpr varBoolExpr)` will ony return true is the field value is a bool.+typeExpr :: Expr a -> Expr Bool+typeExpr e = Expr {+ desc = mkDesc "type" [desc e]+ , eval = \v -> case eval e v of+ (Left _) -> return False+ (Right _) -> return True+}++
+ src/Exprs/Var.hs view
@@ -0,0 +1,126 @@+-- |+-- This module contains all expressions for Relapse variables.++module Exprs.Var (+ varBoolExpr+ , varIntExpr+ , varUintExpr+ , varDoubleExpr+ , varStringExpr+ , varBytesExpr+ , isVar+) where++import Data.Text (Text)+import Data.ByteString (ByteString)++import qualified Parsers+import Expr++-- |+-- isVar returns whether an expression is one of the six variable expressions.+isVar :: Desc -> Bool+isVar d = null (_params d) && case _name d of+ "$bool" -> True+ "$int" -> True+ "$uint" -> True+ "$double" -> True+ "$string" -> True+ "$[]byte" -> True+ _ -> False++-- |+-- varBoolExpr creates a bool variable expression.+varBoolExpr :: Expr Bool+varBoolExpr = Expr {+ desc = Desc {+ _name = "$bool"+ , _toStr = "$bool"+ , _hash = hashWithName "$bool" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.Bool b) -> Right b+ _ -> Left "not a bool"+}++-- |+-- varIntExpr creates an int variable expression.+varIntExpr :: Expr Int+varIntExpr = Expr {+ desc = Desc {+ _name = "$int"+ , _toStr = "$int"+ , _hash = hashWithName "$int" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.Int i) -> Right i+ _ -> Left "not an int"+}++-- |+-- varUintExpr creates a uint variable expression.+varUintExpr :: Expr Word+varUintExpr = Expr {+ desc = Desc {+ _name = "$uint"+ , _toStr = "$uint"+ , _hash = hashWithName "$uint" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.Uint u) -> Right u+ _ -> Left "not a uint"+}++-- |+-- varDoubleExpr creates a double variable expression.+varDoubleExpr :: Expr Double+varDoubleExpr = Expr {+ desc = Desc {+ _name = "$double"+ , _toStr = "$double"+ , _hash = hashWithName "$double" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.Double d) -> Right d+ _ -> Left "not a double"+}++-- |+-- varStringExpr creates a string variable expression.+varStringExpr :: Expr Text+varStringExpr = Expr {+ desc = Desc {+ _name = "$string"+ , _toStr = "$string"+ , _hash = hashWithName "$string" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.String s) -> Right s+ _ -> Left "not a string"+}++-- |+-- varBytesExpr creates a bytes variable expression.+varBytesExpr :: Expr ByteString+varBytesExpr = Expr {+ desc = Desc {+ _name = "$[]byte"+ , _toStr = "$[]byte"+ , _hash = hashWithName "$[]byte" []+ , _params = []+ , _hasVar = True+ }+ , eval = \l -> case l of+ (Parsers.Bytes b) -> Right b+ _ -> Left "not bytes"+}
src/IfExprs.hs view
@@ -9,19 +9,23 @@ ZippedIfExprs, zipIfExprs, evalZippedIfExprs ) where -import Control.Monad.Except (Except)--import Patterns+import Smart import Expr+import Exprs.Logic import Simplify import Zip import Parsers +-- |+-- IfExpr contains a condition and a return pattern for each of the two cases. newtype IfExpr = IfExpr (Expr Bool, Pattern, Pattern) +-- |+-- newIfExpr creates an IfExpr. newIfExpr :: Expr Bool -> Pattern -> Pattern -> IfExpr newIfExpr c t e = IfExpr (c, t, e) +-- | IfExprs is a tree of if expressions, which contains a list of resulting patterns on each of its leaves. data IfExprs = Cond { cond :: Expr Bool@@ -30,38 +34,34 @@ } | Ret [Pattern] -compileIfExprs :: Refs -> [IfExpr] -> IfExprs-compileIfExprs _ [] = Ret []-compileIfExprs refs (e:es) = let (IfExpr ifExpr) = simplifyIf refs e- in addIfExpr ifExpr (compileIfExprs refs es)+-- | compileIfExprs compiles a list of if expressions in an IfExprs tree, for efficient evaluation.+compileIfExprs :: [IfExpr] -> IfExprs+compileIfExprs [] = Ret []+compileIfExprs (IfExpr ifExpr:es) = addIfExpr ifExpr (compileIfExprs es) -evalIfExprs :: IfExprs -> Label -> Except ValueErr [Pattern]+-- | valIfExprs evaluates a tree of if expressions and returns the resulting patterns or an error.+evalIfExprs :: IfExprs -> Label -> Either String [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)+ | boolExpr False == andExpr c cs = Cond cs (addRet e ts) (addIfExpr (c, t, e) es)+ | boolExpr False == andExpr (notExpr 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) +-- |+-- ZippedIfExprs is a tree of if expressions, but with a zipped pattern list and a zipper on each of the leaves. data ZippedIfExprs = ZippedCond { zcond :: Expr Bool@@ -70,11 +70,13 @@ } | ZippedRet [Pattern] Zipper +-- | zipIfExprs compresses an if expression tree's leaves. 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 evaulates a ZippedIfExprs tree and returns the zipped pattern list and zipper from the resulting leaf.+evalZippedIfExprs :: ZippedIfExprs -> Label -> Either String ([Pattern], Zipper) evalZippedIfExprs (ZippedRet ps zs) _ = return (ps, zs) evalZippedIfExprs (ZippedCond c t e) v = do { b <- eval c v;
src/Json.hs view
@@ -8,6 +8,8 @@ ) where import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject)+import Data.Ratio (denominator)+import Data.Text (pack) import qualified Data.Tree as DataTree import Parsers@@ -30,17 +32,19 @@ 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 (JSRational _ r) = if denominator r /= 1 + then [DataTree.Node (Double (fromRational r :: Double)) []]+ else [DataTree.Node (Int $ truncate r) []]+uValue (JSString s) = [DataTree.Node (String $ pack $ 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+uArray index (v:vs) = DataTree.Node (Int 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)+uKeyValue (name, value) = DataTree.Node (String $ pack name) (uValue value)
src/MemDerive.hs view
@@ -8,16 +8,15 @@ -- This module provides memoization of the nullable, calls and returns functions. module MemDerive (- derive, Mem, newMem, nullable, validate+ derive, Mem, newMem, 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 Control.Monad.Trans.Either (EitherT, runEitherT, left, hoistEither) import qualified Derive-import qualified Patterns-import Patterns (Refs, Pattern)+import Smart (Grammar, Pattern, lookupRef, nullable, lookupMain) import IfExprs import Expr import Zip@@ -29,69 +28,60 @@ | 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)+newtype Mem = Mem (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))+newMem = Mem (M.empty, M.empty) -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))+calls :: Grammar -> [Pattern] -> State Mem IfExprs+calls g k = state $ \(Mem (c, r)) -> let (v', c') = mem (Derive.calls g) k c;+ in (v', Mem (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'))+returns :: Grammar -> ([Pattern], [Bool]) -> State Mem [Pattern]+returns g k = state $ \(Mem (c, r)) -> let (v', r') = mem (Derive.returns g) k r;+ in (v', Mem (c, r')) -mderive :: Tree t => Refs -> [Pattern] -> [t] -> ExceptT ValueErr (State Mem) [Pattern]+mderive :: Tree t => Grammar -> [Pattern] -> [t] -> EitherT String (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- ;+mderive g ps (tree:ts) = do {+ ifs <- lift $ calls g ps;+ childps <- hoistEither $ evalIfExprs ifs (getLabel tree); (zchildps, zipper) <- return $ zippy childps;- childres <- mderive refs zchildps (getChildren tree);- nulls <- lift $ mapM (nullable refs) childres;- let unzipns = unzipby zipper nulls+ childres <- mderive g zchildps (getChildren tree);+ let + nulls = map nullable childres+ unzipns = unzipby zipper nulls ;- rs <- lift $ returns refs (ps, unzipns);- mderive refs rs ts+ rs <- lift $ returns g (ps, unzipns);+ mderive g 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+derive :: Tree t => Grammar -> [t] -> Either String Pattern+derive g ts =+ let start = [lookupMain g]+ (res, _) = runState (runEitherT $ mderive g start ts) newMem in case res of- (Left l) -> throwError $ show l+ (Left l) -> Left l (Right [r]) -> return r- (Right rs) -> throwError $ "not a single pattern: " ++ show rs+ (Right rs) -> Left $ "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- }+validate :: Tree t => Grammar -> Pattern -> [t] -> (State Mem) Bool+validate g start tree = do {+ rs <- runEitherT (mderive g [start] tree);+ return $ case rs of+ (Right [r]) -> nullable r+ _ -> False+}
− src/ParsePatterns.hs
@@ -1,420 +0,0 @@-{-#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 [constExpr]- else if name == "regex" then- newFunction name [constExpr, constToVar constExpr]- else- newFunction name [constToVar constExpr, 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
@@ -3,7 +3,7 @@ module Parser ( -- * Parse Grammar- parseGrammar+ parseGrammar, parseGrammarWithUDFs -- * Internal functions -- | These functions are exposed for testing purposes. , grammar, pattern, nameExpr, expr, @@ -13,15 +13,28 @@ import Text.ParserCombinators.Parsec import Numeric (readDec, readOct, readHex, readFloat) import Data.Char (chr)+import qualified Data.Text as Text+import qualified Data.ByteString.Char8 as ByteString+import Control.Arrow (left) import Expr-import Patterns-import ParsePatterns+import Exprs+import Exprs.Logic+import Exprs.Var+import Ast -- | parseGrammar parses the Relapse Grammar.-parseGrammar :: String -> Either ParseError Refs-parseGrammar = parse (grammar <* eof) ""+parseGrammar :: String -> Either String Grammar+parseGrammar = parseGrammarWithUDFs stdOnly +-- | parseGrammarWithUDFs parses the Relapse Grammar with extra user defined functions.+parseGrammarWithUDFs :: MkFunc -> String -> Either String Grammar+parseGrammarWithUDFs extraUDFs str = + let mkFunc n es = case mkExpr n es of+ (Left _) -> extraUDFs n es+ (Right v) -> return v+ in left show $ parse (grammar mkFunc <* eof) "" str+ infixl 4 <++> (<++>) :: CharParser () String -> CharParser () String -> CharParser () String f <++> g = (++) <$> f <*> g@@ -30,6 +43,11 @@ (<::>) :: CharParser () Char -> CharParser () String -> CharParser () String f <::> g = (:) <$> f <*> g +check :: Either String a -> CharParser () a+check e = case e of+ (Left err) -> fail err+ (Right v) -> return v+ empty :: CharParser () String empty = return "" @@ -48,6 +66,7 @@ _ws :: CharParser () () _ws = _comment <|> () <$ space +-- | For internal testing ws :: CharParser () () ws = () <$ many _ws @@ -83,14 +102,24 @@ <|> return 0 ) +-- | For internal testing intLit :: CharParser () Int intLit = string "int(" *> _signedIntLit <* char ')' <|> _signedIntLit <?> "int_lit" -uintCastLit :: CharParser () Int-uintCastLit = string "uint(" *> _intLit <* char ')'+uintLit :: CharParser () Word+uintLit = do {+ i <- intLit;+ if i < 0+ then fail "negative uint" + else return $ fromIntegral i;+} +-- | For internal testing+uintCastLit :: CharParser () Word+uintCastLit = string "uint(" *> uintLit <* char ')'+ _exponent :: CharParser () String _exponent = oneOf "eE" <::> ( oneOf "+-" <::> many1 digit @@ -110,9 +139,11 @@ <|> empty _read readFloat (i ++ e) +-- | For internal testing doubleCastLit :: CharParser () Double doubleCastLit = string "double(" *> ((*) <$> _optionalSign <*> _floatLit) <* char ')' +-- | For internal testing idLit :: CharParser () String idLit = (letter <|> char '_') <::> many (alphaNum <|> char '_') @@ -151,8 +182,9 @@ _rawString :: CharParser () String _rawString = between (char '`') (char '`') (many $ noneOf "`") -stringLit :: CharParser () String-stringLit = _rawString <|> _interpretedString+-- | For internal testing+stringLit :: CharParser () Text.Text+stringLit = Text.pack <$> (_rawString <|> _interpretedString) _hexByteUValue :: CharParser () Char _hexByteUValue = char 'x' *> do {@@ -180,25 +212,26 @@ _byteElem :: CharParser () Char _byteElem = _byteLit <|> between (char '\'') (char '\'') (_unicodeValue <|> _octalByteUValue <|> _hexByteUValue) -bytesCastLit :: CharParser () String-bytesCastLit = string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}'+-- | For internal testing+bytesCastLit :: CharParser () ByteString.ByteString+bytesCastLit = ByteString.pack <$> (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+_literal :: CharParser () AnyExpr+_literal = mkBoolExpr . boolExpr <$> bool+ <|> mkIntExpr . intExpr <$> intLit+ <|> mkUintExpr . uintExpr <$> uintCastLit+ <|> mkDoubleExpr . doubleExpr <$> doubleCastLit+ <|> mkStringExpr . stringExpr <$> stringLit+ <|> mkBytesExpr . bytesExpr <$> bytesCastLit -_terminal :: CharParser () ParsedExpr+_terminal :: CharParser () AnyExpr _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" ))+ mkBoolExpr varBoolExpr <$ string "bool"+ <|> mkIntExpr varIntExpr <$ string "int"+ <|> mkUintExpr varUintExpr <$ string "uint"+ <|> mkDoubleExpr varDoubleExpr <$ string "double"+ <|> mkStringExpr varStringExpr <$ string "string"+ <|> mkBytesExpr varBytesExpr <$ string "[]byte" )) <|> _literal _builtinSymbol :: CharParser () String@@ -212,15 +245,11 @@ <|> 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+_builtin :: MkFunc -> CharParser () AnyExpr+_builtin mkFunc = mkBuiltIn <$> _builtinSymbol <*> (ws *> _expr mkFunc) >>= check -_function :: CharParser () ParsedExpr-_function = newFunction <$> idLit <*> (char '(' *> sepBy (ws *> _expr <* ws) (char ',') <* char ')') >>= check+_function :: MkFunc -> CharParser () AnyExpr+_function mkFunc = mkFunc <$> idLit <*> (char '(' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char ')') >>= check _listType :: CharParser () String _listType = char '[' <::> char ']' <::> (@@ -231,53 +260,36 @@ <|> 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+_mustBool :: AnyExpr -> CharParser () (Expr Bool)+_mustBool = check . assertBool -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+newList :: String -> [AnyExpr] -> CharParser () AnyExpr+newList "[]bool" es = mkBoolsExpr . boolsExpr <$> mapM (check . assertBool) es+newList "[]int" es = mkIntsExpr . intsExpr <$> mapM (check . assertInt) es+newList "[]uint" es = mkUintsExpr . uintsExpr <$> mapM (check . assertUint) es+newList "[]double" es = mkDoublesExpr . doublesExpr <$> mapM (check . assertDouble) es+newList "[]string" es = mkStringsExpr . stringsExpr <$> mapM (check . assertString) es+newList "[][]byte" es = mkListOfBytesExpr . listOfBytesExpr <$> mapM (check . assertBytes) es -_list :: CharParser () ParsedExpr-_list = do {+_list :: MkFunc -> CharParser () AnyExpr+_list mkFunc = do { ltype <- _listType;- es <- ws *> char '{' *> sepBy (ws *> _expr <* ws) (char ',') <* char '}';+ es <- ws *> char '{' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char '}'; newList ltype es } -_expr :: CharParser () ParsedExpr-_expr = try _terminal <|> _list <|> _function+_expr :: MkFunc -> CharParser () AnyExpr+_expr mkFunc = try _terminal <|> _list mkFunc <|> _function mkFunc -expr :: CharParser () (Expr Bool)-expr = (try _terminal <|> _builtin <|> _function) >>= _mustBool+-- | For internal testing+expr :: MkFunc -> CharParser () (Expr Bool)+expr mkFunc = (try _terminal <|> _builtin mkFunc <|> _function mkFunc) >>= _mustBool -_name :: CharParser () (Expr Bool)-_name = (newBuiltIn "==" <$> (_literal <|> (StringExpr . Const <$> idLit))) >>= check >>= _mustBool+_nameString :: CharParser () (Expr Bool)+_nameString = (mkBuiltIn "==" <$> + (_literal <|> + (mkStringExpr . stringExpr . Text.pack <$> idLit))) + >>= check >>= _mustBool sepBy2 :: CharParser () a -> String -> CharParser () [a] sepBy2 p sep = do {@@ -289,25 +301,26 @@ } _nameChoice :: CharParser () (Expr Bool)-_nameChoice = foldl1 OrFunc <$> sepBy2 (ws *> nameExpr <* ws) "|"+_nameChoice = foldl1 orExpr <$> sepBy2 (ws *> nameExpr <* ws) "|" +-- | For internal testing nameExpr :: CharParser () (Expr Bool)-nameExpr = (Const True <$ char '_')- <|> (NotFunc <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')'))+nameExpr = (boolExpr True <$ char '_')+ <|> (notExpr <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')')) <|> (char '(' *> ws *> _nameChoice <* ws <* char ')')- <|> _name+ <|> _nameString -_concatPattern :: CharParser () Pattern-_concatPattern = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern <* ws) ",") <* optional (char ',' <* ws) <* char ']'+_concatPattern :: MkFunc -> CharParser () Pattern+_concatPattern mkFunc = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern mkFunc <* ws) ",") <* optional (char ',' <* ws) <* char ']' -_interleavePattern :: CharParser () Pattern-_interleavePattern = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern <* ws) ";") <* optional (char ';' <* ws) <* char '}'+_interleavePattern :: MkFunc -> CharParser () Pattern+_interleavePattern mkFunc = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern mkFunc <* ws) ";") <* optional (char ';' <* ws) <* char '}' -_parenPattern :: CharParser () Pattern-_parenPattern = do {+_parenPattern :: MkFunc -> CharParser () Pattern+_parenPattern mkFunc = do { char '('; ws;- first <- pattern;+ first <- pattern mkFunc; ws; ( char ')' *> ws *> (@@ -316,23 +329,23 @@ ) ) <|> ( (- (first <$ char '|' >>= _orList) <|> - (first <$ char '&' >>= _andList)+ (first <$ char '|' >>= _orList mkFunc) <|> + (first <$ char '&' >>= _andList mkFunc) ) <* char ')' ) } -_orList :: Pattern -> CharParser () Pattern-_orList p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern <* ws) (char '|')+_orList :: MkFunc -> Pattern -> CharParser () Pattern+_orList mkFunc p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern mkFunc <* ws) (char '|') -_andList :: Pattern -> CharParser () Pattern-_andList p = And p . foldl1 And <$> sepBy1 (ws *> pattern <* ws) (char '&')+_andList :: MkFunc -> Pattern -> CharParser () Pattern+_andList mkFunc p = And p . foldl1 And <$> sepBy1 (ws *> pattern mkFunc <* ws) (char '&') _refPattern :: CharParser () Pattern _refPattern = Reference <$> (char '@' *> ws *> idLit) -_notPattern :: CharParser () Pattern-_notPattern = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern <* ws <* char ')')+_notPattern :: MkFunc -> CharParser () Pattern+_notPattern mkFunc = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern mkFunc <* ws <* char ')') _emptyPattern :: CharParser () Pattern _emptyPattern = Empty <$ string "<empty>"@@ -340,34 +353,36 @@ _zanyPattern :: CharParser () Pattern _zanyPattern = ZAny <$ string "*" -_containsPattern :: CharParser () Pattern-_containsPattern = Contains <$> (char '.' *> pattern)+_containsPattern :: MkFunc -> CharParser () Pattern+_containsPattern mkFunc = Contains <$> (char '.' *> pattern mkFunc) -_treenodePattern :: CharParser () Pattern-_treenodePattern = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern) <|> _depthPattern ) )+_treenodePattern :: MkFunc -> CharParser () Pattern+_treenodePattern mkFunc = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern mkFunc) <|> _depthPattern mkFunc) ) -_depthPattern :: CharParser () Pattern-_depthPattern = _concatPattern <|> _interleavePattern <|> _containsPattern - <|> flip Node Empty <$> ( (string "->" *> expr ) <|> (_builtin >>= _mustBool) )+_depthPattern :: MkFunc -> CharParser () Pattern+_depthPattern mkFunc = _concatPattern mkFunc <|> _interleavePattern mkFunc<|> _containsPattern mkFunc+ <|> flip Node Empty <$> ( (string "->" *> expr mkFunc) <|> (_builtin mkFunc>>= _mustBool) ) -newContains :: CharParser () ParsedExpr -> CharParser () Pattern-newContains e = flip Node Empty <$> ((newBuiltIn "*=" <$> e) >>= check >>= _mustBool)+newContains :: CharParser () AnyExpr -> CharParser () Pattern+newContains e = flip Node Empty <$> ((mkBuiltIn "*=" <$> e) >>= check >>= _mustBool) -pattern :: CharParser () Pattern-pattern = char '*' *> (- (char '=' *> (newContains (ws *> _expr)))+-- | For internal testing+pattern :: MkFunc -> CharParser () Pattern+pattern mkFunc = char '*' *> (+ (char '=' *> newContains (ws *> _expr mkFunc)) <|> return ZAny- ) <|> _parenPattern+ ) <|> _parenPattern mkFunc <|> _refPattern <|> try _emptyPattern- <|> try _treenodePattern- <|> try _depthPattern- <|> _notPattern+ <|> try (_treenodePattern mkFunc)+ <|> try (_depthPattern mkFunc)+ <|> _notPattern mkFunc -_patternDecl :: CharParser () Refs-_patternDecl = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern)+_patternDecl :: MkFunc -> CharParser () Grammar+_patternDecl mkFunc = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern mkFunc) -grammar :: CharParser () Refs-grammar = ws *> (foldl1 union <$> many1 (_patternDecl <* ws))- <|> union <$> (newRef "main" <$> pattern) <*> (foldl union emptyRef <$> many (ws *> _patternDecl <* ws))+-- | For internal testing+grammar :: MkFunc -> CharParser () Grammar+grammar mkFunc = ws *> (foldl1 union <$> many1 (_patternDecl mkFunc <* ws))+ <|> union <$> (newRef "main" <$> pattern mkFunc) <*> (foldl union emptyRef <$> many (ws *> _patternDecl mkFunc <* ws))
src/Parsers.hs view
@@ -11,13 +11,24 @@ import Control.DeepSeq (NFData) import GHC.Generics (Generic)+import Data.Text (Text)+import Data.ByteString (ByteString) +-- |+-- Label is a tagged union of all possible value types that can returned by a katydid parser: +-- String, Int, Uint, Double, Bool and Bytes. data Label- = String String- | Number Rational+ = String Text+ | Int Int+ | Uint Word+ | Double Double | Bool Bool+ | Bytes ByteString deriving (Show, Eq, Ord, Generic, NFData) +-- |+-- Tree is the type class that should be implemented by a katydid parser.+-- This is implemented by the Json and XML parser. class Tree a where getLabel :: a -> Label getChildren :: a -> [a]
− src/Patterns.hs
@@ -1,109 +0,0 @@--- |--- 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
@@ -14,39 +14,53 @@ -- If your tree has a single root, simply provide a singleton list as input. module Relapse (- parseGrammar, validate, filter+ parse, parseWithUDFs, Grammar+ , 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 Ast import qualified MemDerive+import qualified Smart import Parsers+import qualified Exprs +-- | Grammar represents a compiled relapse grammar.+newtype Grammar = Grammar Smart.Grammar+ -- |--- 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+-- parse parses the relapse grammar and returns either a parsed grammar or an error string.+parse :: String -> Either String Grammar+parse grammarString = do {+ parsed <- Parser.parseGrammar grammarString;+ Grammar <$> Smart.compile parsed;+} -- |--- 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+-- parseWithUDFs parses the relapse grammar with extra user defined functions+-- and returns either a parsed grammar or an error string.+parseWithUDFs :: Exprs.MkFunc -> String -> Either String Grammar+parseWithUDFs userLib grammarString = do {+ parsed <- Parser.parseGrammarWithUDFs userLib grammarString;+ Grammar <$> Smart.compile parsed;+}++-- |+-- validate returns whether a tree is valid, given the grammar.+validate :: Tree t => Grammar -> [t] -> Bool+validate g tree = case filter g [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+-- filter returns a filtered list of trees, given the grammar.+filter :: Tree t => Grammar -> [[t]] -> [[t]]+filter (Grammar g) trees = + let start = Smart.lookupMain g+ f = filterM (MemDerive.validate g start) trees (r, _) = runState f MemDerive.newMem in r
src/Simplify.hs view
@@ -9,21 +9,22 @@ import qualified Data.Set as S -import Patterns+import Ast import Expr+import Exprs.Logic -- | -- 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+simplify :: Grammar -> Pattern -> Pattern+simplify g pat =+ let simp = simplify' g+ in case pat of Empty -> Empty ZAny -> ZAny- (Node v p) -> simplifyNode (simplifyBoolExpr v) (simp p)+ (Node v p) -> simplifyNode 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)+ (Or p1 p2) -> simplifyOr g (simp p1) (simp p2)+ (And p1 p2) -> simplifyAnd g (simp p1) (simp p2) (ZeroOrMore p) -> simplifyZeroOrMore (simp p) (Not p) -> simplifyNot (simp p) (Optional p) -> simplifyOptional (simp p)@@ -31,12 +32,13 @@ (Contains p) -> simplifyContains (simp p) p@(Reference _) -> p -simplify' :: Refs -> Pattern -> Pattern-simplify' refs p = checkRef refs $ simplify refs p+simplify' :: Grammar -> Pattern -> Pattern+simplify' g p = checkRef g $ simplify g p simplifyNode :: Expr Bool -> Pattern -> Pattern-simplifyNode (Const False) _ = Not ZAny-simplifyNode v p = Node v p+simplifyNode v p = case evalConst v of+ (Just False) -> Not ZAny+ _ -> Node v p simplifyConcat :: Pattern -> Pattern -> Pattern simplifyConcat (Not ZAny) _ = Not ZAny@@ -48,17 +50,17 @@ simplifyConcat ZAny (Concat p ZAny) = Contains p simplifyConcat p1 p2 = Concat p1 p2 -simplifyOr :: Refs -> Pattern -> Pattern -> Pattern+simplifyOr :: Grammar -> 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+simplifyOr _ (Node v1 Empty) (Node v2 Empty) = Node (orExpr v1 v2) Empty+simplifyOr g Empty p + | nullable g p == Right True = p | otherwise = Or Empty p-simplifyOr refs p Empty- | nullable refs p = p +simplifyOr g p Empty+ | nullable g p == Right True = p | otherwise = Or Empty p simplifyOr _ p1 p2 = bin Or $ simplifyChildren Or $ S.toAscList $ setOfOrs p1 `S.union` setOfOrs p2 @@ -79,17 +81,17 @@ setOfOrs (Or p1 p2) = setOfOrs p1 `S.union` setOfOrs p2 setOfOrs p = S.singleton p -simplifyAnd :: Refs -> Pattern -> Pattern -> Pattern+simplifyAnd :: Grammar -> 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+simplifyAnd _ (Node v1 Empty) (Node v2 Empty) = Node (andExpr v1 v2) Empty+simplifyAnd g Empty p+ | nullable g p == Right True = Empty | otherwise = Not ZAny-simplifyAnd refs p Empty- | nullable refs p = Empty+simplifyAnd g p Empty+ | nullable g p == Right True = Empty | otherwise = Not ZAny simplifyAnd _ p1 p2 = bin And $ simplifyChildren And $ S.toAscList $ setOfAnds p1 `S.union` setOfAnds p2 @@ -127,8 +129,8 @@ simplifyContains (Not ZAny) = Not ZAny simplifyContains p = Contains p -checkRef :: Refs -> Pattern -> Pattern-checkRef refs p = case reverseLookupRef p refs of+checkRef :: Grammar -> Pattern -> Pattern+checkRef g p = case reverseLookupRef p g of Nothing -> p (Just k) -> Reference k
+ src/Smart.hs view
@@ -0,0 +1,417 @@+-- |+-- This module describes the smart constructors for Relapse patterns.+module Smart (+ Pattern(..)+ , Grammar+ , lookupRef+ , compile+ , emptyPat, zanyPat, nodePat+ , orPat, andPat, notPat + , concatPat, interleavePat+ , zeroOrMorePat, optionalPat+ , containsPat, refPat+ , emptySet+ , unescapable+ , nullable+ , lookupMain+) where++import qualified Data.Map.Strict as M+import qualified Data.Set as S+import Data.List (sort, sortBy, intercalate)+import Control.Monad (when)++import qualified Expr+import Exprs.Logic (orExpr, andExpr)+import qualified Ast++-- | compile complies an ast into a smart grammar.+compile :: Ast.Grammar -> Either String Grammar+compile g = do {+ Ast.lookupRef g "main"; -- making sure that the main reference exists.+ hasRec <- Ast.hasRecursion g;+ when hasRec $ Left "recursion without interleaved treenode not supported";+ refs <- M.fromList <$> mapM (\name -> do {+ p <- Ast.lookupRef g name;+ return (name, p)+ }) (Ast.listRefs g);+ nullRefs <- mapM (Ast.nullable g) refs;+ Grammar <$> mapM (smart nullRefs) refs+}++smart :: M.Map String Bool -> Ast.Pattern -> Either String Pattern+smart _ Ast.Empty = return emptyPat+smart nulls (Ast.Node e p) = nodePat e <$> smart nulls p+smart nulls (Ast.Concat a b) = concatPat <$> smart nulls a <*> smart nulls b+smart nulls (Ast.Or a b) = orPat <$> smart nulls a <*> smart nulls b+smart nulls (Ast.And a b) = andPat <$> smart nulls a <*> smart nulls b+smart nulls (Ast.ZeroOrMore p) = zeroOrMorePat <$> smart nulls p+smart nulls (Ast.Reference name) = refPat nulls name+smart nulls (Ast.Not p) = notPat <$> smart nulls p+smart _ Ast.ZAny = return zanyPat+smart nulls (Ast.Contains p) = containsPat <$> smart nulls p+smart nulls (Ast.Optional p) = optionalPat <$> smart nulls p+smart nulls (Ast.Interleave a b) = interleavePat <$> smart nulls a <*> smart nulls b++-- |+-- Pattern recursively describes a Relapse Pattern.+data Pattern = Empty+ | Node {+ expr :: Expr.Expr Bool+ , pat :: Pattern+ , _hash :: Int+ }+ | Concat {+ left :: Pattern+ , right :: Pattern+ , _nullable :: Bool+ , _hash :: Int+ }+ | Or {+ pats :: [Pattern]+ , _nullable :: Bool+ , _hash :: Int+ }+ | And {+ pats :: [Pattern]+ , _nullable :: Bool+ , _hash :: Int+ }+ | ZeroOrMore {+ pat :: Pattern+ , _hash :: Int+ }+ | Reference {+ refName :: ValidRef+ , _nullable :: Bool+ , _hash :: Int+ }+ | Not {+ pat :: Pattern+ , _nullable :: Bool+ , _hash :: Int+ }+ | ZAny+ | Contains {+ pat :: Pattern+ , _nullable :: Bool+ , _hash :: Int+ }+ | Optional {+ pat :: Pattern+ , _hash :: Int+ }+ | Interleave {+ pats :: [Pattern]+ , _nullable :: Bool+ , _hash :: Int+ }+ deriving (Eq, Ord)++instance Show Pattern where+ show = toStr++toStr :: Pattern -> String+toStr Empty = "<empty>"+toStr Node{expr=e, pat=p} = show e ++ ":" ++ show p+toStr Concat{left=l,right=r} = "[" ++ show l ++ "," ++ show r ++ "]"+toStr Or{pats=ps} = "(" ++ intercalate "|" (map show ps) ++ ")"+toStr And{pats=ps} = "(" ++ intercalate "&" (map show ps) ++ ")"+toStr ZeroOrMore{pat=p} = "(" ++ show p ++ ")*"+toStr Reference{refName=(ValidRef n)} = "@"++n+toStr Not{pat=p} = "!(" ++ show p ++ ")"+toStr ZAny = "*"+toStr Contains{pat=p} = "." ++ show p+toStr Optional{pat=p} = "(" ++ show p ++ ")?"+toStr Interleave{pats=ps} = "{" ++ intercalate ";" (map show ps) ++ "}"++-- cmp is an efficient comparison function for patterns.+-- It is very important that cmp is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries.+cmp :: Pattern -> Pattern -> Ordering+cmp a b = if hashcmp == EQ then compare a b else hashcmp+ where hashcmp = compare (hash a) (hash b)++-- eq is an efficient comparison function for patterns.+-- It is very important that eq is efficient, +-- because it is a bottleneck for simplification and smart construction of large queries.+eq :: Pattern -> Pattern -> Bool+eq a b = cmp a b == EQ++hash :: Pattern -> Int+hash Empty = 3+hash Node{_hash=h} = h+hash Concat{_hash=h} = h+hash Or{_hash=h} = h+hash And{_hash=h} = h+hash ZeroOrMore{_hash=h} = h+hash Reference{_hash=h} = h+hash Not{_hash=h} = h+hash ZAny = 5+hash Contains{_hash=h} = h+hash Optional{_hash=h} = h+hash Interleave{_hash=h} = h++-- | nullable returns whether the pattern matches the empty string.+nullable :: Pattern -> Bool+nullable Empty = True+nullable Node{} = False+nullable Concat{_nullable=n} = n+nullable Or{_nullable=n} = n+nullable And{_nullable=n} = n+nullable ZeroOrMore{} = True+nullable Reference{_nullable=n} = n+nullable Not{_nullable=n} = n+nullable ZAny = True+nullable Contains{_nullable=n} = n+nullable Optional{} = True+nullable Interleave{_nullable=n} = n++-- | emptyPat is the smart constructor for the empty pattern.+emptyPat :: Pattern+emptyPat = Empty++-- | zanyPat is the smart constructor for the zany pattern.+zanyPat :: Pattern+zanyPat = ZAny++-- | notPat is the smart constructor for the not pattern.+notPat :: Pattern -> Pattern+notPat Not {pat=p} = p+notPat p = Not {+ pat = p+ , _nullable = not $ nullable p+ , _hash = 31 * 7 + hash p+}++-- | emptySet is the smart constructor for the !(*) pattern.+emptySet :: Pattern+emptySet = notPat zanyPat++-- | nodePat is the smart constructor for the node pattern.+nodePat :: Expr.Expr Bool -> Pattern -> Pattern+nodePat e p =+ case Expr.evalConst e of+ (Just False) -> emptySet+ _ -> Node {+ expr = e+ , pat = p+ , _hash = 31 * (11 + 31 * Expr._hash (Expr.desc e)) + hash p+ }++isLeaf :: Pattern -> Bool+isLeaf Node{pat=Empty} = True+isLeaf _ = False++-- | concatPat is the smart constructor for the concat pattern.+concatPat :: Pattern -> Pattern -> Pattern+concatPat notZAny@Not{pat=ZAny} _ = notZAny+concatPat _ notZAny@Not{pat=ZAny} = notZAny+concatPat Empty b = b+concatPat a Empty = a+concatPat Concat{left=a1, right=a2} b = concatPat a1 (concatPat a2 b)+concatPat ZAny Concat{left=b1, right=ZAny} = containsPat b1+concatPat a b = Concat {+ left = a+ , right = b + , _nullable = nullable a && nullable b+ , _hash = 31 * (13 + 31 * hash a) + hash b+}++-- | containsPat is the smart constructor for the contains pattern.+containsPat :: Pattern -> Pattern+containsPat Empty = ZAny+containsPat p@ZAny = p+containsPat p@Not{pat=ZAny} = p+containsPat p = Contains {+ pat = p+ , _nullable = nullable p+ , _hash = 31 * 17 + hash p+}++-- | optionalPat is the smart constructor for the optional pattern.+optionalPat :: Pattern -> Pattern+optionalPat p@Empty = p+optionalPat p@Optional{} = p+optionalPat p = Optional {+ pat = p+ , _hash = 31 * 19 + hash p+}++-- | zeroOrMorePat is the smart constructor for the zeroOrMore pattern.+zeroOrMorePat :: Pattern -> Pattern+zeroOrMorePat p@ZeroOrMore{} = p+zeroOrMorePat p = ZeroOrMore {+ pat = p+ , _hash = 31 * 23 + hash p+}++-- | refPat is the smart constructor for the reference pattern.+refPat :: M.Map String Bool -> String -> Either String Pattern+refPat nullRefs name = + case M.lookup name nullRefs of+ Nothing -> Left $ "no reference named: " ++ name+ (Just n) -> Right Reference {+ refName = ValidRef name+ , _hash = 31 * 29 + Expr.hashString name+ , _nullable = n+ }++-- | orPat is the smart constructor for the or pattern.+orPat :: Pattern -> Pattern -> Pattern+orPat a b = orPat' $ S.fromList (getOrs a ++ getOrs b)++getOrs :: Pattern -> [Pattern]+getOrs Or{pats=ps} = ps+getOrs p = [p]++orPat' :: S.Set Pattern -> Pattern+orPat' ps = ps `returnIfSingleton`+ \ps -> if S.member zanyPat ps+ then zanyPat+ else S.delete emptySet ps `returnIfSingleton`+ \ps -> (if all nullable ps+ then S.delete emptyPat ps+ else ps) `returnIfSingleton`+ \ps -> mergeLeaves orExpr ps `returnIfSingleton`+ \ps -> mergeNodesWithEqualNames orPat ps `returnIfSingleton`+ \ps -> let psList = sort $ S.toList ps+ in Or {+ pats = psList+ , _nullable = any nullable psList+ , _hash = Expr.hashList (31*33) $ map hash psList+ }++-- | andPat is the smart constructor for the and pattern.+andPat :: Pattern -> Pattern -> Pattern+andPat a b = andPat' $ S.fromList (getAnds a ++ getAnds b)++getAnds :: Pattern -> [Pattern]+getAnds And{pats=ps} = ps+getAnds p = [p]++andPat' :: S.Set Pattern -> Pattern+andPat' ps = ps `returnIfSingleton`+ \ps -> if S.member emptySet ps+ then emptySet+ else S.delete zanyPat ps `returnIfSingleton`+ \ps -> if S.member emptyPat ps+ then if all nullable ps+ then emptyPat+ else emptySet + else ps `returnIfSingleton`+ \ps -> mergeLeaves andExpr ps `returnIfSingleton`+ \ps -> mergeNodesWithEqualNames andPat ps `returnIfSingleton`+ \ps -> let psList = sort $ S.toList ps + in And {+ pats = psList+ , _nullable = all nullable psList+ , _hash = Expr.hashList (31*37) $ map hash psList+ }++-- | returnIfSingleton returns the pattern from the set if the set is of size one, otherwise it applies the function to the set.+returnIfSingleton :: S.Set Pattern -> (S.Set Pattern -> Pattern) -> Pattern+returnIfSingleton s1 f =+ if S.size s1 == 1 then head $ S.toList s1 else f s1++mergeLeaves :: (Expr.Expr Bool -> Expr.Expr Bool -> Expr.Expr Bool) -> S.Set Pattern -> S.Set Pattern+mergeLeaves merger = merge $ \a b -> case (a,b) of+ (Node{expr=ea,pat=Empty},Node{expr=eb,pat=Empty}) -> [nodePat (merger ea eb) emptyPat]+ _ -> [a,b]++mergeNodesWithEqualNames :: (Pattern -> Pattern -> Pattern) -> S.Set Pattern -> S.Set Pattern+mergeNodesWithEqualNames merger = merge $ \a b -> case (a,b) of+ (Node{expr=ea,pat=pa},Node{expr=eb,pat=pb}) -> + if ea == eb then [nodePat ea (merger pa pb)] else [a,b]+ _ -> [a,b]++merge :: (Pattern -> Pattern -> [Pattern]) -> S.Set Pattern -> S.Set Pattern+merge merger ps = let list = sortBy leavesThenNamesAndThenContains (S.toList ps)+ in S.fromList $ foldl (\(a:merged) b -> merger a b ++ merged) [head list] (tail list)++leavesThenNamesAndThenContains :: Pattern -> Pattern -> Ordering+leavesThenNamesAndThenContains a@Node{} b@Node{} = leavesFirst a b+leavesThenNamesAndThenContains Node{} _ = LT+leavesThenNamesAndThenContains _ Node{} = GT+leavesThenNamesAndThenContains a b = containsThird a b++leavesFirst :: Pattern -> Pattern -> Ordering+leavesFirst a b+ | isLeaf a && isLeaf b = compare a b+ | isLeaf a = LT+ | isLeaf b = GT+ | otherwise = namesSecond a b++namesSecond :: Pattern -> Pattern -> Ordering+namesSecond a@Node{expr=ea} b@Node{expr=eb} = let fcomp = compare ea eb+ in if fcomp == EQ + then compare a b+ else fcomp++containsThird :: Pattern -> Pattern -> Ordering+containsThird a@Contains{} b@Contains{} = compare a b+containsThird Contains{} _ = LT+containsThird _ Contains{} = GT+containsThird a b = compare a b++-- | interleavePat is the smart constructor for the interleave pattern.+interleavePat :: Pattern -> Pattern -> Pattern+interleavePat a b = interleavePat' (getInterleaves a ++ getInterleaves b)++getInterleaves :: Pattern -> [Pattern]+getInterleaves Interleave{pats=ps} = ps+getInterleaves p = [p]++interleavePat' :: [Pattern] -> Pattern+interleavePat' ps+ | emptySet `elem` ps = emptySet+ | all (eq Empty) ps = emptyPat+ | otherwise = delete Empty ps `returnIfOnlyOne`+ \ps -> (if any (eq ZAny) ps+ then zanyPat : delete ZAny ps+ else ps) `returnIfOnlyOne`+ \ps -> let psList = sort ps+ in Interleave {+ pats = psList+ , _nullable = all nullable psList+ , _hash = Expr.hashList (31*41) $ map hash psList+ }++-- | returnIfOnlyOne returns the pattern from the list if the list is of size one, otherwise it applies the function to the list.+returnIfOnlyOne :: [Pattern] -> ([Pattern] -> Pattern) -> Pattern+returnIfOnlyOne xs f = if length xs == 1 then head xs else f xs++delete :: Pattern -> [Pattern] -> [Pattern]+delete removeItem = filter (not . (\p -> p == removeItem))++-- |+-- 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{pat=ZAny} = True+unescapable _ = False++-- |+-- Grammar is a map from reference name to pattern and describes a relapse grammar.+newtype Grammar = Grammar Refs+ deriving (Show, Eq)++-- |+-- Refs is a map from reference name to pattern, excluding the main reference, which makes a relapse grammar.+type Refs = M.Map String Pattern++newtype ValidRef = ValidRef String+ deriving (Eq, Ord, Show)++-- |+-- lookupRef looks up a pattern in the reference map, given a reference name.+lookupRef :: Grammar -> ValidRef -> Pattern+lookupRef (Grammar refs) (ValidRef name) = + case M.lookup name refs of+ Nothing -> error $ "valid reference not found: " ++ name+ (Just p) -> p++-- | lookupMain retrieves the main pattern from the grammar.+lookupMain :: Grammar -> Pattern+lookupMain g = lookupRef g (ValidRef "main")
src/VpaDerive.hs view
@@ -1,9 +1,9 @@ -- |--- This module contains a VPA (Visual Pushdown Automaton) implementation of the internal derivative algorithm.+-- This module contains a VPA (Visibly 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.+-- It shows how our algorithm is effectively equivalent to a visibly pushdown automaton. module VpaDerive ( derive @@ -12,11 +12,11 @@ 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 Control.Monad.Trans.Either (EitherT, runEitherT, left, hoistEither) import qualified Derive-import Patterns (Refs, Pattern)-import qualified Patterns+import Smart (Grammar, Pattern)+import qualified Smart import IfExprs import Expr import Zip@@ -35,36 +35,34 @@ type Nullable = M.Map [Pattern] [Bool] type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern] -newtype Vpa = Vpa (Nullable, Calls, Returns, Refs)+newtype Vpa = Vpa (Nullable, Calls, Returns, Grammar) -newVpa :: Refs -> Vpa-newVpa refs = Vpa (M.empty, M.empty, M.empty, refs)+newVpa :: Grammar -> Vpa+newVpa g = Vpa (M.empty, M.empty, M.empty, g) 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))+nullable key = state $ \(Vpa (n, c, r, g)) -> let (v', n') = mem (map Smart.nullable) key n;+ in (v', Vpa (n', c, r, g)) 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))+calls key = state $ \(Vpa (n, c, r, g)) -> let (v', c') = mem (zipIfExprs . Derive.calls g) key c;+ in (v', Vpa (n, c', r, g)) -vpacall :: VpaState -> Label -> ExceptT ValueErr (State Vpa) (StackElm, VpaState)+vpacall :: VpaState -> Label -> EitherT String (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)+ (nextstate, zipper) <- hoistEither $ evalZippedIfExprs zifexprs label;+ let + stackelm = (vpastate, zipper) ; return (stackelm, nextstate) } returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern]-returns key = state $ \(Vpa (n, c, r, refs)) -> +returns key = state $ \(Vpa (n, c, r, g)) -> let (v', r') = mem (\(ps, zipper, znulls) -> - Derive.returns refs (ps, unzipby zipper znulls)) key r- in (v', Vpa (n, c, r', refs))+ Derive.returns g (ps, unzipby zipper znulls)) key r+ in (v', Vpa (n, c, r', g)) vpareturn :: StackElm -> VpaState -> State Vpa VpaState vpareturn (vpastate, zipper) current = do {@@ -72,25 +70,28 @@ returns (vpastate, zipper, zipnulls) } -deriv :: Tree t => VpaState -> t -> ExceptT ValueErr (State Vpa) VpaState+deriv :: Tree t => VpaState -> t -> EitherT String (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 :: Tree t => Vpa -> VpaState -> [t] -> Either String [Pattern] foldLT _ current [] = return current foldLT m current (t:ts) = - let (newstate, newm) = runState (runExceptT $ deriv current t) m+ let (newstate, newm) = runState (runEitherT $ deriv current t) m in case newstate of- (Left l) -> throwError l+ (Left l) -> Left 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+-- |+-- derive is the derivative implementation for trees.+-- This implementation makes use of visual pushdown automata.+derive :: Tree t => Grammar -> [t] -> Either String Pattern+derive g ts = + let start = [Smart.lookupMain g]+ in case foldLT (newVpa g) start ts of+ (Left l) -> Left $ show l (Right [r]) -> return r- (Right rs) -> throwError $ "Number of patterns is not one, but " ++ show rs+ (Right rs) -> Left $ "Number of patterns is not one, but " ++ show rs
src/Xml.hs view
@@ -11,11 +11,12 @@ import Text.XML.HXT.DOM.TypeDefs (XmlTree, XNode(..), blobToString, localPart) import Text.XML.HXT.Parser.XmlParsec (xread) import Data.Tree.NTree.TypeDefs (NTree(..))+import qualified Data.Text as Text import Parsers instance Tree XmlTree where- getLabel (NTree n _ ) = either (String . ("XML Parse Error:" ++)) id (xmlLabel n)+ getLabel (NTree n _ ) = either (String . Text.pack . ("XML Parse Error:" ++)) id (xmlLabel n) getChildren (NTree _ cs) = cs -- |@@ -38,4 +39,4 @@ -- TODO what about other leaf types parseLabel :: String -> Label-parseLabel s = maybe (String s) (Number . toRational) (readMaybe s :: Maybe Int)+parseLabel s = maybe (String (Text.pack s)) Int (readMaybe s :: Maybe Int)
src/Zip.hs view
@@ -10,28 +10,34 @@ import qualified Data.Set as S import Data.List (elemIndex) -import Patterns+import Smart data ZipEntry = ZipVal Int | ZipZAny | ZipNotZAny deriving (Eq, Ord) +-- |+-- Zipper represents compressed indexes+-- that resulted from compressing a list of patterns.+-- This can be used to uncompress a list of bools (nullability of patterns). newtype Zipper = Zipper [ZipEntry] deriving (Eq, Ord) +-- | zippy compresses a list of patterns. zippy :: [Pattern] -> ([Pattern], Zipper) zippy ps = let s = S.fromList ps s' = S.delete ZAny s- s'' = S.delete (Not ZAny) s'+ s'' = S.delete emptySet s' l = S.toAscList s'' in (l, Zipper $ map (indexOf l) ps) indexOf :: [Pattern] -> Pattern -> ZipEntry indexOf _ ZAny = ZipZAny-indexOf _ (Not ZAny) = ZipNotZAny+indexOf _ Not{pat=ZAny} = ZipNotZAny indexOf ps p = case elemIndex p ps of (Just i) -> ZipVal i +-- | unzipby uncompresses a list of bools (nullability of patterns). unzipby :: Zipper -> [Bool] -> [Bool] unzipby (Zipper z) bs = map (ofIndexb bs) z
+ test/DeriveSpec.hs view
@@ -0,0 +1,48 @@+{-# LANGUAGE FlexibleInstances #-}++-- | +-- This module DeriveSpec tests the Derive module.+module DeriveSpec (+ tests+) where++import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as HUnit++import Data.Tree+import qualified Derive+import qualified Parser+import qualified Smart+import qualified Parsers++import Data.List.Index (imap)++instance Parsers.Tree (Tree Parsers.Label) where+ getLabel (Node l _) = l+ getChildren (Node _ cs) = cs++tests = T.testGroup "Derive" [+ T.testGroup "derive" [+ HUnit.testCase "two ors" $+ either HUnit.assertFailure (\(want,got) -> HUnit.assertEqual "(want,got)" want got) $ do {+ input <- Parser.parseGrammar "(== 1 | !(== 2))" >>= Smart.compile;+ want <- Parser.parseGrammar "*" >>= Smart.compile;+ got <- Derive.derive input [Node (Parsers.Int 1) []];+ return (Smart.lookupMain want, got)+ }+ , HUnit.testCase "two interleaves" $+ either HUnit.assertFailure (\(want,got) -> HUnit.assertEqual "(want,got)" want got) $ do {+ input <- Parser.parseGrammar "{== 1 ; !(== 2)}" >>= Smart.compile;+ want <- Parser.parseGrammar "({<empty>;!(==2)}|{==1;*})" >>= Smart.compile;+ got <- Derive.derive input [Node (Parsers.Int 1) []];+ return (Smart.lookupMain want, got)+ }+ ]+ , T.testGroup "removeOneForEach" [+ HUnit.testCase "[1,2]" $+ HUnit.assertEqual "1,2" [[2],[1]] $ Derive.removeOneForEach [1,2]+ , HUnit.testCase "[1,2,3]" $+ HUnit.assertEqual "1,2,3" [[2,3],[1,3],[1,2]] $ Derive.removeOneForEach [1,2,3]+ , HUnit.testCase "[1]" $+ HUnit.assertEqual "1" [[]] $ Derive.removeOneForEach [1]+ ]]
test/ParserSpec.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ -- | -- This module ParserSpec tests the Parser module. module ParserSpec (@@ -11,8 +13,19 @@ import Parser import Expr-import Patterns+import Exprs.Compare+import Exprs.Contains+import Exprs.Elem+import Exprs.Length+import Exprs.Logic+import Exprs.Strings+import Exprs.Type+import Exprs.Var+import Exprs+import Ast +import UserDefinedFuncs+ success :: (Eq a, Show a) => String -> CharParser () a -> String -> a -> T.TestTree success name p input want = HUnit.testCase name $ case parse (p <* eof) "" input of (Left err) -> HUnit.assertFailure $ "given input: " ++ input ++ " got error: " ++ show err@@ -86,109 +99,115 @@ success "id with underscore" idLit "abc_123" "abc_123", failure "id starts with number" idLit "123abc", - success "expr bool var" expr "$bool" BoolVariable,- success "expr bool const" expr "true" (Const True),- success "expr ==" expr "== true" (BoolEqualFunc BoolVariable (Const True)),- success "expr *=" expr "*= \"a\"" (StringContainsFunc StringVariable (Const "a")),- success "expr not" expr "not(true)" (NotFunc (Const True)),- success "expr eq bool" expr "eq($bool, true)" (BoolEqualFunc BoolVariable (Const True)),- success "expr eq int" expr "eq($int, 1)" (IntEqualFunc IntVariable (Const 1)),- failure "expr eq type mismatch" expr "eq($bool, 1)",- success "expr list" expr "eq($int, length([]int{1,2}))" (IntEqualFunc IntVariable (IntListLengthFunc [Const 1, Const 2])),+ success "expr bool var" (expr mkExpr) "$bool" varBoolExpr,+ success "expr bool const" (expr mkExpr) "true" (boolExpr True),+ success "expr ==" (expr mkExpr) "== true" (eqExpr varBoolExpr (boolExpr True)),+ success "expr *=" (expr mkExpr) "*= \"a\"" (containsStringExpr varStringExpr (stringExpr "a")),+ success "expr not" (expr mkExpr) "not(true)" (notExpr (boolExpr True)),+ success "expr eq bool" (expr mkExpr) "eq($bool, true)" (eqExpr varBoolExpr (boolExpr True)),+ success "expr eq int" (expr mkExpr) "eq($int, 1)" (eqExpr varIntExpr (intExpr 1)),+ failure "expr eq type mismatch" (expr mkExpr) "eq($bool, 1)",+ success "expr list" (expr mkExpr) "eq($int, length([]int{1,2}))" (eqExpr varIntExpr (lengthListExpr $ intsExpr [intExpr 1, intExpr 2])), - success "name bool" nameExpr "true" (BoolEqualFunc BoolVariable (Const True)),- success "name id" nameExpr "a" (StringEqualFunc StringVariable (Const "a")),- success "name string" nameExpr "\"a\"" (StringEqualFunc StringVariable (Const "a")),- success "name not" nameExpr "!(a)" (NotFunc (StringEqualFunc StringVariable (Const "a"))),- success "name any" nameExpr "_" (Const True),- success "name or" nameExpr "(a|b)" (OrFunc (StringEqualFunc StringVariable (Const "a")) (StringEqualFunc StringVariable (Const "b"))),+ success "name bool" nameExpr "true" (eqExpr varBoolExpr (boolExpr True)),+ success "name id" nameExpr "a" (eqExpr varStringExpr (stringExpr "a")),+ success "name string" nameExpr "\"a\"" (eqExpr varStringExpr (stringExpr "a")),+ success "name not" nameExpr "!(a)" (notExpr (eqExpr varStringExpr (stringExpr "a"))),+ success "name any" nameExpr "_" (boolExpr True),+ success "name or" nameExpr "(a|b)" (orExpr (eqExpr varStringExpr (stringExpr "a")) (eqExpr varStringExpr (stringExpr "b"))), failure "name grouping" nameExpr "((a))", - success "empty" pattern "<empty>" Empty,- success "zany" pattern "*" ZAny,- success "or" pattern "(*|*)" (Or ZAny ZAny),- success "or list" pattern "(*|*|*)" (Or ZAny (Or ZAny ZAny)),- success "or list longer" pattern "(*|*|*|*|*)" (Or ZAny (Or (Or (Or ZAny ZAny) ZAny) ZAny)),- success "and" pattern "(*&*)" (And ZAny ZAny),- success "and list" pattern "(*&*&*)" (And ZAny (And ZAny ZAny)),- failure "mix and or" pattern "(*|*&*)",- failure "one item in paren" pattern "(*)",- failure "empty paren" pattern "()",- success "zero or more" pattern "(*)*" (ZeroOrMore ZAny),- success "optional" pattern "(*)?" (Optional ZAny),- success "not" pattern "!(*)" (Not ZAny),- success "reference" pattern "@name" (Reference "name"),- success "concat" pattern "[*,*]" (Concat ZAny ZAny),- failure "single concat" pattern "[*]",- failure "empty concat" pattern "[]",- success "concat list" pattern "[*,*,*]" (Concat (Concat ZAny ZAny) ZAny),- success "interleave" pattern "{*;*}" (Interleave ZAny ZAny),- success "interleave list" pattern "{*;*;*}" (Interleave (Interleave ZAny ZAny) ZAny),- failure "empty interleave" pattern "{}",- failure "single interleave" pattern "{*}",- success "contains" pattern ".*" (Contains ZAny),- success "leaf builtin" pattern "== 1" (Node (IntEqualFunc IntVariable (Const 1)) Empty),- success "leaf function" pattern "->eq($int, 1)" (Node (IntEqualFunc IntVariable (Const 1)) Empty),- success "treenode" pattern "a:*" (Node (StringEqualFunc StringVariable (Const "a")) ZAny),- success "any treenode" pattern "_:*" (Node (Const True) ZAny),- success "treenode no colon" pattern "_[*,*]" (Node (Const True) (Concat ZAny ZAny)),+ success "empty" (pattern mkExpr) "<empty>" Empty,+ success "zany" (pattern mkExpr) "*" ZAny,+ success "or" (pattern mkExpr) "(*|*)" (Or ZAny ZAny),+ success "or list" (pattern mkExpr) "(*|*|*)" (Or ZAny (Or ZAny ZAny)),+ success "or list longer" (pattern mkExpr) "(*|*|*|*|*)" (Or ZAny (Or (Or (Or ZAny ZAny) ZAny) ZAny)),+ success "and" (pattern mkExpr) "(*&*)" (And ZAny ZAny),+ success "and list" (pattern mkExpr) "(*&*&*)" (And ZAny (And ZAny ZAny)),+ failure "mix and or" (pattern mkExpr) "(*|*&*)",+ failure "one item in paren" (pattern mkExpr) "(*)",+ failure "empty paren" (pattern mkExpr) "()",+ success "zero or more" (pattern mkExpr) "(*)*" (ZeroOrMore ZAny),+ success "optional" (pattern mkExpr) "(*)?" (Optional ZAny),+ success "not" (pattern mkExpr) "!(*)" (Not ZAny),+ success "reference" (pattern mkExpr) "@name" (Reference "name"),+ success "concat" (pattern mkExpr) "[*,*]" (Concat ZAny ZAny),+ failure "single concat" (pattern mkExpr) "[*]",+ failure "empty concat" (pattern mkExpr) "[]",+ success "concat list" (pattern mkExpr) "[*,*,*]" (Concat (Concat ZAny ZAny) ZAny),+ success "interleave" (pattern mkExpr) "{*;*}" (Interleave ZAny ZAny),+ success "interleave list" (pattern mkExpr) "{*;*;*}" (Interleave (Interleave ZAny ZAny) ZAny),+ failure "empty interleave" (pattern mkExpr) "{}",+ failure "single interleave" (pattern mkExpr) "{*}",+ success "contains" (pattern mkExpr) ".*" (Contains ZAny),+ success "leaf builtin" (pattern mkExpr) "== 1" (Node (eqExpr varIntExpr (intExpr 1)) Empty),+ success "leaf function" (pattern mkExpr) "->eq($int, 1)" (Node (eqExpr varIntExpr (intExpr 1)) Empty),+ success "treenode" (pattern mkExpr) "a:*" (Node (eqExpr varStringExpr (stringExpr "a")) ZAny),+ success "any treenode" (pattern mkExpr) "_:*" (Node (boolExpr True) ZAny),+ success "treenode no colon" (pattern mkExpr) "_[*,*]" (Node (boolExpr True) (Concat ZAny ZAny)), - success "treenode with contains" pattern "a:*=\"b\"" (- Node (StringEqualFunc StringVariable (Const "a"))- $ Node (StringContainsFunc StringVariable (Const "b")) Empty),- success "anynode with contains" pattern "_:*=\"b\"" (- Node (Const True)- $ Node (StringContainsFunc StringVariable (Const "b")) Empty),- success "contains anynode with contains" pattern "._:*=\"b\"" (- Contains $ Node (Const True)- $ Node (StringContainsFunc StringVariable (Const "b")) Empty),- success "contains anynode with contains or" pattern "(._:*=\"b\"|*)" (- Or (Contains $ Node (Const True) $ Node (StringContainsFunc StringVariable (Const "b")) Empty)+ success "treenode with contains" (pattern mkExpr) "a:*=\"b\"" (+ Node (eqExpr varStringExpr (stringExpr "a"))+ $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty),+ success "anynode with contains" (pattern mkExpr) "_:*=\"b\"" (+ Node (boolExpr True)+ $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty),+ success "contains anynode with contains" (pattern mkExpr) "._:*=\"b\"" (+ Contains $ Node (boolExpr True)+ $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty),+ success "contains anynode with contains or" (pattern mkExpr) "(._:*=\"b\"|*)" (+ Or (Contains $ Node (boolExpr True) $ Node (containsStringExpr varStringExpr (stringExpr "b")) Empty) ZAny ), -- (~=\"^([ \t\r\n\v\f])+$\")*- success "Page195E0AddrE0NameE0" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*}" (- Node (StringEqualFunc StringVariable (Const "Person")) (+ success "Page195E0AddrE0NameE0" (pattern mkExpr) "Person:{Name:*;(Addr:*)?;(Email:*)*}" (+ Node (eqExpr varStringExpr (stringExpr "Person")) (Interleave (Interleave- (Node (StringEqualFunc StringVariable (Const "Name")) ZAny)- (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny)+ (Node (eqExpr varStringExpr (stringExpr "Name")) ZAny)+ (Optional $ Node (eqExpr varStringExpr (stringExpr "Addr")) ZAny) )- (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny))+ (ZeroOrMore (Node (eqExpr varStringExpr (stringExpr "Email")) ZAny)) )- ) ),- success "whitespace regex" pattern "(~=\"^([ \t\r\n\v\f])+$\")*" (- ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty+ success "whitespace regex" (pattern mkExpr) "(~=\"^([ \t\r\n\v\f])+$\")*" (+ ZeroOrMore $ Node (regexExpr (stringExpr "^([ \t\r\n\v\f])+$") varStringExpr) Empty ),- success "Page195E0AddrE0NameE0 with whitespace" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*;(~=\"^([ \t\r\n\v\f])+$\")*}" (- Node (StringEqualFunc StringVariable (Const "Person")) (+ success "Page195E0AddrE0NameE0 with whitespace" (pattern mkExpr) "Person:{Name:*;(Addr:*)?;(Email:*)*;(~=\"^([ \t\r\n\v\f])+$\")*}" (+ Node (eqExpr varStringExpr (stringExpr "Person")) (Interleave (Interleave (Interleave- (Node (StringEqualFunc StringVariable (Const "Name")) ZAny)- (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny)+ (Node (eqExpr varStringExpr (stringExpr "Name")) ZAny)+ (Optional $ Node (eqExpr varStringExpr (stringExpr "Addr")) ZAny) )- (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny))+ (ZeroOrMore (Node (eqExpr varStringExpr (stringExpr "Email")) ZAny)) )- (ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty)+ (ZeroOrMore $ Node (regexExpr (stringExpr "^([ \t\r\n\v\f])+$") varStringExpr) Empty) )- ) ), - success "single pattern grammar" grammar "*" $ newRef "main" ZAny,- success "single pattern decl" grammar "#main = *" $ newRef "main" ZAny,- failure "two patterns grammar" grammar "* *",- success "two pattern decls" grammar "#main = * #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,- success "one pattern and one pattern decl" grammar "* #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,- success "one pattern and two pattern decls" grammar "* #a = * #b = *" $ newRef "main" ZAny `union` newRef "a" ZAny `union` newRef "b" ZAny,+ success "single pattern grammar" (grammar mkExpr) "*" $ newRef "main" ZAny,+ success "single pattern decl" (grammar mkExpr) "#main = *" $ newRef "main" ZAny,+ failure "two patterns grammar" (grammar mkExpr) "* *",+ success "two pattern decls" (grammar mkExpr) "#main = * #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,+ success "one pattern and one pattern decl" (grammar mkExpr) "* #a = *" $ newRef "main" ZAny `union` newRef "a" ZAny,+ success "one pattern and two pattern decls" (grammar mkExpr) "* #a = * #b = *" $ newRef "main" ZAny `union` newRef "a" ZAny `union` newRef "b" ZAny, - success "not pattern, not name and != conflicts without not enough lookahead" grammar "!(A):*" (newRef "main" (Node (NotFunc (StringEqualFunc StringVariable (Const "A"))) ZAny)),- success "->type conflicts with ->true and -1 conflicts with ->" grammar "->type($string)" (newRef "main" (Node (StringTypeFunc StringVariable) Empty)),- success "<= conflicts with <empty>" grammar "<= 0" (newRef "main" (Node (IntLessOrEqualFunc IntVariable (Const 0)) Empty)),- success "unexpected space builtin treenode child" grammar "A == \"F\"" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringEqualFunc StringVariable (Const "F")) Empty))),- success "unexpected space after comment" grammar "(* & */*spaces*/ )" (newRef "main" (And ZAny ZAny)),- success "treenode with child builtin type" grammar "A :: $string" (newRef "main" (Node (StringEqualFunc StringVariable (Const "A")) (Node (StringTypeFunc StringVariable) Empty))),- success "extra semicolon" grammar "{*;*;}" (newRef "main" (Interleave ZAny ZAny)),+ success "not pattern, not name and != conflicts without not enough lookahead" (grammar mkExpr) "!(A):*" (newRef "main" (Node (notExpr (eqExpr varStringExpr (stringExpr "A"))) ZAny)),+ success "->type conflicts with ->true and -1 conflicts with ->" (grammar mkExpr) "->type($string)" (newRef "main" (Node (typeExpr varStringExpr) Empty)),+ success "<= conflicts with <empty>" (grammar mkExpr) "<= 0" (newRef "main" (Node (leExpr varIntExpr (intExpr 0)) Empty)),+ success "unexpected space builtin treenode child" (grammar mkExpr) "A == \"F\"" (newRef "main" (Node (eqExpr varStringExpr (stringExpr "A")) (Node (eqExpr varStringExpr (stringExpr "F")) Empty))),+ success "unexpected space after comment" (grammar mkExpr) "(* & */*spaces*/ )" (newRef "main" (And ZAny ZAny)),+ success "treenode with child builtin type" (grammar mkExpr) "A :: $string" (newRef "main" (Node (eqExpr varStringExpr (stringExpr "A")) (Node (typeExpr varStringExpr) Empty))),+ success "extra semicolon" (grammar mkExpr) "{*;*;}" (newRef "main" (Interleave ZAny ZAny)), + success "user defined function" (grammar bothLibs) "->isPrime($int)" (newRef "main" (Node (isPrimeExpr varIntExpr) Empty)),+ failure "user defined function" (grammar mkExpr) "->isPrime($int)",+ HUnit.testCase "" (return ())]++bothLibs :: String -> [AnyExpr] -> Either String AnyExpr+bothLibs name args = case mkExpr name args of+ (Left err) -> userLib name args+ (Right expr) -> return expr
test/RelapseSpec.hs view
@@ -7,34 +7,44 @@ import qualified Test.Tasty as T import qualified Test.Tasty.HUnit as HUnit -import Control.Monad.Except (runExcept)- import Relapse import Json+import UserDefinedFuncs+import Expr (AnyExpr)+import Exprs (mkExpr) tests = T.testGroup "Relapse" [ HUnit.testCase "parseGrammar success" $ either HUnit.assertFailure (\_ -> return ()) $- runExcept $ Relapse.parseGrammar "a == 1"+ Relapse.parse "a == 1" , HUnit.testCase "parseGrammar failure" $ either (\_ -> return ()) (\_ -> HUnit.assertFailure "expected error") $- runExcept $ Relapse.parseGrammar "{ a : 1 }" + Relapse.parse "{ a : 1 }" , HUnit.testCase "validate success" $ either HUnit.assertFailure (HUnit.assertBool "expected success") $ Relapse.validate <$> - runExcept (Relapse.parseGrammar "a == 1") <*> + Relapse.parse "a == 1" <*> Json.decodeJSON "{\"a\":1}" , HUnit.testCase "validate failure" $ either HUnit.assertFailure (HUnit.assertBool "expected failure" . not) $ Relapse.validate <$> - runExcept (Relapse.parseGrammar "a == 1") <*> + Relapse.parse "a == 1" <*> Json.decodeJSON "{\"a\":2}" , HUnit.testCase "filter" $ case do {- refs <- runExcept $ Relapse.parseGrammar "a == 1";+ refs <- Relapse.parse "a == 1"; want <- Json.decodeJSON "{\"a\":1}"; other <- Json.decodeJSON "{\"a\":2}";+ return (Relapse.filter refs [want, other], [want]);+ } of+ (Left err) -> HUnit.assertFailure err+ (Right (got, want)) -> HUnit.assertEqual "expected the same tree" want got++ , HUnit.testCase "user defined function" $ case do {+ refs <- Relapse.parseWithUDFs userLib "a->isPrime($int)";+ want <- Json.decodeJSON "{\"a\":3}";+ other <- Json.decodeJSON "{\"a\":4}"; return (Relapse.filter refs [want, other], [want]); } of (Left err) -> HUnit.assertFailure err
test/Spec.hs view
@@ -10,6 +10,7 @@ import qualified ParserSpec import qualified Suite import qualified RelapseSpec+import qualified DeriveSpec main :: IO () main = do {@@ -18,5 +19,6 @@ ParserSpec.tests , RelapseSpec.tests , Suite.tests testSuiteCases+ , DeriveSpec.tests ] }
test/Suite.hs view
@@ -10,10 +10,10 @@ import System.Directory (getCurrentDirectory, listDirectory, doesDirectoryExist) import System.FilePath (FilePath, (</>), takeExtension, takeBaseName, takeDirectory) import Text.XML.HXT.DOM.TypeDefs (XmlTree)-import Control.Monad.Except (Except(..), runExcept) import Parsers (Tree)-import Patterns (Refs, Pattern, nullable, hasRecursion)+import Smart (Grammar, Pattern, nullable, compile)+import qualified Ast import Json (JsonTree, decodeJSON) import Xml (decodeXML) import Parser (parseGrammar)@@ -24,7 +24,7 @@ tests :: [TestSuiteCase] -> T.TestTree tests testSuiteCases = - let nonRecursiveTestCases = filter (\(TestSuiteCase _ g _ _) -> not (hasRecursion g)) testSuiteCases+ let nonRecursiveTestCases = filter (\(TestSuiteCase _ g _ _) -> not (either error id $ Ast.hasRecursion g)) testSuiteCases derivTests = T.testGroup "derive" $ map (newTestCase AlgoDeriv) nonRecursiveTestCases zipTests = T.testGroup "zip" $ map (newTestCase AlgoZip) nonRecursiveTestCases mapTests = T.testGroup "map" $ map (newTestCase AlgoMap) nonRecursiveTestCases@@ -47,7 +47,7 @@ data TestSuiteCase = TestSuiteCase { name :: String- , grammar :: Refs+ , grammar :: Ast.Grammar , input :: EncodedData , valid :: Bool } deriving Show@@ -72,28 +72,35 @@ testName :: Algo -> TestSuiteCase -> String testName algo (TestSuiteCase name g t want) = name ++ "_" ++ show algo -must :: Except String Pattern -> Pattern-must e = case runExcept e of- (Left l) -> error l- (Right r) -> r--testDeriv :: Tree t => Algo -> String -> Refs -> [t] -> Bool -> IO ()+testDeriv :: Tree t => Algo -> String -> Ast.Grammar -> [t] -> Bool -> IO () testDeriv AlgoDeriv name g ts want = - let p = must $ Derive.derive g ts - got = nullable g p- in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got+ let p = either error id (do {+ compiled <- compile g;+ Derive.derive compiled ts;+ })+ got = nullable p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoZip name g ts want = - let p = must $ Derive.zipderive g ts - got = nullable g p- in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do {+ compiled <- compile g;+ Derive.zipderive compiled ts;+ })+ got = nullable p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoMap name g ts want = - let p = must $ MemDerive.derive g ts - got = nullable g p- in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do {+ compiled <- compile g;+ MemDerive.derive compiled ts;+ })+ got = nullable p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got testDeriv AlgoVpa name g ts want = - let p = must $ VpaDerive.derive g ts - got = nullable g p- in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nresulting derivative = " ++ show p) want got + let p = either error id (do {+ compiled <- compile g;+ VpaDerive.derive compiled ts;+ })+ got = nullable p+ in HUnit.assertEqual ("want " ++ show want ++ " got " ++ show got ++ "\nstarting grammar = " ++ show g ++ "\nresulting derivative = " ++ show p) want got getRelapseJson :: [FilePath] -> FilePath getRelapseJson paths = head $ filter (\fname -> takeExtension fname == ".json" && takeBaseName fname == "relapse") paths@@ -107,10 +114,10 @@ filepathWithExt :: [FilePath] -> String -> FilePath filepathWithExt paths ext = head $ filter (\fname -> takeExtension fname == ext && takeBaseName fname /= "relapse") paths -fromGrammar :: String -> Refs+fromGrammar :: String -> Ast.Grammar fromGrammar s = case parseGrammar s of (Left err) -> error $ "given input: <" ++ s ++ "> got parse error: " ++ show err- (Right r) -> r+ (Right g) -> g readJsonTest :: FilePath -> IO TestSuiteCase readJsonTest path = do {
+ test/UserDefinedFuncs.hs view
@@ -0,0 +1,79 @@+module UserDefinedFuncs (+ userLib+ , incExpr+ , concatExpr+ , isPrimeExpr+) where++import qualified Data.Text++import Data.Numbers.Primes (isPrime)++import Expr++-- |+-- userLib is a library of user defined functions that can be passed to the parser.+userLib :: String -> [AnyExpr] -> Either String AnyExpr+userLib "inc" args = mkIncExpr args+userLib "concat" args = mkConcatExpr args+userLib "isPrime" args = mkIsPrime args+userLib n _ = Left $ "undefined function: " ++ n++-- |+-- mkIncExpr tries to create an incExpr from a variable number and dynamically types arguments.+-- This function is used by the Relapse parser to insert your user defined expression into the expression tree.+mkIncExpr :: [AnyExpr] -> Either String AnyExpr+mkIncExpr args = do {+ arg <- assertArgs1 "inc" args;+ mkIntExpr . incExpr <$> assertInt arg;+}++-- |+-- incExpr creates an expression that increases its input argument by 1.+-- This function is also useful if we want to build up our own well typed expression tree, +-- bypassing the Relapse parser.+incExpr :: Expr Int -> Expr Int+incExpr intArg = trimInt Expr {+ desc = mkDesc "inc" [desc intArg]+ , eval = \fieldValue -> (+1) <$> eval intArg fieldValue+}++-- |+-- mkConcatExpr tries to create an concatExpr from a variable number and dynamically types arguments.+mkConcatExpr :: [AnyExpr] -> Either String AnyExpr+mkConcatExpr args = do {+ (arg1, arg2) <- assertArgs2 "inc" args;+ strArg1 <- assertString arg1;+ strArg2 <- assertString arg2;+ return $ mkStringExpr $ concatExpr strArg1 strArg2;+}++-- |+-- concatExpr creates an expression that concatenates two string together.+concatExpr :: Expr Data.Text.Text -> Expr Data.Text.Text -> Expr Data.Text.Text+concatExpr strExpr1 strExpr2 = trimString Expr {+ desc = mkDesc "concat" [desc strExpr1, desc strExpr2]+ , eval = \fieldValue -> do {+ str1 <- eval strExpr1 fieldValue;+ str2 <- eval strExpr2 fieldValue;+ return $ Data.Text.concat [str1,str2];+ }+}++-- |+-- mkIsPrimeExpr tries to create an isPrimeExpr from a variable number and dynamically types arguments.+mkIsPrime :: [AnyExpr] -> Either String AnyExpr+mkIsPrime args = do {+ arg <- assertArgs1 "isPrime" args;+ case arg of+ (AnyExpr _ (IntFunc _)) -> mkBoolExpr . isPrimeExpr <$> assertInt arg;+ (AnyExpr _ (UintFunc _)) -> mkBoolExpr . isPrimeExpr <$> assertUint arg;+}++-- |+-- isPrime creates an expression checks whether a number is prime.+isPrimeExpr :: Integral a => Expr a -> Expr Bool+isPrimeExpr numExpr = trimBool Expr {+ desc = mkDesc "isPrime" [desc numExpr]+ , eval = \fieldValue -> isPrime <$> eval numExpr fieldValue+}