katydid 0.3.1.0 → 0.4.0.1
raw patch · 61 files changed
+3585/−3337 lines, 61 filesdep ~base
Dependency ranges changed: base
Files
- Changelog.md +27/−0
- Makefile +36/−0
- README.md +0/−104
- Readme.md +104/−0
- app/Main.hs +2/−2
- bench/Suite.hs +5/−5
- changelog.md +0/−15
- katydid.cabal +160/−118
- package.yaml +83/−0
- src/Ast.hs +0/−117
- src/Data/Katydid/Parser/Json.hs +50/−0
- src/Data/Katydid/Parser/Parser.hs +34/−0
- src/Data/Katydid/Parser/Xml.hs +42/−0
- src/Data/Katydid/Relapse/Ast.hs +117/−0
- src/Data/Katydid/Relapse/Derive.hs +165/−0
- src/Data/Katydid/Relapse/Expr.hs +509/−0
- src/Data/Katydid/Relapse/Exprs.hs +86/−0
- src/Data/Katydid/Relapse/Exprs/Compare.hs +191/−0
- src/Data/Katydid/Relapse/Exprs/Contains.hs +48/−0
- src/Data/Katydid/Relapse/Exprs/Elem.hs +35/−0
- src/Data/Katydid/Relapse/Exprs/Length.hs +54/−0
- src/Data/Katydid/Relapse/Exprs/Logic.hs +128/−0
- src/Data/Katydid/Relapse/Exprs/Strings.hs +107/−0
- src/Data/Katydid/Relapse/Exprs/Type.hs +36/−0
- src/Data/Katydid/Relapse/Exprs/Var.hs +127/−0
- src/Data/Katydid/Relapse/IfExprs.hs +86/−0
- src/Data/Katydid/Relapse/MemDerive.hs +91/−0
- src/Data/Katydid/Relapse/Parser.hs +388/−0
- src/Data/Katydid/Relapse/Relapse.hs +67/−0
- src/Data/Katydid/Relapse/Simplify.hs +136/−0
- src/Data/Katydid/Relapse/Smart.hs +417/−0
- src/Data/Katydid/Relapse/VpaDerive.hs +101/−0
- src/Data/Katydid/Relapse/Zip.hs +47/−0
- src/Derive.hs +0/−164
- src/Expr.hs +0/−509
- src/Exprs.hs +0/−86
- src/Exprs/Compare.hs +0/−191
- src/Exprs/Contains.hs +0/−48
- src/Exprs/Elem.hs +0/−35
- src/Exprs/Length.hs +0/−54
- src/Exprs/Logic.hs +0/−128
- src/Exprs/Strings.hs +0/−107
- src/Exprs/Type.hs +0/−36
- src/Exprs/Var.hs +0/−126
- src/IfExprs.hs +0/−85
- src/Json.hs +0/−50
- src/MemDerive.hs +0/−90
- src/Parser.hs +0/−388
- src/Parsers.hs +0/−34
- src/Relapse.hs +0/−66
- src/Simplify.hs +0/−136
- src/Smart.hs +0/−417
- src/VpaDerive.hs +0/−100
- src/Xml.hs +0/−42
- src/Zip.hs +0/−47
- stack.yaml +65/−0
- test/DeriveSpec.hs +13/−11
- test/ParserSpec.hs +12/−12
- test/RelapseSpec.hs +6/−4
- test/Suite.hs +9/−9
- test/UserDefinedFuncs.hs +1/−1
+ Changelog.md view
@@ -0,0 +1,27 @@+# 0.4.0.1++Moved all files into move idiomatic folders.++# 0.3.1.0++Fixed build, by removing internal uses of outdated EitherT.++# 0.3.0.1++New Smart constructors and user defined functions++# 0.2.0.1++Fixed parsing of builtin regex and contains functions.++# 0.2.0.0++New benchmarks++# 0.1.1.0++Cleanup++# 0.1.0.0++First version
+ Makefile view
@@ -0,0 +1,36 @@+.PHONY: run test setup bench doc pkg++build:+ stack build --bench --no-run-benchmarks++test: build+ stack test++singletest: build+ stack test --ta '-p "Derive"'++test-trace: build+ stack test --trace++bench:+ stack bench++run: build+ stack exec katydid-exe++setup:+ stack setup++ide-setup:+ stack build intero++doc:+ stack haddock --haddock-arguments "--odir=./docs"++lint:+ # -XNoPatternSynonyms is a temporary workaround for https://github.com/ndmitchell/hlint/issues/216+ hlint -XNoPatternSynonyms .++pkg: doc+ stack sdist+ echo "Now upload the created file to: https://hackage.haskell.org/upload"
− README.md
@@ -1,104 +0,0 @@-# Katydid--[](https://travis-ci.org/katydid/katydid-haskell)--A Haskell implementation of Katydid.----This includes:-- - [Relapse](https://katydid.github.io/katydid-haskell/Relapse.html): Validation Language - - Parsers: [JSON](https://katydid.github.io/katydid-haskell/Json.html) and [XML](https://katydid.github.io/katydid-haskell/Xml.html)--[Documentation for katydid](http://katydid.github.io/)--[Documentation for katydid-haskell](https://katydid.github.io/katydid-haskell/)--[Documentation for katydid-haskell/Relapse](https://katydid.github.io/katydid-haskell/Relapse.html)--All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes].--[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 => Grammar -> [t] -> Bool-```--, where a tree is a class in the [Parsers](https://katydid.github.io/katydid-haskell/Parsers.html) module:-```haskell-class Tree a where- getLabel :: a -> Label- getChildren :: a -> [a]-```--Here is an example that validates a single JSON tree:-```haskell-main = either - (\err -> putStrLn $ "error:" ++ err) - (\valid -> if valid - then putStrLn "dragons exist" - else putStrLn "dragons are fictional"- ) $- Relapse.validate <$> - Relapse.parse ".DragonsExist == true" <*> - Json.decodeJSON "{\"DragonsExist\": false}"-```--## Efficiency--If you want to validate multiple trees using the same grammar then the filter function does some internal memoization, which makes a huge difference.--```haskell-filter :: Tree t => 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)
+ Readme.md view
@@ -0,0 +1,104 @@+# Katydid++[](https://travis-ci.org/katydid/katydid-haskell)++A Haskell implementation of Katydid.++++This includes:++ - [Relapse](https://katydid.github.io/katydid-haskell/Relapse.html): Validation Language + - Parsers: [JSON](https://katydid.github.io/katydid-haskell/Json.html) and [XML](https://katydid.github.io/katydid-haskell/Xml.html)++[Documentation for katydid](http://katydid.github.io/)++[Documentation for katydid-haskell](https://katydid.github.io/katydid-haskell/)++[Documentation for katydid-haskell/Relapse](https://katydid.github.io/katydid-haskell/Relapse.html)++All JSON and XML tests from [the language agnostic test suite](https://github.com/katydid/testsuite) [passes].++[Hackage](https://hackage.haskell.org/package/katydid)++## Example++Validating a single structure can be done using the validate function:+```haskell+validate :: Tree t => Grammar -> [t] -> Bool+```++, where a tree is a class in the [Parsers](https://katydid.github.io/katydid-haskell/Parsers.html) module:+```haskell+class Tree a where+ getLabel :: a -> Label+ getChildren :: a -> [a]+```++Here is an example that validates a single JSON tree:+```haskell+main = either + (\err -> putStrLn $ "error:" ++ err) + (\valid -> if valid + then putStrLn "dragons exist" + else putStrLn "dragons are fictional"+ ) $+ Relapse.validate <$> + Relapse.parse ".DragonsExist == true" <*> + Json.decodeJSON "{\"DragonsExist\": false}"+```++## Efficiency++If you want to validate multiple trees using the same grammar then the filter function does some internal memoization, which makes a huge difference.++```haskell+filter :: Tree t => 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 Data.Katydid.Relapse.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
@@ -1,7 +1,7 @@ module Main where -import qualified Relapse-import qualified Json+import qualified Data.Katydid.Relapse.Relapse as Relapse+import qualified Data.Katydid.Parser.Json as Json main :: IO () main = either
bench/Suite.hs view
@@ -15,12 +15,12 @@ import GHC.Generics (Generic) import Data.Int (Int64) -import qualified Ast-import Json (JsonTree, decodeJSON)-import Xml (decodeXML)-import qualified Parser+import Data.Katydid.Parser.Json (JsonTree, decodeJSON)+import Data.Katydid.Parser.Xml (decodeXML) -import qualified Relapse+import qualified Data.Katydid.Relapse.Ast as Ast+import qualified Data.Katydid.Relapse.Parser as Parser+import qualified Data.Katydid.Relapse.Relapse as Relapse runBench :: BenchSuiteCase -> IO Int runBench (BenchSuiteCase _ g (XMLDatas inputs)) =
− changelog.md
@@ -1,15 +0,0 @@-# 2.0.1--Fixes parsing of builtin regex and contains functions.--# 2.0.0--Adds benchmarks--# 1.1.0--Cleanup--# 1.0.0--First version
katydid.cabal view
@@ -1,127 +1,169 @@-name: katydid-version: 0.3.1.0-synopsis: A haskell implementation of Katydid-description: - A haskell implementation of Katydid- .- This includes:- .- - Relapse, a validation Language- - Parsers for JSON, XML and an abstraction for trees- .- You should only need the following modules:- .- - The Relapse module is used for validation.- - The Json and XML modules are used to create Json and XML trees that can be validated.- .- If you want to implement your own parser then you can look at the Parsers module- .+-- This file has been generated from package.yaml by hpack version 0.28.2.+--+-- see: https://github.com/sol/hpack+--+-- hash: 5afbe6708301b18023de469fa4847a36e4c9612c2c60efdbf4e30ad3145b4636 -homepage: https://github.com/katydid/katydid-haskell-license: BSD3-license-file: LICENSE-author: Walter Schulze-maintainer: awalterschulze@gmail.com-copyright: Walter Schulze-category: Data-build-type: Simple-extra-source-files: README.md, changelog.md-cabal-version: >=1.10+name: katydid+version: 0.4.0.1+synopsis: A haskell implementation of Katydid+description: Please see the README on GitHub at <https://github.com/katydid/katydid-haskell#readme>+category: Data+homepage: https://github.com/katydid/katydid-haskell#readme+bug-reports: https://github.com/katydid/katydid-haskell/issues+author: Walter Schulze+maintainer: awalterschulze@gmail.com+copyright: Walter Schulze+license: BSD3+license-file: LICENSE+build-type: Simple+cabal-version: >= 1.10+extra-source-files:+ Changelog.md+ LICENSE+ Makefile+ package.yaml+ Readme.md+ stack.yaml +source-repository head+ type: git+ location: https://github.com/katydid/katydid-haskell+ library- hs-source-dirs: src- 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- , VpaDerive- , Parser- , Relapse- , Smart- build-depends: base >= 4.7 && < 5- , containers- , json- , hxt- , regex-tdfa- , mtl- , parsec- , deepseq- , text- , bytestring- , either- , extra- , ilist- , transformers- default-language: Haskell2010+ exposed-modules:+ Data.Katydid.Parser.Json+ Data.Katydid.Parser.Parser+ Data.Katydid.Parser.Xml+ Data.Katydid.Relapse.Ast+ Data.Katydid.Relapse.Derive+ Data.Katydid.Relapse.Expr+ Data.Katydid.Relapse.Exprs+ Data.Katydid.Relapse.Exprs.Compare+ Data.Katydid.Relapse.Exprs.Contains+ Data.Katydid.Relapse.Exprs.Elem+ Data.Katydid.Relapse.Exprs.Length+ Data.Katydid.Relapse.Exprs.Logic+ Data.Katydid.Relapse.Exprs.Strings+ Data.Katydid.Relapse.Exprs.Type+ Data.Katydid.Relapse.Exprs.Var+ Data.Katydid.Relapse.IfExprs+ Data.Katydid.Relapse.MemDerive+ Data.Katydid.Relapse.Parser+ Data.Katydid.Relapse.Relapse+ Data.Katydid.Relapse.Simplify+ Data.Katydid.Relapse.Smart+ Data.Katydid.Relapse.VpaDerive+ Data.Katydid.Relapse.Zip+ other-modules:+ Paths_katydid+ hs-source-dirs:+ src+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , deepseq+ , either+ , extra+ , hxt+ , ilist+ , json+ , mtl+ , parsec+ , regex-tdfa+ , text+ , transformers+ default-language: Haskell2010 executable katydid-exe- hs-source-dirs: app- main-is: Main.hs- ghc-options: -threaded -rtsopts -with-rtsopts=-N- build-depends: base- , katydid- , mtl- default-language: Haskell2010+ main-is: Main.hs+ other-modules:+ Paths_katydid+ hs-source-dirs:+ app+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , deepseq+ , either+ , extra+ , hxt+ , ilist+ , json+ , katydid+ , mtl+ , parsec+ , regex-tdfa+ , text+ , transformers+ default-language: Haskell2010 test-suite katydid-test- type: exitcode-stdio-1.0- hs-source-dirs: test- main-is: Spec.hs- build-depends: base- , katydid- , directory- , filepath- , containers- , json- , hxt- , HUnit- , parsec- , mtl- , tasty-hunit- , tasty- , text- , primes- , ilist- other-modules: UserDefinedFuncs- , ParserSpec- , RelapseSpec- , Suite- , DeriveSpec- ghc-options: -threaded -rtsopts -with-rtsopts=-N- default-language: Haskell2010+ type: exitcode-stdio-1.0+ main-is: Spec.hs+ other-modules:+ DeriveSpec+ ParserSpec+ RelapseSpec+ Suite+ UserDefinedFuncs+ Paths_katydid+ hs-source-dirs:+ test+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ build-depends:+ HUnit+ , base >=4.7 && <5+ , bytestring+ , containers+ , deepseq+ , directory+ , either+ , extra+ , filepath+ , hxt+ , ilist+ , json+ , katydid+ , mtl+ , parsec+ , primes+ , regex-tdfa+ , tasty+ , tasty-hunit+ , text+ , transformers+ default-language: Haskell2010 -benchmark criterion-benchmarks- type: exitcode-stdio-1.0- hs-source-dirs: bench- main-is: Benchmarks.hs- build-depends: base- , katydid- , criterion >= 1.2.2- , directory- , filepath- , mtl- , hxt- , deepseq- , text- other-modules: Suite- ghc-options: -Wall+benchmark katydid-benchmark+ type: exitcode-stdio-1.0+ main-is: Benchmarks.hs+ other-modules:+ Suite+ Paths_katydid+ hs-source-dirs:+ bench+ ghc-options: -Wall+ build-depends:+ base >=4.7 && <5+ , bytestring+ , containers+ , criterion >=1.2.2+ , deepseq+ , directory+ , either+ , extra+ , filepath+ , hxt+ , ilist+ , json+ , katydid+ , mtl+ , parsec+ , regex-tdfa+ , text+ , transformers default-language: Haskell2010- -source-repository head- type: git- location: https://github.com/katydid/katydid-haskell
+ package.yaml view
@@ -0,0 +1,83 @@+name: katydid+version: 0.4.0.1+github: "katydid/katydid-haskell"+license: BSD3+author: "Walter Schulze"+maintainer: "awalterschulze@gmail.com"+copyright: "Walter Schulze"++extra-source-files:+- Readme.md+- LICENSE+- Makefile+- Changelog.md+- package.yaml+- stack.yaml++# Metadata used when publishing your package+synopsis: A haskell implementation of Katydid+category: Data++# To avoid duplicated efforts in documentation and dealing with the+# complications of embedding Haddock markup inside cabal files, it is+# common to point users to the README.md file.+description: Please see the README on GitHub at <https://github.com/katydid/katydid-haskell#readme>++dependencies:+- base >= 4.7 && < 5+- containers+- json+- hxt+- regex-tdfa+- mtl+- parsec+- deepseq+- text+- bytestring+- either+- extra+- ilist+- transformers++library:+ source-dirs: src++executables:+ katydid-exe:+ main: Main.hs+ source-dirs: app+ ghc-options:+ - -threaded+ - -rtsopts+ - -with-rtsopts=-N+ dependencies:+ - katydid++tests:+ katydid-test:+ main: Spec.hs+ source-dirs: test+ ghc-options:+ - -threaded+ - -rtsopts+ - -with-rtsopts=-N+ dependencies:+ - katydid+ - directory+ - filepath+ - HUnit+ - tasty-hunit+ - tasty+ - primes++benchmarks:+ katydid-benchmark:+ main: Benchmarks.hs+ source-dirs: bench+ ghc-options:+ - -Wall+ dependencies:+ - katydid+ - criterion >= 1.2.2+ - directory+ - filepath
− src/Ast.hs
@@ -1,117 +0,0 @@--- |--- 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/Data/Katydid/Parser/Json.hs view
@@ -0,0 +1,50 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- This module contains the Json Parser.++module Data.Katydid.Parser.Json (+ decodeJSON, JsonTree+) where++import Text.JSON (decode, Result(..), JSValue(..), fromJSString, fromJSObject)+import Data.Ratio (denominator)+import Data.Text (pack)++import qualified Data.Tree as DataTree+import Data.Katydid.Parser.Parser++instance Tree JsonTree where+ getLabel (DataTree.Node l _) = l+ getChildren (DataTree.Node _ cs) = cs++-- |+-- JsonTree is a tree that can be validated by Relapse.+type JsonTree = DataTree.Tree Label++-- |+-- decodeJSON returns a JsonTree, given an input string.+decodeJSON :: String -> Either String [JsonTree]+decodeJSON s = case decode s of+ (Error e) -> Left e+ (Ok v) -> Right (uValue v)++uValue :: JSValue -> [JsonTree]+uValue JSNull = []+uValue (JSBool b) = [DataTree.Node (Bool b) []]+uValue (JSRational _ r) = 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 (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 $ pack name) (uValue value)
+ src/Data/Katydid/Parser/Parser.hs view
@@ -0,0 +1,34 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}++-- |+-- This module describes the abstract tree that can be validated by Relapse.+--+-- The JSON and XML parsers both are both versions of this type class.++module Data.Katydid.Parser.Parser (+ Tree(..), Label(..)+) where++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 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/Data/Katydid/Parser/Xml.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE FlexibleInstances #-}++-- |+-- This module contains the XML Parser.++module Data.Katydid.Parser.Xml (+ decodeXML+) where++import Text.Read (readMaybe)+import Text.XML.HXT.DOM.TypeDefs (XmlTree, XNode(..), blobToString, localPart)+import Text.XML.HXT.Parser.XmlParsec (xread)+import Data.Tree.NTree.TypeDefs (NTree(..))+import qualified Data.Text as Text++import Data.Katydid.Parser.Parser++instance Tree XmlTree where+ getLabel (NTree n _ ) = either (String . Text.pack . ("XML Parse Error:" ++)) id (xmlLabel n)+ getChildren (NTree _ cs) = cs++-- |+-- decodeXML returns a XmlTree, given an input string.+decodeXML :: String -> [XmlTree]+decodeXML = xread++xmlLabel :: XNode -> Either String Label+xmlLabel (XText s) = return $ parseLabel s+xmlLabel (XBlob b) = return $ parseLabel $ blobToString b+xmlLabel x@(XCharRef _) = fail $ "XCharRef not supported" ++ show x+xmlLabel x@(XEntityRef _) = fail $ "XEntityRef not supported" ++ show x+xmlLabel x@(XCmt _) = fail $ "XCmt not supported" ++ show x+xmlLabel (XCdata s) = return $ parseLabel s+xmlLabel x@XPi{} = fail $ "XPi not supported" ++ show x+xmlLabel (XTag qname attrs) = return $ parseLabel (localPart qname) -- TODO attrs should be part of the children returned by getChildren+xmlLabel x@XDTD{} = fail $ "XDTD not supported" ++ show x+xmlLabel (XAttr qname) = return $ parseLabel (localPart qname)+xmlLabel x@XError{} = fail $ "XError not supported" ++ show x++-- TODO what about other leaf types+parseLabel :: String -> Label+parseLabel s = maybe (String (Text.pack s)) Int (readMaybe s :: Maybe Int)
+ src/Data/Katydid/Relapse/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 Data.Katydid.Relapse.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 Data.Katydid.Relapse.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/Data/Katydid/Relapse/Derive.hs view
@@ -0,0 +1,165 @@+-- |+-- This module is a simple implementation of the internal derivative algorithm.+--+-- It is intended to be used for explanation purposes.+--+-- This means that it gives up speed for readability.+--+-- Thus it has no type of memoization.++module Data.Katydid.Relapse.Derive (+ derive, calls, returns, zipderive+ -- * Internal functions+ -- | These functions are exposed for testing purposes.+ , removeOneForEach+) where++import Data.Foldable (foldlM)+import Data.List.Index (imap)++import Data.Katydid.Parser.Parser++import Data.Katydid.Relapse.Smart+import Data.Katydid.Relapse.Simplify+import Data.Katydid.Relapse.Zip+import Data.Katydid.Relapse.IfExprs++-- | +-- calls returns a compiled if expression tree.+-- Each if expression returns a child pattern, given the input value.+-- In other words calls signature is actually:+--+-- @+-- Refs -> [Pattern] -> Value -> [Pattern]+-- @+--+-- , where the resulting list of patterns are the child patterns,+-- that need to be derived given the trees child values.+calls :: Grammar -> [Pattern] -> IfExprs+calls g ps = compileIfExprs $ concatMap (\p -> deriveCall g p []) ps++deriveCall :: Grammar -> Pattern -> [IfExpr] -> [IfExpr]+deriveCall _ Empty res = res+deriveCall _ ZAny res = 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 :: Grammar -> ([Pattern], [Bool]) -> [Pattern]+returns _ ([], []) = []+returns g (p:tailps, ns) =+ let (dp, tailns) = deriveReturn g p ns+ in dp:returns g (tailps, tailns)++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++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 => 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 => Grammar -> [Pattern] -> t -> Either String [Pattern]+deriv g ps tree =+ if all unescapable ps then return ps else+ 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 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 => 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 => Grammar -> [Pattern] -> t -> Either String [Pattern]+zipderiv g ps tree =+ if all unescapable ps then return ps else+ 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 g (ps, unzipns)+ }
+ src/Data/Katydid/Relapse/Expr.hs view
@@ -0,0 +1,509 @@+-- |+-- This module contains all the functions you need to implement a Relapse expression.++module Data.Katydid.Relapse.Expr (+ 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.Char (ord)+import Data.List (intercalate)+import Data.Text (Text, unpack, pack)+import Data.ByteString (ByteString)++import qualified Data.Katydid.Parser.Parser as Parser++-- |+-- 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++-- |+-- 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++-- |+-- 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+}++-- |+-- 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+}++instance Show Desc where+ show = _toStr++instance Ord Desc where+ compare = cmp++instance Eq Desc where+ (==) a b = cmp a b == EQ++-- |+-- 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+}++-- |+-- 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 = (Parser.Label -> Either String a)++instance Show AnyExpr where+ show a = show (_desc a)++instance Eq AnyExpr where+ (==) a b = _desc a == _desc b++instance Ord AnyExpr where+ compare a b = cmp (_desc a) (_desc b)++-- |+-- 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])++-- |+-- 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+}++instance Show (Expr a) where+ show e = show (desc e)++instance Eq (Expr a) where+ (==) x y = desc x == desc y++instance Ord (Expr a) where+ compare x y = cmp (desc x) (desc y)++-- |+-- params returns the descriptions of the parameters of the user defined expression.+params :: Expr a -> [Desc]+params = _params . desc++-- |+-- name returns the name of the user defined expression.+name :: Expr a -> String+name = _name . desc++-- |+-- hasVar returns whether the expression or any of its children contains a variable expression.+hasVar :: Expr a -> Bool+hasVar = _hasVar . desc++-- |+-- mkBoolExpr generalises a bool expression to any expression.+mkBoolExpr :: Expr Bool -> AnyExpr+mkBoolExpr (Expr desc eval) = AnyExpr desc (BoolFunc eval)++-- |+-- 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"++-- |+-- mkIntExpr generalises an int expression to any expression.+mkIntExpr :: Expr Int -> AnyExpr+mkIntExpr (Expr desc eval) = AnyExpr desc (IntFunc eval)++-- |+-- 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"++-- |+-- mkDoubleExpr generalises a double expression to any expression.+mkDoubleExpr :: Expr Double -> AnyExpr+mkDoubleExpr (Expr desc eval) = AnyExpr desc (DoubleFunc eval)++-- |+-- 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"++-- |+-- mkStringExpr generalises a string expression to any expression.+mkStringExpr :: Expr Text -> AnyExpr+mkStringExpr (Expr desc eval) = AnyExpr desc (StringFunc eval)++-- |+-- 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"++-- |+-- mkUintExpr generalises a uint expression to any expression.+mkUintExpr :: Expr Word -> AnyExpr+mkUintExpr (Expr desc eval) = AnyExpr desc (UintFunc eval)++-- |+-- 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"++-- |+-- mkBytesExpr generalises a bytes expression to any expression.+mkBytesExpr :: Expr ByteString -> AnyExpr+mkBytesExpr (Expr desc eval) = AnyExpr desc (BytesFunc eval)++-- |+-- 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"++-- |+-- mkBoolsExpr generalises a list of bools expression to any expression.+mkBoolsExpr :: Expr [Bool] -> AnyExpr+mkBoolsExpr (Expr desc eval) = AnyExpr desc (BoolsFunc eval)++-- |+-- 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"++-- |+-- mkIntsExpr generalises a list of ints expression to any expression.+mkIntsExpr :: Expr [Int] -> AnyExpr+mkIntsExpr (Expr desc eval) = AnyExpr desc (IntsFunc eval)++-- |+-- 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"++-- |+-- mkUintsExpr generalises a list of uints expression to any expression.+mkUintsExpr :: Expr [Word] -> AnyExpr+mkUintsExpr (Expr desc eval) = AnyExpr desc (UintsFunc eval)++-- |+-- 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"++-- |+-- mkDoublesExpr generalises a list of doubles expression to any expression.+mkDoublesExpr :: Expr [Double] -> AnyExpr+mkDoublesExpr (Expr desc eval) = AnyExpr desc (DoublesFunc eval)++-- |+-- 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"++-- |+-- mkStringsExpr generalises a list of strings expression to any expression.+mkStringsExpr :: Expr [Text] -> AnyExpr+mkStringsExpr (Expr desc eval) = AnyExpr desc (StringsFunc eval)++-- |+-- 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"++-- |+-- mkListOfBytesExpr generalises a list of bytes expression to any expression.+mkListOfBytesExpr :: Expr [ByteString] -> AnyExpr+mkListOfBytesExpr (Expr desc eval) = AnyExpr desc (ListOfBytesFunc eval)++-- |+-- 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"++-- 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)++-- |+-- 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)++-- |+-- hashString calcuates a hash of a string.+hashString :: String -> Int+hashString s = hashList 0 (map ord s)++-- |+-- 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)++noLabel :: Parser.Label+noLabel = Parser.String (pack "not a label, trying constant evaluation")++-- |+-- 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++-- |+-- 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++-- |+-- 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+}++-- |+-- 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+}++-- |+-- 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+}++-- |+-- 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+}++-- |+-- 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+}++-- |+-- 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+}++-- |+-- 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++-- |+-- 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++-- |+-- 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++-- |+-- 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++-- |+-- 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++-- |+-- 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++-- |+-- 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" ++-- |+-- 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"++-- |+-- 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"++-- |+-- 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"++-- |+-- 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"++-- |+-- 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"++seqExprs :: String -> [Expr a] -> Expr [a]+seqExprs n es = Expr {+ desc = mkDesc n (map desc es)+ , eval = \v -> mapM (`eval` v) es+}
+ src/Data/Katydid/Relapse/Exprs.hs view
@@ -0,0 +1,86 @@+-- |+-- This module contains the standard library of expressions, used by the Relapse parser.++module Data.Katydid.Relapse.Exprs (+ mkBuiltIn+ , mkExpr+ , MkFunc+ , stdOnly+) where++import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Exprs.Compare+import Data.Katydid.Relapse.Exprs.Contains+import Data.Katydid.Relapse.Exprs.Elem+import Data.Katydid.Relapse.Exprs.Length+import Data.Katydid.Relapse.Exprs.Logic+import Data.Katydid.Relapse.Exprs.Strings+import Data.Katydid.Relapse.Exprs.Type+import Data.Katydid.Relapse.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/Data/Katydid/Relapse/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 Data.Katydid.Relapse.Exprs.Compare (+ mkEqExpr, eqExpr+ , mkNeExpr, neExpr+ , mkGeExpr, geExpr+ , mkLeExpr, leExpr+ , mkGtExpr, gtExpr+ , mkLtExpr, ltExpr+) where++import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Contains.hs view
@@ -0,0 +1,48 @@+-- |+-- This module contains the Relapse contains expressions.+module Data.Katydid.Relapse.Exprs.Contains (+ mkContainsExpr+ , containsStringExpr+ , containsExpr+) where++import qualified Data.Text as Text++import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Elem.hs view
@@ -0,0 +1,35 @@+-- |+-- This module contains the Relapse elem expression.+module Data.Katydid.Relapse.Exprs.Elem (+ mkElemExpr+ , elemExpr+) where++import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Length.hs view
@@ -0,0 +1,54 @@+-- |+-- This module contains the Relapse length expressions.+module Data.Katydid.Relapse.Exprs.Length (+ mkLengthExpr+ , lengthListExpr+ , lengthStringExpr+ , lengthBytesExpr+) where++import qualified Data.Text as Text+import qualified Data.ByteString as ByteString++import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Logic.hs view
@@ -0,0 +1,128 @@+-- |+-- This module contains the Relapse logic expressions: not, and, or. +module Data.Katydid.Relapse.Exprs.Logic (+ mkNotExpr, notExpr+ , mkAndExpr, andExpr+ , mkOrExpr, orExpr+) where++import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Strings.hs view
@@ -0,0 +1,107 @@+-- |+-- This module contains the Relapse string expressions.++module Data.Katydid.Relapse.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 Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Type.hs view
@@ -0,0 +1,36 @@+-- |+-- This module contains the Relapse type expression.++module Data.Katydid.Relapse.Exprs.Type (+ mkTypeExpr+ , typeExpr+) where++import Data.Katydid.Relapse.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/Data/Katydid/Relapse/Exprs/Var.hs view
@@ -0,0 +1,127 @@+-- |+-- This module contains all expressions for Relapse variables.++module Data.Katydid.Relapse.Exprs.Var (+ varBoolExpr+ , varIntExpr+ , varUintExpr+ , varDoubleExpr+ , varStringExpr+ , varBytesExpr+ , isVar+) where++import Data.Text (Text)+import Data.ByteString (ByteString)++import qualified Data.Katydid.Parser.Parser as Parser++import Data.Katydid.Relapse.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+ (Parser.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+ (Parser.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+ (Parser.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+ (Parser.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+ (Parser.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+ (Parser.Bytes b) -> Right b+ _ -> Left "not bytes"+}
+ src/Data/Katydid/Relapse/IfExprs.hs view
@@ -0,0 +1,86 @@+-- |+-- This is an internal relapse module.+--+-- It contains multiple implementations of if expressions.++module Data.Katydid.Relapse.IfExprs (+ IfExprs, IfExpr, newIfExpr,+ evalIfExprs, compileIfExprs,+ ZippedIfExprs, zipIfExprs, evalZippedIfExprs+) where++import Data.Katydid.Parser.Parser++import Data.Katydid.Relapse.Smart+import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Exprs.Logic+import Data.Katydid.Relapse.Simplify+import Data.Katydid.Relapse.Zip++-- |+-- 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+ , thn :: IfExprs+ , els :: IfExprs+ }+ | Ret [Pattern]++-- | 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)++-- | 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+}++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)+ | 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+ , zthn :: ZippedIfExprs+ , zels :: ZippedIfExprs+ }+ | 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 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;+ if b then evalZippedIfExprs t v else evalZippedIfExprs e v+}+
+ src/Data/Katydid/Relapse/MemDerive.hs view
@@ -0,0 +1,91 @@+-- |+-- This module is an efficient implementation of the derivative algorithm for trees.+--+-- It is intended to be used for production purposes.+--+-- This means that it gives up some readability for speed.+--+-- This module provides memoization of the nullable, calls and returns functions.++module Data.Katydid.Relapse.MemDerive (+ derive, Mem, newMem, validate+) where++import qualified Data.Map.Strict as M+import Control.Monad.State (State, runState, lift, state)+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)++import Data.Katydid.Parser.Parser++import qualified Data.Katydid.Relapse.Derive as Derive+import Data.Katydid.Relapse.Smart (Grammar, Pattern, lookupRef, nullable, lookupMain)+import Data.Katydid.Relapse.IfExprs+import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Zip++mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)+mem f k m+ | M.member k m = (m M.! k, m)+ | otherwise = let res = f k+ in (res, M.insert k res m)++type 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 (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)++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 :: 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 => Grammar -> [Pattern] -> [t] -> ExceptT String (State Mem) [Pattern]+mderive _ ps [] = return ps+mderive g ps (tree:ts) = do {+ ifs <- lift $ calls g ps;+ childps <- hoistExcept $ evalIfExprs ifs (getLabel tree);+ (zchildps, zipper) <- return $ zippy childps;+ childres <- mderive g zchildps (getChildren tree);+ let + nulls = map nullable childres+ unzipns = unzipby zipper nulls+ ;+ rs <- lift $ returns g (ps, unzipns);+ mderive g rs ts+}++hoistExcept :: (Monad m) => Either e a -> ExceptT e m a+hoistExcept = ExceptT . return++-- |+-- derive is the classic derivative implementation for trees.+derive :: Tree t => Grammar -> [t] -> Either String Pattern+derive g ts =+ let start = [lookupMain g]+ (res, _) = runState (runExceptT $ mderive g start ts) newMem+ in case res of+ (Left l) -> Left l+ (Right [r]) -> return r+ (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 => Grammar -> Pattern -> [t] -> (State Mem) Bool+validate g start tree = do {+ rs <- runExceptT (mderive g [start] tree);+ return $ case rs of+ (Right [r]) -> nullable r+ _ -> False+}
+ src/Data/Katydid/Relapse/Parser.hs view
@@ -0,0 +1,388 @@+-- |+-- This module parses the Relapse Grammar using the Parsec Library.++module Data.Katydid.Relapse.Parser (+ -- * Parse Grammar+ parseGrammar, parseGrammarWithUDFs+ -- * Internal functions+ -- | These functions are exposed for testing purposes.+ , grammar, pattern, nameExpr, expr, + idLit, bytesCastLit, stringLit, doubleCastLit, uintCastLit, intLit, ws+) where++import Text.ParserCombinators.Parsec+import Numeric (readDec, readOct, readHex, readFloat)+import Data.Char (chr)+import qualified Data.Text as Text+import qualified Data.ByteString.Char8 as ByteString+import Control.Arrow (left)++import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Exprs+import Data.Katydid.Relapse.Exprs.Logic+import Data.Katydid.Relapse.Exprs.Var+import Data.Katydid.Relapse.Ast++-- | parseGrammar parses the Relapse Grammar.+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++infixr 5 <::>+(<::>) :: 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 ""++opt :: CharParser () Char -> CharParser () String+opt p = (:"") <$> p <|> empty++_lineComment :: CharParser () ()+_lineComment = char '/' *> many (noneOf "\n") <* char '\n' *> return ()++_blockComment :: CharParser () ()+_blockComment = char '*' *> many (noneOf "*") <* char '*' <* char '/' *> return ()++_comment :: CharParser () ()+_comment = char '/' *> (_lineComment <|> _blockComment)++_ws :: CharParser () ()+_ws = _comment <|> () <$ space++-- | For internal testing+ws :: CharParser () ()+ws = () <$ many _ws++bool :: CharParser () Bool+bool = True <$ string "true"+ <|> False <$ string "false"++_decimalLit :: CharParser () Int+_decimalLit = oneOf "123456789" <::> many digit >>= _read readDec++_octalLit :: CharParser () Int+_octalLit = many1 octDigit >>= _read readOct++_hexLit :: CharParser () Int+_hexLit = many1 hexDigit >>= _read readHex++_read :: ReadS a -> String -> CharParser () a+_read read s = case read s of+ [(n, "")] -> return n+ ((n, ""):_) -> return n+ _ -> fail "digit"++_optionalSign :: (Num a) => CharParser () a+_optionalSign = -1 <$ char '-' <|> return 1++_signedIntLit :: CharParser () Int+_signedIntLit = (*) <$> _optionalSign <*> _intLit++_intLit :: CharParser () Int+_intLit = _decimalLit + <|> char '0' *> (_octalLit + <|> (oneOf "xX" *> _hexLit)+ <|> return 0+ )++-- | For internal testing+intLit :: CharParser () Int+intLit = string "int(" *> _signedIntLit <* char ')'+ <|> _signedIntLit+ <?> "int_lit"++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 + <|> many1 digit)++_floatLit :: CharParser () Double+_floatLit = do+ i <- many1 digit+ e <- _exponent + <|> ((string "." <|> empty) <++> + (_exponent + <|> many1 digit <++>+ (_exponent+ <|> empty)+ )+ ) + <|> 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 '_')++_qualid :: CharParser () String+_qualid = idLit <++> (concat <$> many (char '.' <::> idLit))++_bigUValue :: CharParser () Char+_bigUValue = char 'U' *> do {+ hs <- count 8 hexDigit;+ n <- _read readHex hs;+ return $ toEnum n+}++_littleUValue :: CharParser () Char+_littleUValue = char 'u' *> do { + hs <- count 4 hexDigit;+ n <- _read readHex hs;+ return $ toEnum n+}++_escapedChar :: CharParser () Char+_escapedChar = choice (zipWith (\c r -> r <$ char c) "abnfrtv'\\\"/" "\a\b\n\f\r\t\v\'\\\"/")++_unicodeValue :: CharParser () Char+_unicodeValue = (char '\\' *> + (_bigUValue + <|> _littleUValue + <|> _hexByteUValue + <|> _escapedChar+ <|> _octalByteUValue)+ ) <|> noneOf "\\\""++_interpretedString :: CharParser () String+_interpretedString = between (char '"') (char '"') (many _unicodeValue)++_rawString :: CharParser () String+_rawString = between (char '`') (char '`') (many $ noneOf "`")++-- | For internal testing+stringLit :: CharParser () Text.Text+stringLit = Text.pack <$> (_rawString <|> _interpretedString)++_hexByteUValue :: CharParser () Char+_hexByteUValue = char 'x' *> do {+ hs <- count 2 hexDigit;+ n <- _read readHex hs;+ return $ chr n+}++_octalByteUValue :: CharParser () Char+_octalByteUValue = do {+ os <- count 3 octDigit;+ n <- _read readOct os;+ return $ toEnum n+}++_byteLit :: CharParser () Char+_byteLit = do {+ i <- _intLit;+ if i > 255 then+ fail $ "too large for byte: " ++ show i+ else+ return $ chr i+}++_byteElem :: CharParser () Char+_byteElem = _byteLit <|> between (char '\'') (char '\'') (_unicodeValue <|> _octalByteUValue <|> _hexByteUValue)++-- | For internal testing+bytesCastLit :: CharParser () ByteString.ByteString+bytesCastLit = ByteString.pack <$> (string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}')++_literal :: CharParser () AnyExpr+_literal = mkBoolExpr . boolExpr <$> bool+ <|> mkIntExpr . intExpr <$> intLit+ <|> mkUintExpr . uintExpr <$> uintCastLit+ <|> mkDoubleExpr . doubleExpr <$> doubleCastLit+ <|> mkStringExpr . stringExpr <$> stringLit+ <|> mkBytesExpr . bytesExpr <$> bytesCastLit++_terminal :: CharParser () AnyExpr+_terminal = (char '$' *> (+ 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+_builtinSymbol = string "==" + <|> string "!=" + <|> char '<' <::> opt (char '=')+ <|> char '>' <::> opt (char '=')+ <|> string "~="+ <|> string "*="+ <|> string "^="+ <|> string "$="+ <|> string "::"++_builtin :: MkFunc -> CharParser () AnyExpr+_builtin mkFunc = mkBuiltIn <$> _builtinSymbol <*> (ws *> _expr mkFunc) >>= check++_function :: MkFunc -> CharParser () AnyExpr+_function mkFunc = mkFunc <$> idLit <*> (char '(' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char ')') >>= check++_listType :: CharParser () String+_listType = char '[' <::> char ']' <::> (+ string "bool"+ <|> string "int"+ <|> string "uint"+ <|> string "double"+ <|> string "string"+ <|> string "[]byte" )++_mustBool :: AnyExpr -> CharParser () (Expr Bool)+_mustBool = check . assertBool++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 :: MkFunc -> CharParser () AnyExpr+_list mkFunc = do {+ ltype <- _listType;+ es <- ws *> char '{' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char '}';+ newList ltype es+}++_expr :: MkFunc -> CharParser () AnyExpr+_expr mkFunc = try _terminal <|> _list mkFunc <|> _function mkFunc++-- | For internal testing+expr :: MkFunc -> CharParser () (Expr Bool)+expr mkFunc = (try _terminal <|> _builtin mkFunc <|> _function mkFunc) >>= _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 {+ x1 <- p;+ string sep;+ x2 <- p;+ xs <- many (try (string sep *> p));+ return (x1:x2:xs)+}++_nameChoice :: CharParser () (Expr Bool)+_nameChoice = foldl1 orExpr <$> sepBy2 (ws *> nameExpr <* ws) "|"++-- | For internal testing+nameExpr :: CharParser () (Expr Bool)+nameExpr = (boolExpr True <$ char '_')+ <|> (notExpr <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')'))+ <|> (char '(' *> ws *> _nameChoice <* ws <* char ')')+ <|> _nameString++_concatPattern :: MkFunc -> CharParser () Pattern+_concatPattern mkFunc = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern mkFunc <* ws) ",") <* optional (char ',' <* ws) <* char ']'++_interleavePattern :: MkFunc -> CharParser () Pattern+_interleavePattern mkFunc = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern mkFunc <* ws) ";") <* optional (char ';' <* ws) <* char '}'++_parenPattern :: MkFunc -> CharParser () Pattern+_parenPattern mkFunc = do {+ char '(';+ ws;+ first <- pattern mkFunc;+ ws;+ ( char ')' *> ws *>+ (+ ZeroOrMore first <$ char '*'+ <|> Optional first <$ char '?'+ )+ ) <|> ( + (+ (first <$ char '|' >>= _orList mkFunc) <|> + (first <$ char '&' >>= _andList mkFunc)+ ) <* char ')'+ )+}++_orList :: MkFunc -> Pattern -> CharParser () Pattern+_orList mkFunc p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern mkFunc <* 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 :: MkFunc -> CharParser () Pattern+_notPattern mkFunc = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern mkFunc <* ws <* char ')')++_emptyPattern :: CharParser () Pattern+_emptyPattern = Empty <$ string "<empty>"++_zanyPattern :: CharParser () Pattern+_zanyPattern = ZAny <$ string "*"++_containsPattern :: MkFunc -> CharParser () Pattern+_containsPattern mkFunc = Contains <$> (char '.' *> pattern mkFunc)++_treenodePattern :: MkFunc -> CharParser () Pattern+_treenodePattern mkFunc = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern mkFunc) <|> _depthPattern mkFunc) )++_depthPattern :: MkFunc -> CharParser () Pattern+_depthPattern mkFunc = _concatPattern mkFunc <|> _interleavePattern mkFunc<|> _containsPattern mkFunc+ <|> flip Node Empty <$> ( (string "->" *> expr mkFunc) <|> (_builtin mkFunc>>= _mustBool) )++newContains :: CharParser () AnyExpr -> CharParser () Pattern+newContains e = flip Node Empty <$> ((mkBuiltIn "*=" <$> e) >>= check >>= _mustBool)++-- | For internal testing+pattern :: MkFunc -> CharParser () Pattern+pattern mkFunc = char '*' *> (+ (char '=' *> newContains (ws *> _expr mkFunc))+ <|> return ZAny+ ) <|> _parenPattern mkFunc+ <|> _refPattern+ <|> try _emptyPattern+ <|> try (_treenodePattern mkFunc)+ <|> try (_depthPattern mkFunc)+ <|> _notPattern mkFunc+ +_patternDecl :: MkFunc -> CharParser () Grammar+_patternDecl mkFunc = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern mkFunc)++-- | 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/Data/Katydid/Relapse/Relapse.hs view
@@ -0,0 +1,67 @@+-- |+-- This module provides an implementation of the relapse validation language.+--+-- Relapse is intended to be used for validation of trees or filtering of lists of trees.+--+-- Katydid currently provides two types of trees out of the box: Json and XML, +-- but relapse supports any type of tree as long the type +-- is of the Tree typeclass provided by the Parsers module.+--+-- The validate and filter functions expects a Tree to be a list of trees, +-- since not all serialization formats have a single root.+-- For example, valid json like "[1, 2]" does not have a single root.+-- Relapse can also validate these types of trees. +-- If your tree has a single root, simply provide a singleton list as input.++module Data.Katydid.Relapse.Relapse (+ parse, parseWithUDFs, Grammar+ , validate, filter+) where++import Prelude hiding (filter)+import Control.Monad.State (runState)+import Control.Monad (filterM)++import Data.Katydid.Parser.Parser++import qualified Data.Katydid.Relapse.Parser as Parser+import qualified Data.Katydid.Relapse.Ast as Ast+import qualified Data.Katydid.Relapse.MemDerive as MemDerive+import qualified Data.Katydid.Relapse.Smart as Smart+import qualified Data.Katydid.Relapse.Exprs as Exprs++-- | Grammar represents a compiled relapse grammar.+newtype Grammar = Grammar Smart.Grammar++-- |+-- 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;+}++-- |+-- 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.+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/Data/Katydid/Relapse/Simplify.hs view
@@ -0,0 +1,136 @@+{-#LANGUAGE GADTs #-}++-- |+-- This module simplifies Relapse patterns.++module Data.Katydid.Relapse.Simplify (+ simplify +) where++import qualified Data.Set as S++import Data.Katydid.Relapse.Ast+import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Exprs.Logic++-- |+-- simplify simplifies an input pattern to an equivalent simpler pattern.+simplify :: Grammar -> Pattern -> Pattern+simplify g pat =+ let simp = simplify' g+ in case pat of+ Empty -> Empty+ ZAny -> ZAny+ (Node v p) -> simplifyNode v (simp p)+ (Concat p1 p2) -> simplifyConcat (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)+ (Interleave p1 p2) -> simplifyInterleave (simp p1) (simp p2)+ (Contains p) -> simplifyContains (simp p)+ p@(Reference _) -> p++simplify' :: Grammar -> Pattern -> Pattern+simplify' g p = checkRef g $ simplify g p++simplifyNode :: Expr Bool -> Pattern -> Pattern+simplifyNode v p = case evalConst v of+ (Just False) -> Not ZAny+ _ -> Node v p++simplifyConcat :: Pattern -> Pattern -> Pattern+simplifyConcat (Not ZAny) _ = Not ZAny+simplifyConcat _ (Not ZAny) = Not ZAny+simplifyConcat (Concat p1 p2) p3 = + simplifyConcat p1 (Concat p2 p3)+simplifyConcat Empty p = p+simplifyConcat p Empty = p+simplifyConcat ZAny (Concat p ZAny) = Contains p+simplifyConcat p1 p2 = Concat p1 p2++simplifyOr :: 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 (orExpr v1 v2) Empty+simplifyOr g Empty p + | nullable g p == Right True = p+ | otherwise = Or Empty 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++simplifyChildren :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> [Pattern]+simplifyChildren _ [] = []+simplifyChildren _ [p] = [p]+simplifyChildren op (p1@(Node v1 c1):(p2@(Node v2 c2):ps))+ | v1 == v2 = simplifyChildren op $ Node v1 (op c1 c2):ps+ | otherwise = p1:simplifyChildren op (p2:ps)+simplifyChildren op (p:ps) = p:simplifyChildren op ps++bin :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> Pattern+bin op [p] = p+bin op [p1,p2] = op p1 p2+bin op (p:ps) = op p (bin op ps)++setOfOrs :: Pattern -> S.Set Pattern+setOfOrs (Or p1 p2) = setOfOrs p1 `S.union` setOfOrs p2+setOfOrs p = S.singleton p++simplifyAnd :: 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 (andExpr v1 v2) Empty+simplifyAnd g Empty p+ | nullable g p == Right True = Empty+ | otherwise = Not ZAny+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++setOfAnds :: Pattern -> S.Set Pattern+setOfAnds (And p1 p2) = setOfAnds p1 `S.union` setOfAnds p2+setOfAnds p = S.singleton p++simplifyZeroOrMore :: Pattern -> Pattern+simplifyZeroOrMore (ZeroOrMore p) = ZeroOrMore p+simplifyZeroOrMore p = ZeroOrMore p++simplifyNot :: Pattern -> Pattern+simplifyNot (Not p) = p+simplifyNot p = Not p++simplifyOptional :: Pattern -> Pattern+simplifyOptional Empty = Empty+simplifyOptional p = Optional p++simplifyInterleave :: Pattern -> Pattern -> Pattern+simplifyInterleave (Not ZAny) _ = Not ZAny+simplifyInterleave _ (Not ZAny) = Not ZAny+simplifyInterleave Empty p = p+simplifyInterleave p Empty = p+simplifyInterleave ZAny ZAny = ZAny+simplifyInterleave p1 p2 = bin Interleave $ S.toAscList $ setOfInterleaves p1 `S.union` setOfInterleaves p2++setOfInterleaves :: Pattern -> S.Set Pattern+setOfInterleaves (Interleave p1 p2) = setOfInterleaves p1 `S.union` setOfInterleaves p2+setOfInterleaves p = S.singleton p++simplifyContains :: Pattern -> Pattern+simplifyContains Empty = ZAny+simplifyContains ZAny = ZAny+simplifyContains (Not ZAny) = Not ZAny+simplifyContains p = Contains p++checkRef :: Grammar -> Pattern -> Pattern+checkRef g p = case reverseLookupRef p g of+ Nothing -> p+ (Just k) -> Reference k+
+ src/Data/Katydid/Relapse/Smart.hs view
@@ -0,0 +1,417 @@+-- |+-- This module describes the smart constructors for Relapse patterns.+module Data.Katydid.Relapse.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 Data.Katydid.Relapse.Expr as Expr+import Data.Katydid.Relapse.Exprs.Logic (orExpr, andExpr)+import qualified Data.Katydid.Relapse.Ast as 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/Data/Katydid/Relapse/VpaDerive.hs view
@@ -0,0 +1,101 @@+-- |+-- 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 our algorithm is effectively equivalent to a visibly pushdown automaton.++module Data.Katydid.Relapse.VpaDerive (+ derive +) where++import qualified Data.Map.Strict as M+import Control.Monad.State (State, runState, state, lift)+import Data.Foldable (foldlM)+import Control.Monad.Trans.Except (ExceptT(..), runExceptT)++import Data.Katydid.Parser.Parser++import qualified Data.Katydid.Relapse.Derive as Derive+import Data.Katydid.Relapse.Smart (Grammar, Pattern)+import qualified Data.Katydid.Relapse.Smart as Smart+import Data.Katydid.Relapse.IfExprs+import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Zip++mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)+mem f k m+ | M.member k m = (m M.! k, m)+ | otherwise = let res = f k+ in (res, M.insert k res m)++type VpaState = [Pattern]+type StackElm = ([Pattern], Zipper)++type Calls = M.Map VpaState ZippedIfExprs+type Nullable = M.Map [Pattern] [Bool]+type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern]++newtype Vpa = Vpa (Nullable, Calls, Returns, Grammar)++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, 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, g)) -> let (v', c') = mem (zipIfExprs . Derive.calls g) key c;+ in (v', Vpa (n, c', r, g))++vpacall :: VpaState -> Label -> ExceptT String (State Vpa) (StackElm, VpaState)+vpacall vpastate label = do {+ zifexprs <- lift $ calls vpastate;+ (nextstate, zipper) <- hoistExcept $ evalZippedIfExprs zifexprs label;+ let + stackelm = (vpastate, zipper)+ ; + return (stackelm, nextstate)+}++hoistExcept :: (Monad m) => Either e a -> ExceptT e m a+hoistExcept = ExceptT . return++returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern]+returns key = state $ \(Vpa (n, c, r, g)) -> + let (v', r') = mem (\(ps, zipper, znulls) -> + 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 {+ zipnulls <- nullable current;+ returns (vpastate, zipper, zipnulls)+}++deriv :: Tree t => VpaState -> t -> ExceptT 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] -> Either String [Pattern]+foldLT _ current [] = return current+foldLT m current (t:ts) = + let (newstate, newm) = runState (runExceptT $ deriv current t) m+ in case newstate of+ (Left l) -> Left l+ (Right r) -> foldLT newm r ts++-- |+-- 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) -> Left $ "Number of patterns is not one, but " ++ show rs
+ src/Data/Katydid/Relapse/Zip.hs view
@@ -0,0 +1,47 @@+-- |+-- This is an internal relapse module.+--+-- It zips patterns to reduce the state space.++module Data.Katydid.Relapse.Zip (+ Zipper, zippy, unzipby+) where++import qualified Data.Set as S+import Data.List (elemIndex)++import Data.Katydid.Relapse.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 emptySet s'+ l = S.toAscList s''+ in (l, Zipper $ map (indexOf l) ps)++indexOf :: [Pattern] -> Pattern -> ZipEntry+indexOf _ ZAny = ZipZAny+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++ofIndexb :: [Bool] -> ZipEntry -> Bool+ofIndexb _ ZipZAny = True+ofIndexb _ ZipNotZAny = False+ofIndexb bs (ZipVal i) = bs !! i
− src/Derive.hs
@@ -1,164 +0,0 @@--- |--- This module is a simple implementation of the internal derivative algorithm.------ It is intended to be used for explanation purposes.------ This means that it gives up speed for readability.------ Thus it has no type of memoization.--module Derive (- derive, calls, returns, zipderive- -- * Internal functions- -- | These functions are exposed for testing purposes.- , removeOneForEach-) where--import Data.Foldable (foldlM)-import Data.List.Index (imap)--import Smart-import Parsers-import Simplify-import Zip-import IfExprs---- | --- calls returns a compiled if expression tree.--- Each if expression returns a child pattern, given the input value.--- In other words calls signature is actually:------ @--- Refs -> [Pattern] -> Value -> [Pattern]--- @------ , where the resulting list of patterns are the child patterns,--- that need to be derived given the trees child values.-calls :: Grammar -> [Pattern] -> IfExprs-calls g ps = compileIfExprs $ concatMap (\p -> deriveCall g p []) ps--deriveCall :: Grammar -> Pattern -> [IfExpr] -> [IfExpr]-deriveCall _ Empty res = res-deriveCall _ ZAny res = 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 :: Grammar -> ([Pattern], [Bool]) -> [Pattern]-returns _ ([], []) = []-returns g (p:tailps, ns) =- let (dp, tailns) = deriveReturn g p ns- in dp:returns g (tailps, tailns)--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--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 => 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 => Grammar -> [Pattern] -> t -> Either String [Pattern]-deriv g ps tree =- if all unescapable ps then return ps else- 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 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 => 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 => Grammar -> [Pattern] -> t -> Either String [Pattern]-zipderiv g ps tree =- if all unescapable ps then return ps else- 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 g (ps, unzipns)- }
− src/Expr.hs
@@ -1,509 +0,0 @@--- |--- This module contains all the functions you need to implement a Relapse expression.--module Expr (- 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.Char (ord)-import Data.List (intercalate)-import Data.Text (Text, unpack, pack)-import Data.ByteString (ByteString)--import qualified Parsers---- |--- 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---- |--- 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---- |--- 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-}---- |--- 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-}--instance Show Desc where- show = _toStr--instance Ord Desc where- compare = cmp--instance Eq Desc where- (==) a b = cmp a b == EQ---- |--- 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-}---- |--- 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)--instance Show AnyExpr where- show a = show (_desc a)--instance Eq AnyExpr where- (==) a b = _desc a == _desc b--instance Ord AnyExpr where- compare a b = cmp (_desc a) (_desc b)---- |--- 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])---- |--- 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-}--instance Show (Expr a) where- show e = show (desc e)--instance Eq (Expr a) where- (==) x y = desc x == desc y--instance Ord (Expr a) where- compare x y = cmp (desc x) (desc y)---- |--- params returns the descriptions of the parameters of the user defined expression.-params :: Expr a -> [Desc]-params = _params . desc---- |--- name returns the name of the user defined expression.-name :: Expr a -> String-name = _name . desc---- |--- hasVar returns whether the expression or any of its children contains a variable expression.-hasVar :: Expr a -> Bool-hasVar = _hasVar . desc---- |--- mkBoolExpr generalises a bool expression to any expression.-mkBoolExpr :: Expr Bool -> AnyExpr-mkBoolExpr (Expr desc eval) = AnyExpr desc (BoolFunc eval)---- |--- 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"---- |--- mkIntExpr generalises an int expression to any expression.-mkIntExpr :: Expr Int -> AnyExpr-mkIntExpr (Expr desc eval) = AnyExpr desc (IntFunc eval)---- |--- 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"---- |--- mkDoubleExpr generalises a double expression to any expression.-mkDoubleExpr :: Expr Double -> AnyExpr-mkDoubleExpr (Expr desc eval) = AnyExpr desc (DoubleFunc eval)---- |--- 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"---- |--- mkStringExpr generalises a string expression to any expression.-mkStringExpr :: Expr Text -> AnyExpr-mkStringExpr (Expr desc eval) = AnyExpr desc (StringFunc eval)---- |--- 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"---- |--- mkUintExpr generalises a uint expression to any expression.-mkUintExpr :: Expr Word -> AnyExpr-mkUintExpr (Expr desc eval) = AnyExpr desc (UintFunc eval)---- |--- 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"---- |--- mkBytesExpr generalises a bytes expression to any expression.-mkBytesExpr :: Expr ByteString -> AnyExpr-mkBytesExpr (Expr desc eval) = AnyExpr desc (BytesFunc eval)---- |--- 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"---- |--- mkBoolsExpr generalises a list of bools expression to any expression.-mkBoolsExpr :: Expr [Bool] -> AnyExpr-mkBoolsExpr (Expr desc eval) = AnyExpr desc (BoolsFunc eval)---- |--- 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"---- |--- mkIntsExpr generalises a list of ints expression to any expression.-mkIntsExpr :: Expr [Int] -> AnyExpr-mkIntsExpr (Expr desc eval) = AnyExpr desc (IntsFunc eval)---- |--- 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"---- |--- mkUintsExpr generalises a list of uints expression to any expression.-mkUintsExpr :: Expr [Word] -> AnyExpr-mkUintsExpr (Expr desc eval) = AnyExpr desc (UintsFunc eval)---- |--- 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"---- |--- mkDoublesExpr generalises a list of doubles expression to any expression.-mkDoublesExpr :: Expr [Double] -> AnyExpr-mkDoublesExpr (Expr desc eval) = AnyExpr desc (DoublesFunc eval)---- |--- 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"---- |--- mkStringsExpr generalises a list of strings expression to any expression.-mkStringsExpr :: Expr [Text] -> AnyExpr-mkStringsExpr (Expr desc eval) = AnyExpr desc (StringsFunc eval)---- |--- 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"---- |--- mkListOfBytesExpr generalises a list of bytes expression to any expression.-mkListOfBytesExpr :: Expr [ByteString] -> AnyExpr-mkListOfBytesExpr (Expr desc eval) = AnyExpr desc (ListOfBytesFunc eval)---- |--- 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"---- 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)---- |--- 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)---- |--- hashString calcuates a hash of a string.-hashString :: String -> Int-hashString s = hashList 0 (map ord s)---- |--- 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)--noLabel :: Parsers.Label-noLabel = Parsers.String (pack "not a label, trying constant evaluation")---- |--- 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---- |--- 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---- |--- 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-}---- |--- 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-}---- |--- 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-}---- |--- 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-}---- |--- 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-}---- |--- 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-}---- |--- 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---- |--- 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---- |--- 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---- |--- 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---- |--- 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---- |--- 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---- |--- 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" ---- |--- 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"---- |--- 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"---- |--- 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"---- |--- 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"---- |--- 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"--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
@@ -1,86 +0,0 @@--- |--- 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
@@ -1,191 +0,0 @@--- |--- 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
@@ -1,48 +0,0 @@--- |--- 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
@@ -1,35 +0,0 @@--- |--- 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
@@ -1,54 +0,0 @@--- |--- 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
@@ -1,128 +0,0 @@--- |--- 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
@@ -1,107 +0,0 @@--- |--- 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
@@ -1,36 +0,0 @@--- |--- 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
@@ -1,126 +0,0 @@--- |--- 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
@@ -1,85 +0,0 @@--- |--- This is an internal relapse module.------ It contains multiple implementations of if expressions.--module IfExprs (- IfExprs, IfExpr, newIfExpr,- evalIfExprs, compileIfExprs,- ZippedIfExprs, zipIfExprs, evalZippedIfExprs-) where--import 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- , thn :: IfExprs- , els :: IfExprs- }- | Ret [Pattern]---- | 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)---- | 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-}--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)- | 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- , zthn :: ZippedIfExprs- , zels :: ZippedIfExprs- }- | 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 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;- if b then evalZippedIfExprs t v else evalZippedIfExprs e v-}-
− src/Json.hs
@@ -1,50 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}---- |--- This module contains the Json Parser.--module Json (- decodeJSON, JsonTree-) 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--instance Tree JsonTree where- getLabel (DataTree.Node l _) = l- getChildren (DataTree.Node _ cs) = cs---- |--- JsonTree is a tree that can be validated by Relapse.-type JsonTree = DataTree.Tree Label---- |--- decodeJSON returns a JsonTree, given an input string.-decodeJSON :: String -> Either String [JsonTree]-decodeJSON s = case decode s of- (Error e) -> Left e- (Ok v) -> Right (uValue v)--uValue :: JSValue -> [JsonTree]-uValue JSNull = []-uValue (JSBool b) = [DataTree.Node (Bool b) []]-uValue (JSRational _ r) = 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 (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 $ pack name) (uValue value)
− src/MemDerive.hs
@@ -1,90 +0,0 @@--- |--- This module is an efficient implementation of the derivative algorithm for trees.------ It is intended to be used for production purposes.------ This means that it gives up some readability for speed.------ This module provides memoization of the nullable, calls and returns functions.--module MemDerive (- derive, Mem, newMem, validate-) where--import qualified Data.Map.Strict as M-import Control.Monad.State (State, runState, lift, state)-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)--import qualified Derive-import Smart (Grammar, Pattern, lookupRef, nullable, lookupMain)-import IfExprs-import Expr-import Zip-import Parsers--mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)-mem f k m- | M.member k m = (m M.! k, m)- | otherwise = let res = f k- in (res, M.insert k res m)--type 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 (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)--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 :: 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 => Grammar -> [Pattern] -> [t] -> ExceptT String (State Mem) [Pattern]-mderive _ ps [] = return ps-mderive g ps (tree:ts) = do {- ifs <- lift $ calls g ps;- childps <- hoistExcept $ evalIfExprs ifs (getLabel tree);- (zchildps, zipper) <- return $ zippy childps;- childres <- mderive g zchildps (getChildren tree);- let - nulls = map nullable childres- unzipns = unzipby zipper nulls- ;- rs <- lift $ returns g (ps, unzipns);- mderive g rs ts-}--hoistExcept :: (Monad m) => Either e a -> ExceptT e m a-hoistExcept = ExceptT . return---- |--- derive is the classic derivative implementation for trees.-derive :: Tree t => Grammar -> [t] -> Either String Pattern-derive g ts =- let start = [lookupMain g]- (res, _) = runState (runExceptT $ mderive g start ts) newMem- in case res of- (Left l) -> Left l- (Right [r]) -> return r- (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 => Grammar -> Pattern -> [t] -> (State Mem) Bool-validate g start tree = do {- rs <- runExceptT (mderive g [start] tree);- return $ case rs of- (Right [r]) -> nullable r- _ -> False-}
− src/Parser.hs
@@ -1,388 +0,0 @@--- |--- This module parses the Relapse Grammar using the Parsec Library.--module Parser (- -- * Parse Grammar- parseGrammar, parseGrammarWithUDFs- -- * Internal functions- -- | These functions are exposed for testing purposes.- , grammar, pattern, nameExpr, expr, - idLit, bytesCastLit, stringLit, doubleCastLit, uintCastLit, intLit, ws-) where--import Text.ParserCombinators.Parsec-import Numeric (readDec, readOct, readHex, readFloat)-import Data.Char (chr)-import qualified Data.Text as Text-import qualified Data.ByteString.Char8 as ByteString-import Control.Arrow (left)--import Expr-import Exprs-import Exprs.Logic-import Exprs.Var-import Ast---- | parseGrammar parses the Relapse Grammar.-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--infixr 5 <::>-(<::>) :: 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 ""--opt :: CharParser () Char -> CharParser () String-opt p = (:"") <$> p <|> empty--_lineComment :: CharParser () ()-_lineComment = char '/' *> many (noneOf "\n") <* char '\n' *> return ()--_blockComment :: CharParser () ()-_blockComment = char '*' *> many (noneOf "*") <* char '*' <* char '/' *> return ()--_comment :: CharParser () ()-_comment = char '/' *> (_lineComment <|> _blockComment)--_ws :: CharParser () ()-_ws = _comment <|> () <$ space---- | For internal testing-ws :: CharParser () ()-ws = () <$ many _ws--bool :: CharParser () Bool-bool = True <$ string "true"- <|> False <$ string "false"--_decimalLit :: CharParser () Int-_decimalLit = oneOf "123456789" <::> many digit >>= _read readDec--_octalLit :: CharParser () Int-_octalLit = many1 octDigit >>= _read readOct--_hexLit :: CharParser () Int-_hexLit = many1 hexDigit >>= _read readHex--_read :: ReadS a -> String -> CharParser () a-_read read s = case read s of- [(n, "")] -> return n- ((n, ""):_) -> return n- _ -> fail "digit"--_optionalSign :: (Num a) => CharParser () a-_optionalSign = -1 <$ char '-' <|> return 1--_signedIntLit :: CharParser () Int-_signedIntLit = (*) <$> _optionalSign <*> _intLit--_intLit :: CharParser () Int-_intLit = _decimalLit - <|> char '0' *> (_octalLit - <|> (oneOf "xX" *> _hexLit)- <|> return 0- )---- | For internal testing-intLit :: CharParser () Int-intLit = string "int(" *> _signedIntLit <* char ')'- <|> _signedIntLit- <?> "int_lit"--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 - <|> many1 digit)--_floatLit :: CharParser () Double-_floatLit = do- i <- many1 digit- e <- _exponent - <|> ((string "." <|> empty) <++> - (_exponent - <|> many1 digit <++>- (_exponent- <|> empty)- )- ) - <|> 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 '_')--_qualid :: CharParser () String-_qualid = idLit <++> (concat <$> many (char '.' <::> idLit))--_bigUValue :: CharParser () Char-_bigUValue = char 'U' *> do {- hs <- count 8 hexDigit;- n <- _read readHex hs;- return $ toEnum n-}--_littleUValue :: CharParser () Char-_littleUValue = char 'u' *> do { - hs <- count 4 hexDigit;- n <- _read readHex hs;- return $ toEnum n-}--_escapedChar :: CharParser () Char-_escapedChar = choice (zipWith (\c r -> r <$ char c) "abnfrtv'\\\"/" "\a\b\n\f\r\t\v\'\\\"/")--_unicodeValue :: CharParser () Char-_unicodeValue = (char '\\' *> - (_bigUValue - <|> _littleUValue - <|> _hexByteUValue - <|> _escapedChar- <|> _octalByteUValue)- ) <|> noneOf "\\\""--_interpretedString :: CharParser () String-_interpretedString = between (char '"') (char '"') (many _unicodeValue)--_rawString :: CharParser () String-_rawString = between (char '`') (char '`') (many $ noneOf "`")---- | For internal testing-stringLit :: CharParser () Text.Text-stringLit = Text.pack <$> (_rawString <|> _interpretedString)--_hexByteUValue :: CharParser () Char-_hexByteUValue = char 'x' *> do {- hs <- count 2 hexDigit;- n <- _read readHex hs;- return $ chr n-}--_octalByteUValue :: CharParser () Char-_octalByteUValue = do {- os <- count 3 octDigit;- n <- _read readOct os;- return $ toEnum n-}--_byteLit :: CharParser () Char-_byteLit = do {- i <- _intLit;- if i > 255 then- fail $ "too large for byte: " ++ show i- else- return $ chr i-}--_byteElem :: CharParser () Char-_byteElem = _byteLit <|> between (char '\'') (char '\'') (_unicodeValue <|> _octalByteUValue <|> _hexByteUValue)---- | For internal testing-bytesCastLit :: CharParser () ByteString.ByteString-bytesCastLit = ByteString.pack <$> (string "[]byte{" *> sepBy (ws *> _byteElem <* ws) (char ',') <* char '}')--_literal :: CharParser () AnyExpr-_literal = mkBoolExpr . boolExpr <$> bool- <|> mkIntExpr . intExpr <$> intLit- <|> mkUintExpr . uintExpr <$> uintCastLit- <|> mkDoubleExpr . doubleExpr <$> doubleCastLit- <|> mkStringExpr . stringExpr <$> stringLit- <|> mkBytesExpr . bytesExpr <$> bytesCastLit--_terminal :: CharParser () AnyExpr-_terminal = (char '$' *> (- 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-_builtinSymbol = string "==" - <|> string "!=" - <|> char '<' <::> opt (char '=')- <|> char '>' <::> opt (char '=')- <|> string "~="- <|> string "*="- <|> string "^="- <|> string "$="- <|> string "::"--_builtin :: MkFunc -> CharParser () AnyExpr-_builtin mkFunc = mkBuiltIn <$> _builtinSymbol <*> (ws *> _expr mkFunc) >>= check--_function :: MkFunc -> CharParser () AnyExpr-_function mkFunc = mkFunc <$> idLit <*> (char '(' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char ')') >>= check--_listType :: CharParser () String-_listType = char '[' <::> char ']' <::> (- string "bool"- <|> string "int"- <|> string "uint"- <|> string "double"- <|> string "string"- <|> string "[]byte" )--_mustBool :: AnyExpr -> CharParser () (Expr Bool)-_mustBool = check . assertBool--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 :: MkFunc -> CharParser () AnyExpr-_list mkFunc = do {- ltype <- _listType;- es <- ws *> char '{' *> sepBy (ws *> _expr mkFunc <* ws) (char ',') <* char '}';- newList ltype es-}--_expr :: MkFunc -> CharParser () AnyExpr-_expr mkFunc = try _terminal <|> _list mkFunc <|> _function mkFunc---- | For internal testing-expr :: MkFunc -> CharParser () (Expr Bool)-expr mkFunc = (try _terminal <|> _builtin mkFunc <|> _function mkFunc) >>= _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 {- x1 <- p;- string sep;- x2 <- p;- xs <- many (try (string sep *> p));- return (x1:x2:xs)-}--_nameChoice :: CharParser () (Expr Bool)-_nameChoice = foldl1 orExpr <$> sepBy2 (ws *> nameExpr <* ws) "|"---- | For internal testing-nameExpr :: CharParser () (Expr Bool)-nameExpr = (boolExpr True <$ char '_')- <|> (notExpr <$> (char '!' *> ws *> char '(' *> ws *> nameExpr <* ws <* char ')'))- <|> (char '(' *> ws *> _nameChoice <* ws <* char ')')- <|> _nameString--_concatPattern :: MkFunc -> CharParser () Pattern-_concatPattern mkFunc = char '[' *> (foldl1 Concat <$> sepBy2 (ws *> pattern mkFunc <* ws) ",") <* optional (char ',' <* ws) <* char ']'--_interleavePattern :: MkFunc -> CharParser () Pattern-_interleavePattern mkFunc = char '{' *> (foldl1 Interleave <$> sepBy2 (ws *> pattern mkFunc <* ws) ";") <* optional (char ';' <* ws) <* char '}'--_parenPattern :: MkFunc -> CharParser () Pattern-_parenPattern mkFunc = do {- char '(';- ws;- first <- pattern mkFunc;- ws;- ( char ')' *> ws *>- (- ZeroOrMore first <$ char '*'- <|> Optional first <$ char '?'- )- ) <|> ( - (- (first <$ char '|' >>= _orList mkFunc) <|> - (first <$ char '&' >>= _andList mkFunc)- ) <* char ')'- )-}--_orList :: MkFunc -> Pattern -> CharParser () Pattern-_orList mkFunc p = Or p . foldl1 Or <$> sepBy1 (ws *> pattern mkFunc <* 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 :: MkFunc -> CharParser () Pattern-_notPattern mkFunc = Not <$> (char '!' *> ws *> char '(' *> ws *> pattern mkFunc <* ws <* char ')')--_emptyPattern :: CharParser () Pattern-_emptyPattern = Empty <$ string "<empty>"--_zanyPattern :: CharParser () Pattern-_zanyPattern = ZAny <$ string "*"--_containsPattern :: MkFunc -> CharParser () Pattern-_containsPattern mkFunc = Contains <$> (char '.' *> pattern mkFunc)--_treenodePattern :: MkFunc -> CharParser () Pattern-_treenodePattern mkFunc = Node <$> nameExpr <*> ( ws *> ( try (char ':' *> ws *> pattern mkFunc) <|> _depthPattern mkFunc) )--_depthPattern :: MkFunc -> CharParser () Pattern-_depthPattern mkFunc = _concatPattern mkFunc <|> _interleavePattern mkFunc<|> _containsPattern mkFunc- <|> flip Node Empty <$> ( (string "->" *> expr mkFunc) <|> (_builtin mkFunc>>= _mustBool) )--newContains :: CharParser () AnyExpr -> CharParser () Pattern-newContains e = flip Node Empty <$> ((mkBuiltIn "*=" <$> e) >>= check >>= _mustBool)---- | For internal testing-pattern :: MkFunc -> CharParser () Pattern-pattern mkFunc = char '*' *> (- (char '=' *> newContains (ws *> _expr mkFunc))- <|> return ZAny- ) <|> _parenPattern mkFunc- <|> _refPattern- <|> try _emptyPattern- <|> try (_treenodePattern mkFunc)- <|> try (_depthPattern mkFunc)- <|> _notPattern mkFunc- -_patternDecl :: MkFunc -> CharParser () Grammar-_patternDecl mkFunc = newRef <$> (char '#' *> ws *> idLit) <*> (ws *> char '=' *> ws *> pattern mkFunc)---- | 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
@@ -1,34 +0,0 @@-{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}---- |--- This module describes the abstract tree that can be validated by Relapse.------ The JSON and XML parsers both are both versions of this type class.--module Parsers (- Tree(..), Label(..)-) where--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 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/Relapse.hs
@@ -1,66 +0,0 @@--- |--- This module provides an implementation of the relapse validation language.------ Relapse is intended to be used for validation of trees or filtering of lists of trees.------ Katydid currently provides two types of trees out of the box: Json and XML, --- but relapse supports any type of tree as long the type --- is of the Tree typeclass provided by the Parsers module.------ The validate and filter functions expects a Tree to be a list of trees, --- since not all serialization formats have a single root.--- For example, valid json like "[1, 2]" does not have a single root.--- Relapse can also validate these types of trees. --- If your tree has a single root, simply provide a singleton list as input.--module Relapse (- parse, parseWithUDFs, Grammar- , validate, filter-) where--import Prelude hiding (filter)-import Control.Monad.State (runState)-import Control.Monad (filterM)--import qualified Parser-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---- |--- 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;-}---- |--- 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.-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
@@ -1,136 +0,0 @@-{-#LANGUAGE GADTs #-}---- |--- This module simplifies Relapse patterns.--module Simplify (- simplify -) where--import qualified Data.Set as S--import Ast-import Expr-import Exprs.Logic---- |--- simplify simplifies an input pattern to an equivalent simpler pattern.-simplify :: Grammar -> Pattern -> Pattern-simplify g pat =- let simp = simplify' g- in case pat of- Empty -> Empty- ZAny -> ZAny- (Node v p) -> simplifyNode v (simp p)- (Concat p1 p2) -> simplifyConcat (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)- (Interleave p1 p2) -> simplifyInterleave (simp p1) (simp p2)- (Contains p) -> simplifyContains (simp p)- p@(Reference _) -> p--simplify' :: Grammar -> Pattern -> Pattern-simplify' g p = checkRef g $ simplify g p--simplifyNode :: Expr Bool -> Pattern -> Pattern-simplifyNode v p = case evalConst v of- (Just False) -> Not ZAny- _ -> Node v p--simplifyConcat :: Pattern -> Pattern -> Pattern-simplifyConcat (Not ZAny) _ = Not ZAny-simplifyConcat _ (Not ZAny) = Not ZAny-simplifyConcat (Concat p1 p2) p3 = - simplifyConcat p1 (Concat p2 p3)-simplifyConcat Empty p = p-simplifyConcat p Empty = p-simplifyConcat ZAny (Concat p ZAny) = Contains p-simplifyConcat p1 p2 = Concat p1 p2--simplifyOr :: 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 (orExpr v1 v2) Empty-simplifyOr g Empty p - | nullable g p == Right True = p- | otherwise = Or Empty 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--simplifyChildren :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> [Pattern]-simplifyChildren _ [] = []-simplifyChildren _ [p] = [p]-simplifyChildren op (p1@(Node v1 c1):(p2@(Node v2 c2):ps))- | v1 == v2 = simplifyChildren op $ Node v1 (op c1 c2):ps- | otherwise = p1:simplifyChildren op (p2:ps)-simplifyChildren op (p:ps) = p:simplifyChildren op ps--bin :: (Pattern -> Pattern -> Pattern) -> [Pattern] -> Pattern-bin op [p] = p-bin op [p1,p2] = op p1 p2-bin op (p:ps) = op p (bin op ps)--setOfOrs :: Pattern -> S.Set Pattern-setOfOrs (Or p1 p2) = setOfOrs p1 `S.union` setOfOrs p2-setOfOrs p = S.singleton p--simplifyAnd :: 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 (andExpr v1 v2) Empty-simplifyAnd g Empty p- | nullable g p == Right True = Empty- | otherwise = Not ZAny-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--setOfAnds :: Pattern -> S.Set Pattern-setOfAnds (And p1 p2) = setOfAnds p1 `S.union` setOfAnds p2-setOfAnds p = S.singleton p--simplifyZeroOrMore :: Pattern -> Pattern-simplifyZeroOrMore (ZeroOrMore p) = ZeroOrMore p-simplifyZeroOrMore p = ZeroOrMore p--simplifyNot :: Pattern -> Pattern-simplifyNot (Not p) = p-simplifyNot p = Not p--simplifyOptional :: Pattern -> Pattern-simplifyOptional Empty = Empty-simplifyOptional p = Optional p--simplifyInterleave :: Pattern -> Pattern -> Pattern-simplifyInterleave (Not ZAny) _ = Not ZAny-simplifyInterleave _ (Not ZAny) = Not ZAny-simplifyInterleave Empty p = p-simplifyInterleave p Empty = p-simplifyInterleave ZAny ZAny = ZAny-simplifyInterleave p1 p2 = bin Interleave $ S.toAscList $ setOfInterleaves p1 `S.union` setOfInterleaves p2--setOfInterleaves :: Pattern -> S.Set Pattern-setOfInterleaves (Interleave p1 p2) = setOfInterleaves p1 `S.union` setOfInterleaves p2-setOfInterleaves p = S.singleton p--simplifyContains :: Pattern -> Pattern-simplifyContains Empty = ZAny-simplifyContains ZAny = ZAny-simplifyContains (Not ZAny) = Not ZAny-simplifyContains p = Contains p--checkRef :: Grammar -> Pattern -> Pattern-checkRef g p = case reverseLookupRef p g of- Nothing -> p- (Just k) -> Reference k-
− src/Smart.hs
@@ -1,417 +0,0 @@--- |--- 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
@@ -1,100 +0,0 @@--- |--- 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 our algorithm is effectively equivalent to a visibly pushdown automaton.--module VpaDerive (- derive -) where--import qualified Data.Map.Strict as M-import Control.Monad.State (State, runState, state, lift)-import Data.Foldable (foldlM)-import Control.Monad.Trans.Except (ExceptT(..), runExceptT)--import qualified Derive-import Smart (Grammar, Pattern)-import qualified Smart-import IfExprs-import Expr-import Zip-import Parsers--mem :: Ord k => (k -> v) -> k -> M.Map k v -> (v, M.Map k v)-mem f k m- | M.member k m = (m M.! k, m)- | otherwise = let res = f k- in (res, M.insert k res m)--type VpaState = [Pattern]-type StackElm = ([Pattern], Zipper)--type Calls = M.Map VpaState ZippedIfExprs-type Nullable = M.Map [Pattern] [Bool]-type Returns = M.Map ([Pattern], Zipper, [Bool]) [Pattern]--newtype Vpa = Vpa (Nullable, Calls, Returns, Grammar)--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, 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, g)) -> let (v', c') = mem (zipIfExprs . Derive.calls g) key c;- in (v', Vpa (n, c', r, g))--vpacall :: VpaState -> Label -> ExceptT String (State Vpa) (StackElm, VpaState)-vpacall vpastate label = do {- zifexprs <- lift $ calls vpastate;- (nextstate, zipper) <- hoistExcept $ evalZippedIfExprs zifexprs label;- let - stackelm = (vpastate, zipper)- ; - return (stackelm, nextstate)-}--hoistExcept :: (Monad m) => Either e a -> ExceptT e m a-hoistExcept = ExceptT . return--returns :: ([Pattern], Zipper, [Bool]) -> State Vpa [Pattern]-returns key = state $ \(Vpa (n, c, r, g)) -> - let (v', r') = mem (\(ps, zipper, znulls) -> - 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 {- zipnulls <- nullable current;- returns (vpastate, zipper, zipnulls)-}--deriv :: Tree t => VpaState -> t -> ExceptT 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] -> Either String [Pattern]-foldLT _ current [] = return current-foldLT m current (t:ts) = - let (newstate, newm) = runState (runExceptT $ deriv current t) m- in case newstate of- (Left l) -> Left l- (Right r) -> foldLT newm r ts---- |--- 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) -> Left $ "Number of patterns is not one, but " ++ show rs
− src/Xml.hs
@@ -1,42 +0,0 @@-{-# LANGUAGE FlexibleInstances #-}---- |--- This module contains the XML Parser.--module Xml (- decodeXML-) where--import Text.Read (readMaybe)-import Text.XML.HXT.DOM.TypeDefs (XmlTree, XNode(..), blobToString, localPart)-import Text.XML.HXT.Parser.XmlParsec (xread)-import Data.Tree.NTree.TypeDefs (NTree(..))-import qualified Data.Text as Text--import Parsers--instance Tree XmlTree where- getLabel (NTree n _ ) = either (String . Text.pack . ("XML Parse Error:" ++)) id (xmlLabel n)- getChildren (NTree _ cs) = cs---- |--- decodeXML returns a XmlTree, given an input string.-decodeXML :: String -> [XmlTree]-decodeXML = xread--xmlLabel :: XNode -> Either String Label-xmlLabel (XText s) = return $ parseLabel s-xmlLabel (XBlob b) = return $ parseLabel $ blobToString b-xmlLabel x@(XCharRef _) = fail $ "XCharRef not supported" ++ show x-xmlLabel x@(XEntityRef _) = fail $ "XEntityRef not supported" ++ show x-xmlLabel x@(XCmt _) = fail $ "XCmt not supported" ++ show x-xmlLabel (XCdata s) = return $ parseLabel s-xmlLabel x@XPi{} = fail $ "XPi not supported" ++ show x-xmlLabel (XTag qname attrs) = return $ parseLabel (localPart qname) -- TODO attrs should be part of the children returned by getChildren-xmlLabel x@XDTD{} = fail $ "XDTD not supported" ++ show x-xmlLabel (XAttr qname) = return $ parseLabel (localPart qname)-xmlLabel x@XError{} = fail $ "XError not supported" ++ show x---- TODO what about other leaf types-parseLabel :: String -> Label-parseLabel s = maybe (String (Text.pack s)) Int (readMaybe s :: Maybe Int)
− src/Zip.hs
@@ -1,47 +0,0 @@--- |--- This is an internal relapse module.------ It zips patterns to reduce the state space.--module Zip (- Zipper, zippy, unzipby-) where--import qualified Data.Set as S-import Data.List (elemIndex)--import 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 emptySet s'- l = S.toAscList s''- in (l, Zipper $ map (indexOf l) ps)--indexOf :: [Pattern] -> Pattern -> ZipEntry-indexOf _ ZAny = ZipZAny-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--ofIndexb :: [Bool] -> ZipEntry -> Bool-ofIndexb _ ZipZAny = True-ofIndexb _ ZipNotZAny = False-ofIndexb bs (ZipVal i) = bs !! i
+ stack.yaml view
@@ -0,0 +1,65 @@+# This file was automatically generated by 'stack init'+#+# Some commonly used options have been documented as comments in this file.+# For advanced use and comprehensive documentation of the format, please see:+# https://docs.haskellstack.org/en/stable/yaml_configuration/++# Resolver to choose a 'specific' stackage snapshot or a compiler version.+# A snapshot resolver dictates the compiler version and the set of packages+# to be used for project dependencies. For example:+#+# resolver: lts-3.5+# resolver: nightly-2015-09-21+# resolver: ghc-7.10.2+# resolver: ghcjs-0.1.0_ghc-7.10.2+#+# The location of a snapshot can be provided as a file or url. Stack assumes+# a snapshot provided as a file might change, whereas a url resource does not.+#+# resolver: ./custom-snapshot.yaml+# resolver: https://example.com/snapshots/2018-01-01.yaml+resolver: lts-12.9++# User packages to be built.+# Various formats can be used as shown in the example below.+#+# packages:+# - some-directory+# - https://example.com/foo/bar/baz-0.0.2.tar.gz+# - location:+# git: https://github.com/commercialhaskell/stack.git+# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# - location: https://github.com/commercialhaskell/stack/commit/e7b331f14bcffb8367cd58fbfc8b40ec7642100a+# subdirs:+# - auto-update+# - wai+packages:+- .+# Dependency packages to be pulled from upstream that are not in the resolver+# using the same syntax as the packages field.+# (e.g., acme-missiles-0.3)+# extra-deps: []++# Override default flag values for local packages and extra-deps+# flags: {}++# Extra package databases containing global packages+# extra-package-dbs: []++# Control whether we use the GHC we find on the path+# system-ghc: true+#+# Require a specific version of stack, using version ranges+# require-stack-version: -any # Default+# require-stack-version: ">=1.7"+#+# Override the architecture used by stack, especially useful on Windows+# arch: i386+# arch: x86_64+#+# Extra directories used by stack for building+# extra-include-dirs: [/path/to/dir]+# extra-lib-dirs: [/path/to/dir]+#+# Allow a newer minor version of GHC than the snapshot specifies+# compiler-check: newer-minor
test/DeriveSpec.hs view
@@ -10,14 +10,16 @@ import qualified Test.Tasty.HUnit as HUnit import Data.Tree-import qualified Derive-import qualified Parser-import qualified Smart-import qualified Parsers +import qualified Data.Katydid.Parser.Parser as Parser++import qualified Data.Katydid.Relapse.Derive as Derive+import qualified Data.Katydid.Relapse.Parser as Relapse.Parser+import qualified Data.Katydid.Relapse.Smart as Smart+ import Data.List.Index (imap) -instance Parsers.Tree (Tree Parsers.Label) where+instance Parser.Tree (Tree Parser.Label) where getLabel (Node l _) = l getChildren (Node _ cs) = cs @@ -25,16 +27,16 @@ 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) []];+ input <- Relapse.Parser.parseGrammar "(== 1 | !(== 2))" >>= Smart.compile;+ want <- Relapse.Parser.parseGrammar "*" >>= Smart.compile;+ got <- Derive.derive input [Node (Parser.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) []];+ input <- Relapse.Parser.parseGrammar "{== 1 ; !(== 2)}" >>= Smart.compile;+ want <- Relapse.Parser.parseGrammar "({<empty>;!(==2)}|{==1;*})" >>= Smart.compile;+ got <- Derive.derive input [Node (Parser.Int 1) []]; return (Smart.lookupMain want, got) } ]
test/ParserSpec.hs view
@@ -11,18 +11,18 @@ import Text.ParserCombinators.Parsec (CharParser, parse, eof) -import Parser-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-import Exprs-import Ast+import Data.Katydid.Relapse.Parser+import Data.Katydid.Relapse.Expr+import Data.Katydid.Relapse.Exprs.Compare+import Data.Katydid.Relapse.Exprs.Contains+import Data.Katydid.Relapse.Exprs.Elem+import Data.Katydid.Relapse.Exprs.Length+import Data.Katydid.Relapse.Exprs.Logic+import Data.Katydid.Relapse.Exprs.Strings+import Data.Katydid.Relapse.Exprs.Type+import Data.Katydid.Relapse.Exprs.Var+import Data.Katydid.Relapse.Exprs+import Data.Katydid.Relapse.Ast import UserDefinedFuncs
test/RelapseSpec.hs view
@@ -7,11 +7,13 @@ import qualified Test.Tasty as T import qualified Test.Tasty.HUnit as HUnit -import Relapse-import Json+import qualified Data.Katydid.Parser.Json as Json++import qualified Data.Katydid.Relapse.Relapse as Relapse+import Data.Katydid.Relapse.Expr (AnyExpr)+import Data.Katydid.Relapse.Exprs (mkExpr)+ import UserDefinedFuncs-import Expr (AnyExpr)-import Exprs (mkExpr) tests = T.testGroup "Relapse" [ HUnit.testCase "parseGrammar success" $ either HUnit.assertFailure (\_ -> return ()) $
test/Suite.hs view
@@ -11,16 +11,16 @@ import System.FilePath (FilePath, (</>), takeExtension, takeBaseName, takeDirectory) import Text.XML.HXT.DOM.TypeDefs (XmlTree) -import Parsers (Tree)-import Smart (Grammar, Pattern, nullable, compile)-import qualified Ast-import Json (JsonTree, decodeJSON)-import Xml (decodeXML)-import Parser (parseGrammar)+import Data.Katydid.Parser.Parser (Tree)+import Data.Katydid.Parser.Json (JsonTree, decodeJSON)+import Data.Katydid.Parser.Xml (decodeXML) -import qualified Derive-import qualified MemDerive-import qualified VpaDerive+import Data.Katydid.Relapse.Smart (Grammar, Pattern, nullable, compile)+import qualified Data.Katydid.Relapse.Ast as Ast+import Data.Katydid.Relapse.Parser (parseGrammar)+import qualified Data.Katydid.Relapse.Derive as Derive+import qualified Data.Katydid.Relapse.MemDerive as MemDerive+import qualified Data.Katydid.Relapse.VpaDerive as VpaDerive tests :: [TestSuiteCase] -> T.TestTree tests testSuiteCases =
test/UserDefinedFuncs.hs view
@@ -9,7 +9,7 @@ import Data.Numbers.Primes (isPrime) -import Expr+import Data.Katydid.Relapse.Expr -- | -- userLib is a library of user defined functions that can be passed to the parser.