katydid 0.1.1.0 → 0.2.0.1

raw patch · 9 files changed

+248/−27 lines, 9 filesdep +criteriondep +deepseqdep +textdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: criterion, deepseq, text

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• bench/Benchmarks.hs +13/−0
• bench/Suite.hs +117/−0
• changelog.md +15/−0
• katydid.cabal +20/−2
• src/Derive.hs +16/−16
• src/ParsePatterns.hs +5/−3
• src/Parser.hs +12/−5
• src/Parsers.hs +6/−1
• test/ParserSpec.hs +44/−0

@@ -0,0 +1,13 @@+module Main where++import qualified Criterion.Main as B+import Suite (readBenches, BenchSuiteCase(..), stretch, runBench)++main :: IO ()+main = do {+    benches <- readBenches;+    benchmarks <- return $ map (\benchcase ->+        B.bench (benchname benchcase) $ B.perBatchEnv (stretch benchcase) runBench+    ) benches;+    B.defaultMain benchmarks;+}

@@ -0,0 +1,117 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}++-- |+-- Suite parses the testsuite folder and creates benchmarks+module Suite (+    readBenches, BenchSuiteCase(..), stretch, runBench+) where++import qualified Data.Text as T (unpack)+import qualified Data.Text.IO as TIO (readFile)+import System.Directory (getCurrentDirectory, listDirectory, doesDirectoryExist)+import System.FilePath (FilePath, (</>), takeExtension, takeBaseName, takeDirectory)+import Text.XML.HXT.DOM.TypeDefs (XmlTree)+import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+import Data.Int (Int64)++import Patterns (Refs, hasRecursion)+import Json (JsonTree, decodeJSON)+import Xml (decodeXML)+import Parser (parseGrammar)++import qualified Relapse++runBench :: BenchSuiteCase -> IO Int+runBench (BenchSuiteCase _ g (XMLDatas inputs)) =+    return $ length $ Relapse.filter (fromGrammar g) inputs+runBench (BenchSuiteCase _ g (JsonDatas inputs)) =+    return $ length $ Relapse.filter (fromGrammar g) inputs++readBenches :: IO [BenchSuiteCase]+readBenches = do {+    path <- benchPath;+    exists <- doesDirectoryExist path;+    if exists+    then do {+        jsondirs <- ls $ path </> "json";+        -- TODO create xml benches in testsuite+        -- xmldirs <- ls $ path </> "xml";+        -- xmlBenches <- mapM readXMLBench xmldirs;+        jsonBenches <- mapM readJsonBench jsondirs;+        return $ filter (\(BenchSuiteCase _ g _) -> not (hasRecursion $ fromGrammar g)) jsonBenches+    } else return []+}++data BenchSuiteCase = BenchSuiteCase {+    benchname        :: String+    , grammar   :: String+    , input     :: EncodedData+} deriving (Show, Generic, NFData)++data EncodedData+    = XMLDatas [[XmlTree]]+    | JsonDatas [[JsonTree]]+    deriving (Show, Generic, NFData)++stretch :: BenchSuiteCase -> Int64 -> IO BenchSuiteCase+stretch (BenchSuiteCase name g (XMLDatas xs)) n = return $ BenchSuiteCase name g $ XMLDatas $ stretch' (fromIntegral n) xs+stretch (BenchSuiteCase name g (JsonDatas xs)) n = return $ BenchSuiteCase name g $ JsonDatas $ stretch' (fromIntegral n) xs++stretch' :: Int -> [a] -> [a]+stretch' n xs+    | length xs > n = take n xs+    | otherwise = xs ++ stretch' (n - length xs) xs++must :: Either String a -> a+must e = case e of+    (Left l) -> error l+    (Right r) -> r++getRelapse :: [FilePath] -> FilePath+getRelapse paths = head $ filter (\fname -> takeExtension fname == ".txt" && takeBaseName fname == "relapse") paths++filesWithExt :: String -> [FilePath] -> [FilePath]+filesWithExt ext = filter (\fname -> takeExtension fname == ext && takeBaseName fname /= "relapse")++fromGrammar :: String -> Refs+fromGrammar s = case parseGrammar s of+    (Left err) -> error $ "given input: <" ++ s ++ "> got parse error: " ++ show err+    (Right r) -> r++readFileStrict :: FilePath -> IO String+readFileStrict = fmap T.unpack . TIO.readFile++readJsonBench :: FilePath -> IO BenchSuiteCase+readJsonBench path = do {+    files <- ls path;+    grammarData <- readFileStrict $ getRelapse files;+    jsonDatas <- mapM readFileStrict $ filesWithExt ".json" files;+    return $ BenchSuiteCase+        (takeBaseName path ++ "Json")+        grammarData+        (JsonDatas $ map (must . decodeJSON) jsonDatas)+}++readXMLBench :: FilePath -> IO BenchSuiteCase+readXMLBench path = do {+    files <- ls path;+    grammarData <- readFileStrict $ getRelapse files;+    xmlDatas <- mapM readFileStrict $ filesWithExt ".xml" files;+    return $ BenchSuiteCase+        (takeBaseName path ++ "XML")+        grammarData+        (XMLDatas $ map decodeXML xmlDatas)+}++ls :: FilePath -> IO [FilePath]+ls path = do {+    dirs <- listDirectory path;+    return $ map (path </>) dirs+}++benchPath :: IO FilePath+benchPath = do {+     path <- getCurrentDirectory;+     return $ takeDirectory path </> "testsuite" </> "relapse" </> "benches"+}

@@ -0,0 +1,15 @@+# 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

@@ -1,5 +1,5 @@ name:                katydid-version:             0.1.1.0+version:             0.2.0.1 synopsis:            A haskell implementation of Katydid description:            A haskell implementation of Katydid@@ -25,7 +25,7 @@ copyright:           Walter Schulze category:            Data build-type:          Simple-extra-source-files:  README.md+extra-source-files:  README.md, changelog.md cabal-version:       >=1.10  library@@ -51,6 +51,7 @@                      , regex-tdfa                      , mtl                      , parsec+                     , deepseq   default-language:    Haskell2010  executable katydid-exe@@ -84,6 +85,23 @@   ghc-options:         -threaded -rtsopts -with-rtsopts=-N   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+  default-language: Haskell2010+   source-repository head   type:     git   location: https://github.com/katydid/katydid-haskell

@@ -33,23 +33,23 @@ -- , 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+calls refs ps = compileIfExprs refs $ concatMap (\p -> deriveCall refs p []) 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)+deriveCall :: Refs -> Pattern -> [IfExpr]-> [IfExpr]+deriveCall _ Empty res = res+deriveCall _ ZAny res = res+deriveCall _ (Node v p) res = (newIfExpr v p (Not ZAny)) : res+deriveCall refs (Concat l r) res+    | nullable refs l = deriveCall refs l (deriveCall refs r res)+    | otherwise = deriveCall refs l res+deriveCall refs (Or l r) res = deriveCall refs l (deriveCall refs r res)+deriveCall refs (And l r) res = deriveCall refs l (deriveCall refs r res)+deriveCall refs (Interleave l r) res = deriveCall refs l (deriveCall refs r res)+deriveCall refs (ZeroOrMore p) res = deriveCall refs p res+deriveCall refs (Reference name) res = deriveCall refs (lookupRef refs name) res+deriveCall refs (Not p) res = deriveCall refs p res+deriveCall refs (Contains p) res = deriveCall refs (Concat ZAny (Concat p ZAny)) res+deriveCall refs (Optional p) res = deriveCall refs (Or p Empty) res  -- | -- returns takes a list of patterns and list of bools.

@@ -349,10 +349,12 @@ -- 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+        if name == "type" then             newFunction name [constExpr]+        else if name == "regex" then+            newFunction name [constExpr, constToVar constExpr]+        else+            newFunction name [constToVar constExpr, constExpr]     )  constToVar :: ParsedExpr -> ParsedExpr

@@ -92,7 +92,9 @@ uintCastLit = string "uint(" *> _intLit <* char ')'  _exponent :: CharParser () String-_exponent = oneOf "eE" <::> opt (oneOf "+-") <++> many1 digit+_exponent = oneOf "eE" <::> (+    oneOf "+-" <::> many1 digit +    <|> many1 digit)  _floatLit :: CharParser () Double _floatLit = do@@ -100,7 +102,7 @@     e <- _exponent          <|> ((string "." <|> empty) <++>              (_exponent -            <|> many1 digit <++> +            <|> many1 digit <++>                 (_exponent                 <|> empty)             )@@ -221,7 +223,7 @@ _function = newFunction <$> idLit <*> (char '(' *> sepBy (ws *> _expr <* ws) (char ',') <* char ')') >>= check  _listType :: CharParser () String-_listType = string "[]" <++> (+_listType = char '[' <::> char ']' <::> (     string "bool"     <|> string "int"     <|> string "uint"@@ -348,9 +350,14 @@ _depthPattern = _concatPattern <|> _interleavePattern <|> _containsPattern      <|> flip Node Empty <$> ( (string "->" *> expr ) <|> (_builtin >>= _mustBool) ) +newContains :: CharParser () ParsedExpr -> CharParser () Pattern+newContains e = flip Node Empty <$> ((newBuiltIn "*=" <$> e) >>= check >>= _mustBool)+ pattern :: CharParser () Pattern-pattern = _zanyPattern-    <|> _parenPattern+pattern = char '*' *> (+        (char '=' *> (newContains (ws *> _expr)))+        <|> return ZAny+    ) <|> _parenPattern     <|> _refPattern     <|> try _emptyPattern     <|> try _treenodePattern

@@ -1,3 +1,5 @@+{-# LANGUAGE DeriveGeneric, DeriveAnyClass #-}+ -- | -- This module describes the abstract tree that can be validated by Relapse. --@@ -7,11 +9,14 @@     Tree(..), Label(..) ) where +import Control.DeepSeq (NFData)+import GHC.Generics (Generic)+ data Label     = String String     | Number Rational     | Bool Bool-    deriving (Show, Eq, Ord)+    deriving (Show, Eq, Ord, Generic, NFData)  class Tree a where     getLabel :: a -> Label

@@ -89,6 +89,7 @@     success "expr bool var" expr "$bool" BoolVariable,     success "expr bool const" expr "true" (Const True),     success "expr ==" expr "== true" (BoolEqualFunc BoolVariable (Const True)),+    success "expr *=" expr "*= \"a\"" (StringContainsFunc StringVariable (Const "a")),     success "expr not" expr "not(true)" (NotFunc (Const True)),     success "expr eq bool" expr "eq($bool, true)" (BoolEqualFunc BoolVariable (Const True)),     success "expr eq int" expr "eq($int, 1)" (IntEqualFunc IntVariable (Const 1)),@@ -131,6 +132,49 @@     success "treenode" pattern "a:*" (Node (StringEqualFunc StringVariable (Const "a")) ZAny),     success "any treenode" pattern "_:*" (Node (Const True) ZAny),     success "treenode no colon" pattern "_[*,*]" (Node (Const True) (Concat ZAny ZAny)),++    success "treenode with contains" pattern "a:*=\"b\"" (+        Node (StringEqualFunc StringVariable (Const "a"))+            $ Node (StringContainsFunc StringVariable (Const "b")) Empty),+    success "anynode with contains" pattern "_:*=\"b\"" (+        Node (Const True)+            $ Node (StringContainsFunc StringVariable (Const "b")) Empty),+    success "contains anynode with contains" pattern "._:*=\"b\"" (+        Contains $ Node (Const True)+            $ Node (StringContainsFunc StringVariable (Const "b")) Empty),+    success "contains anynode with contains or" pattern "(._:*=\"b\"|*)" (+        Or (Contains $ Node (Const True) $ Node (StringContainsFunc StringVariable (Const "b")) Empty)+           ZAny+    ),+    -- (~=\"^([ \t\r\n\v\f])+$\")*+    success "Page195E0AddrE0NameE0" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*}" (+        Node (StringEqualFunc StringVariable (Const "Person")) (+            (Interleave+                (Interleave+                    (Node (StringEqualFunc StringVariable (Const "Name")) ZAny)+                    (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny)+                )+                (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny))+            )+        )+    ),+    success "whitespace regex" pattern "(~=\"^([ \t\r\n\v\f])+$\")*" (+        ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty+    ),+    success "Page195E0AddrE0NameE0 with whitespace" pattern "Person:{Name:*;(Addr:*)?;(Email:*)*;(~=\"^([ \t\r\n\v\f])+$\")*}" (+        Node (StringEqualFunc StringVariable (Const "Person")) (+            (Interleave+                (Interleave+                    (Interleave+                        (Node (StringEqualFunc StringVariable (Const "Name")) ZAny)+                        (Optional $ Node (StringEqualFunc StringVariable (Const "Addr")) ZAny)+                    )+                    (ZeroOrMore (Node (StringEqualFunc StringVariable (Const "Email")) ZAny))+                )+                (ZeroOrMore $ Node (RegexFunc (Const "^([ \t\r\n\v\f])+$") StringVariable) Empty)+            )+        )+    ),      success "single pattern grammar" grammar "*" $ newRef "main" ZAny,     success "single pattern decl" grammar "#main = *" $ newRef "main" ZAny,