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