Re: [DOMjudge-commits] Checktestdata branch master updated.
Hi Jeroen, Could you add a description or Makefile documenting how to build this? I tried to do so by installing cabal, and the required packages, but failed. I think I didn't have exactly the right versions, and even then, the Setup binary complained that none of the packages were available. Jaap On 01-01-17 10:42, DOMjudge wrote:
The branch, master has been updated from c525f8b20c1d59e54db2b6399fb5dab9475bb903 (commit) via c6bcd2e71281bf990b0ca9f6254236622d4ebc97 (commit) via d7fea2aabc5ad165ce93589d47398cc99a3f0765 (commit)
- Log ----------------------------------------------------------------- ----------------------------------------------------------------------- https://www.domjudge.org/gitweb/?p=checktestdata.git;a=commitdiff;h=c6bcd2e7 commit c6bcd2e71281bf990b0ca9f6254236622d4ebc97 Author: Jeroen Bransen <jeroen@chordify.net> Date: Sun Jan 1 13:38:25 2017 +0100
[haskell_edsl] Add regex support
diff --git a/haskell_edsl/checktestdata.cabal b/haskell_edsl/checktestdata.cabal index 42babc6..9e42a30 100644 --- a/haskell_edsl/checktestdata.cabal +++ b/haskell_edsl/checktestdata.cabal @@ -27,6 +27,7 @@ library containers >=0.5 && <0.6, either >=4.3 && <4.5, mtl >=2.2 && <2.3, + regex-tdfa >= 1.2, uu-parsinglib >= 2.9 hs-source-dirs: src default-language: Haskell2010 diff --git a/haskell_edsl/src/Checktestdata/Core.hs b/haskell_edsl/src/Checktestdata/Core.hs index e3242b3..11615dc 100644 --- a/haskell_edsl/src/Checktestdata/Core.hs +++ b/haskell_edsl/src/Checktestdata/Core.hs @@ -12,6 +12,7 @@ module Checktestdata.Core ( nextHex, nextFloat, string, + regex, eof, isEOF, ) where @@ -21,6 +22,9 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lex.Fractional as FR import qualified Data.ByteString.Lex.Integral as INT
+import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString + import Control.Monad.State import Control.Monad.Trans.Either
@@ -172,6 +176,24 @@ string s = PrimOp $ do True -> do putRemaining $ BS.drop (length s) cs
+-- | Match with the given regular expression +regex :: String -> CTD String +regex rs = PrimOp $ do + let reg = compile defaultCompOpt defaultExecOpt $ BS.pack rs + case reg of + Left e -> failWithLocation e + Right r -> do + cs <- getRemaining + let err = "Expression " ++ show rs ++ " does not match" + case regexec r cs of + Right (Just (pre,main,post,_)) -> case BS.null pre of + True -> do + putRemaining post + return $ BS.unpack main + False -> failWithLocation err + Left e -> failWithLocation e + Right _ -> failWithLocation err + -- | Check whether we are at the end of the file. isEOF :: CTD Bool isEOF = PrimOp $ do
----------------------------------------------------------------------- https://www.domjudge.org/gitweb/?p=checktestdata.git;a=commitdiff;h=d7fea2aa commit d7fea2aabc5ad165ce93589d47398cc99a3f0765 Author: Jeroen Bransen <jeroen@chordify.net> Date: Sun Jan 1 13:40:02 2017 +0100
[haskell_edsl] Almost complete backwards compatibility, passes most tests
diff --git a/haskell_edsl/src/Checktestdata/Script/AST.hs b/haskell_edsl/src/Checktestdata/Script/AST.hs index f116515..7542c24 100644 --- a/haskell_edsl/src/Checktestdata/Script/AST.hs +++ b/haskell_edsl/src/Checktestdata/Script/AST.hs @@ -1,5 +1,6 @@ module Checktestdata.Script.AST ( - Var, + VarName, + Var (..), Block, AST (..), Expr (..), @@ -8,9 +9,11 @@ module Checktestdata.Script.AST ( Test (..), CompOp (..), ) where --- data Var = Var String [Expr]
-type Var = String +type VarName = String + +data Var = Var VarName [Expr] + deriving ( Show )
type Block = [AST]
@@ -20,11 +23,12 @@ data AST = CSpace | CInt Expr Expr (Maybe Var) | CFloat Expr Expr (Maybe Var) (Maybe FloatOption) | CString Expr + | CRegex Expr (Maybe Var) | CRep (Maybe Var) Expr (Maybe AST) Block -- var, count, separator, body | CWhile (Maybe Var) Test (Maybe AST) Block | CAssert Test | CSet [(Var, Expr)] - | CUnset [Var] + | CUnset [VarName] | CIf Test Block (Maybe Block) deriving (Show)
@@ -54,8 +58,8 @@ data Test = Not Test | And Test Test | Or Test Test | Match Expr - | Unique [Var] - | InArray Expr Var + | Unique [VarName] + | InArray Expr VarName | IsEOF deriving (Show)
diff --git a/haskell_edsl/src/Checktestdata/Script/Interpreter.hs b/haskell_edsl/src/Checktestdata/Script/Interpreter.hs index c74c9a9..8013e09 100644 --- a/haskell_edsl/src/Checktestdata/Script/Interpreter.hs +++ b/haskell_edsl/src/Checktestdata/Script/Interpreter.hs @@ -8,6 +8,7 @@ import Checktestdata.Core import Checktestdata.Derived import Checktestdata.Script.AST
+import Data.List ( genericLength, transpose ) import Data.Map ( Map ) import qualified Data.Map as Map
@@ -19,26 +20,32 @@ import Control.Monad.State --------------------------------------------------------------------------------
-- todo: error handling on script parsing level --- todo: arrays
data Value = VInt Integer | VFloat Rational | VString String + deriving ( Show, Eq, Ord )
-type ValueMap = Map Var Value +type ValueMap = Map VarName (Map [Value] Value)
setValue :: Maybe Var -> Value -> InterpretMonad () setValue Nothing _ = return () -setValue (Just var) val = modify $ Map.insert var val +setValue (Just (Var var eidxs)) val = do + idxs <- mapM fExpr eidxs + modify $ Map.insertWith Map.union var $ Map.singleton idxs val
getValue :: Var -> InterpretMonad Value -getValue var = do +getValue (Var var eidxs) = do vm <- get case Map.lookup var vm of - Nothing -> error $ "Undefined variable " ++ var - Just val -> return val - -unsetVar :: Var -> InterpretMonad () + Nothing -> error $ "Undefined variable " ++ show var + Just vmi -> do + idxs <- mapM fExpr eidxs + case Map.lookup idxs vmi of + Nothing -> error $ "Undefined index " ++ show idxs + Just val -> return val + +unsetVar :: VarName -> InterpretMonad () unsetVar var = modify $ Map.delete var
toInt :: Value -> InterpretMonad Integer @@ -66,133 +73,158 @@ liftC = lift
-- | Interpret an old checktestdata script into an executable 'CTD' interpret :: Block -> CTD () -interpret = flip evalStateT Map.empty . fBlock where +interpret = flip evalStateT Map.empty . fBlock + -- Code blocks (simple fold) - fBlock :: Block -> InterpretMonad () - fBlock = mapM_ fAST - - -- AST elements - fAST :: AST -> InterpretMonad () - fAST CSpace = liftC space - fAST CNewline = liftC newline - fAST CEOF = liftC eof - fAST (CSet vs) = forM_ vs $ \(var,e) -> do - val <- fExpr e - setValue (Just var) val - fAST (CUnset vs) = mapM_ unsetVar vs - fAST (CInt low up var) = do - vlow <- fExpr low >>= toInt - vup <- fExpr up >>= toInt - val <- liftC $ int vlow vup - setValue var (VInt val) - fAST (CFloat low up var _) = do -- todo: scientific/fixed option - vlow <- fExpr low >>= toFloat - vup <- fExpr up >>= toFloat - val <- liftC $ float vlow vup - setValue var (VFloat val) - fAST (CString s) = do - str <- fExpr s >>= toString - liftC $ string str - fAST (CAssert test) = do - b <- fTest test - liftC $ assert b - fAST (CRep var count mbSep body) = do - vcount <- fExpr count >>= toInt - forM_ [0..vcount-1] $ \i -> do - -- Parse separator - case mbSep of - Just sep | i > 0 -> fAST sep - _ -> return () - - -- Set iterator - setValue var (VInt i) +fBlock :: Block -> InterpretMonad () +fBlock = mapM_ fAST + +-- AST elements +fAST :: AST -> InterpretMonad () +fAST CSpace = liftC space +fAST CNewline = liftC newline +fAST CEOF = liftC eof +fAST (CSet vs) = forM_ vs $ \(var,e) -> do + val <- fExpr e + setValue (Just var) val +fAST (CUnset vs) = mapM_ unsetVar vs +fAST (CInt low up var) = do + vlow <- fExpr low >>= toInt + vup <- fExpr up >>= toInt + val <- liftC $ int vlow vup + setValue var (VInt val) +fAST (CFloat low up var _) = do -- todo: scientific/fixed option + vlow <- fExpr low >>= toFloat + vup <- fExpr up >>= toFloat + val <- liftC $ float vlow vup + setValue var (VFloat val) +fAST (CString s) = do + str <- fExpr s >>= toString + liftC $ string str +fAST (CRegex sr var) = do + r <- fExpr sr >>= toString + val <- liftC $ regex r + setValue var (VString val) +fAST (CAssert test) = do + b <- fTest test + liftC $ assert b +fAST (CRep var count mbSep body) = do + vcount <- fExpr count >>= toInt + forM_ [0..vcount-1] $ \i -> do + -- Parse separator + case mbSep of + Just sep | i > 0 -> fAST sep + _ -> return ()
- -- Do the body - fBlock body - fAST (CWhile var test mbSep body) = do - let it :: Integer -> InterpretMonad () - it i = do - setValue var (VInt i) - b <- fTest test - when b $ do - -- Condition true, so parse separator - case mbSep of - Just sep | i > 0 -> fAST sep - _ -> return () - -- And parse body - fBlock body - -- And repeat - it $ i + 1 - it 0 - fAST (CIf test ifTrue mbIfFalse) = do - b <- fTest test - if b then fBlock ifTrue - else case mbIfFalse of - Nothing -> return () - Just bl -> fBlock bl - - -- Expression evaluation - fExpr :: Expr -> InterpretMonad Value - fExpr (EVar var) = getValue var - fExpr (ConstI v) = return $ VInt v - fExpr (ConstF v) = return $ VFloat v - fExpr (ConstS v) = return $ VString v - fExpr (Negate e) = do - val <- fExpr e - case val of - VInt v -> return $ VInt $ negate v - VFloat v -> return $ VFloat $ negate v - _ -> error "Integer of float expected" - fExpr (BinOp op e1 e2) = do - v1 <- fExpr e1 - v2 <- fExpr e2 - fBinOp op v1 v2 - - -- Binary operators - fBinOp :: BinOp -> Value -> Value -> InterpretMonad Value - fBinOp Plus v1 v2 = fNumOp (+) v1 v2 - fBinOp Minus v1 v2 = fNumOp (-) v1 v2 - fBinOp Times v1 v2 = fNumOp (*) v1 v2 - fBinOp Div v1 v2 = case (v1, v2) of - (VInt i1, VInt i2) -> return $ VInt $ i1 `div` i2 - _ -> do - f1 <- toFloat v1 - f2 <- toFloat v2 - return $ VFloat $ f1 / f2 - fBinOp Modulo v1 v2 = do - i1 <- toInt v1 - i2 <- toInt v2 - return $ VInt $ i1 `mod` i2 - fBinOp Pow v1 v2 = do - i2 <- toInt v2 - case v1 of - VInt i1 -> return $ VInt $ i1 ^ i2 - VFloat f1 -> return $ VFloat $ f1 ^^ i2 - _ -> error "Integer of float expected" - - fNumOp :: (forall a. Num a => a -> a -> a) -> Value -> Value -> InterpretMonad Value - fNumOp op v1 v2 = case (v1, v2) of - (VInt i1, VInt i2) -> return $ VInt $ i1 `op` i2 - _ -> do - f1 <- toFloat v1 - f2 <- toFloat v2 - return $ VFloat $ f1 `op` f2 - - fTest :: Test -> InterpretMonad Bool - fTest IsEOF = liftC isEOF - fTest (Not test) = liftM not (fTest test) - fTest (And t1 t2) = liftM2 (&&) (fTest t1) (fTest t2) - fTest (Or t1 t2) = liftM2 (||) (fTest t1) (fTest t2) - fTest (CompOp cmp e1 e2) = do - v1 <- fExpr e1 >>= toFloat -- note that Float here is also exact - v2 <- fExpr e2 >>= toFloat - let Just op = cmp `lookup` [ (CompGT, (>)) - , (CompGE, (>=)) - , (CompEQ, (==)) - , (CompNE, (/=)) - , (CompLT, (<)) - , (CompLE, (<=)) ] - return $ v1 `op` v2 - fTest (Match e) = do - s <- fExpr e >>= toString - liftC $ match s + -- Set iterator + setValue var (VInt i) + + -- Do the body + fBlock body +fAST (CWhile var test mbSep body) = do + let it :: Integer -> InterpretMonad () + it i = do + setValue var (VInt i) + b <- fTest test + when b $ do + -- Condition true, so parse separator + case mbSep of + Just sep | i > 0 -> fAST sep + _ -> return () + -- And parse body + fBlock body + -- And repeat + it $ i + 1 + it 0 +fAST (CIf test ifTrue mbIfFalse) = do + b <- fTest test + if b then fBlock ifTrue + else case mbIfFalse of + Nothing -> return () + Just bl -> fBlock bl + +-- Expression evaluation +fExpr :: Expr -> InterpretMonad Value +fExpr (EVar var) = getValue var +fExpr (ConstI v) = return $ VInt v +fExpr (ConstF v) = return $ VFloat v +fExpr (ConstS v) = return $ VString v +fExpr (StrLen e) = do + val <- fExpr e >>= toString + return $ VInt $ genericLength val +fExpr (Negate e) = do + val <- fExpr e + case val of + VInt v -> return $ VInt $ negate v + VFloat v -> return $ VFloat $ negate v + _ -> error "Integer of float expected" +fExpr (BinOp op e1 e2) = do + v1 <- fExpr e1 + v2 <- fExpr e2 + fBinOp op v1 v2 + +-- Binary operators +fBinOp :: BinOp -> Value -> Value -> InterpretMonad Value +fBinOp Plus v1 v2 = fNumOp (+) v1 v2 +fBinOp Minus v1 v2 = fNumOp (-) v1 v2 +fBinOp Times v1 v2 = fNumOp (*) v1 v2 +fBinOp Div v1 v2 = case (v1, v2) of + (VInt i1, VInt i2) -> return $ VInt $ i1 `div` i2 + _ -> do + f1 <- toFloat v1 + f2 <- toFloat v2 + return $ VFloat $ f1 / f2 +fBinOp Modulo v1 v2 = do + i1 <- toInt v1 + i2 <- toInt v2 + return $ VInt $ i1 `mod` i2 +fBinOp Pow v1 v2 = do + i2 <- toInt v2 + case v1 of + VInt i1 -> return $ VInt $ i1 ^ i2 + VFloat f1 -> return $ VFloat $ f1 ^^ i2 + _ -> error "Integer of float expected" + +fNumOp :: (forall a. Num a => a -> a -> a) -> Value -> Value -> InterpretMonad Value +fNumOp op v1 v2 = case (v1, v2) of + (VInt i1, VInt i2) -> return $ VInt $ i1 `op` i2 + _ -> do + f1 <- toFloat v1 + f2 <- toFloat v2 + return $ VFloat $ f1 `op` f2 + +fTest :: Test -> InterpretMonad Bool +fTest IsEOF = liftC isEOF +fTest (Not test) = liftM not (fTest test) +fTest (And t1 t2) = liftM2 (&&) (fTest t1) (fTest t2) +fTest (Or t1 t2) = liftM2 (||) (fTest t1) (fTest t2) +fTest (Unique vs) = do + vm <- get + keyvals <- forM vs $ \v -> do + let mp = Map.findWithDefault (error $ "Undefined variable " ++ v) v vm + let (keys, vals) = unzip $ Map.toList mp + return (keys, vals) + let (k:ks, vals) = unzip keyvals + let pairs = transpose vals + when (any (/=k) ks) $ liftC $ fail "Different sets of indices" + return $ unique pairs +fTest (InArray val var) = do + vm <- get + case Map.lookup var vm of + Nothing -> liftC $ fail $ "Undefined variable " ++ var + Just vals -> do + v <- fExpr val + return $ v `elem` Map.elems vals +fTest (CompOp cmp e1 e2) = do + v1 <- fExpr e1 >>= toFloat -- note that Float here is also exact + v2 <- fExpr e2 >>= toFloat + let Just op = cmp `lookup` [ (CompGT, (>)) + , (CompGE, (>=)) + , (CompEQ, (==)) + , (CompNE, (/=)) + , (CompLT, (<)) + , (CompLE, (<=)) ] + return $ v1 `op` v2 +fTest (Match e) = do + s <- fExpr e >>= toString + liftC $ match s diff --git a/haskell_edsl/src/Checktestdata/Script/Parser.hs b/haskell_edsl/src/Checktestdata/Script/Parser.hs index 125ce40..5618432 100644 --- a/haskell_edsl/src/Checktestdata/Script/Parser.hs +++ b/haskell_edsl/src/Checktestdata/Script/Parser.hs @@ -6,11 +6,6 @@ module Checktestdata.Script.Parser (
import Checktestdata.Script.AST
---import Text.ParserCombinators.Parsec ---import Text.ParserCombinators.Parsec.Language ---import Text.ParserCombinators.Parsec.Expr ---import qualified Text.ParserCombinators.Parsec.Token as Token - import Data.Char import Data.Ratio
@@ -25,12 +20,24 @@ import Text.ParserCombinators.UU.Utils parseScript :: FilePath -> IO Block parseScript fp = do contents <- readFile fp - case execParser (pSpaces *> pBlock) (dropComments contents) of - (r, []) -> return r - (r, err) -> mapM_ print err >> return r + return $ runParser fp (pSpaces *> pBlock) (dropComments contents)
+-- | Remove all comments from the text. This is less trivial than it seems +-- as # may also be inside a string literal. dropComments :: String -> String -dropComments = unlines . map (takeWhile (/='#')) . lines +dropComments = f False False where + f :: Bool -> Bool -> String -> String -- inComment, inString + f _ _ "" = "" + f True False ('\n':xs) = '\n' : f False False xs + f True False ( _:xs) = f True False xs + f False True ('\\':x:xs) = '\\' : x : f False True xs + f False True ('"' :xs) = '"' : f False False xs + f False True ( x:xs) = x : f False True xs + f False False ('"' :xs) = '"' : f False True xs + f False False ('#' :xs) = f True False xs + f False False ( x:xs) = x : f False False xs + f _ _ _ = error "dropComments: invariant failed" +
-------------------------------------------------------------------------------- -- Parsing @@ -48,19 +55,19 @@ pAST = CSpace <$ pSymbol "SPACE" <*> pExpr <* pComma <*> pExpr - <*> (Just <$ pComma <*> identifier <<|> pure Nothing) + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) <* pRParen <<|> CFloat <$ pSymbol "FLOAT" <* pLParen <*> pExpr <* pComma <*> pExpr - <*> (Just <$ pComma <*> identifier <<|> pure Nothing) + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) <*> (Just <$ pComma <*> pFloatOption <<|> pure Nothing) <* pRParen <<|> CRep <$ pSymbol "REPI" <* pLParen - <*> (Just <$> identifier <* pComma) + <*> (Just <$> pVar <* pComma) <*> pExpr <*> (Just <$ pComma <*> pAST <<|> pure Nothing) <* pRParen @@ -76,7 +83,7 @@ pAST = CSpace <$ pSymbol "SPACE" <* pSymbol "END" <<|> CWhile <$ pSymbol "WHILEI" <* pLParen - <*> (Just <$> identifier <* pComma) + <*> (Just <$> pVar <* pComma) <*> pTest <*> (Just <$ pComma <*> pAST <<|> pure Nothing) <* pRParen @@ -101,6 +108,11 @@ pAST = CSpace <$ pSymbol "SPACE" <* pLParen <*> pTest <* pRParen + <<|> CRegex <$ pSymbol "REGEX" + <* pLParen + <*> pExpr + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) + <* pRParen <<|> CString <$ pSymbol "STRING" <* pLParen <*> pExpr @@ -109,11 +121,15 @@ pAST = CSpace <$ pSymbol "SPACE" <* pLParen <*> pListSep pComma ( - (,) <$> identifier - <* pSym '=' + (,) <$> pVar + <* lexeme (pSym '=') <*> pExpr ) <* pRParen + <<|> CUnset <$ pSymbol "UNSET" + <* pLParen + <*> pListSep pComma identifier + <* pRParen
pFloatOption :: Parser FloatOption pFloatOption = Scientific <$ pSymbol "SCIENTIFIC" @@ -121,12 +137,16 @@ pFloatOption = Scientific <$ pSymbol "SCIENTIFIC"
pExpr :: Parser Expr pExpr = foldr pChainl pExprBase (map same_prio operators) where - same_prio ops = msum [ BinOp op <$ pSym c | (c, op) <- ops] + same_prio ops = msum [ BinOp op <$ lexeme (pSym c) | (c, op) <- ops] pExprBase :: Parser Expr pExprBase = pParens pExpr - <<|> Negate <$ pSym '-' + <<|> Negate <$ lexeme (pSym '-') <*> pExpr - <<|> EVar <$> identifier + <<|> StrLen <$ pSymbol "STRLEN" + <* pLParen + <*> pExpr + <* pRParen + <<|> EVar <$> pVar <<|> ConstS <$> pString <<|> lexeme pNumber
@@ -151,6 +171,7 @@ pNumber = mkNum mkNum i mbF mbE = ConstF $ (fromInteger i + fpart) * epart where fpart = case mbF of Nothing -> 0 + Just "" -> 0 Just f -> (read f) % (10 ^ length f) epart = case mbE of Nothing -> 1 @@ -158,16 +179,31 @@ pNumber = mkNum
-- | Parse a literal string pString :: Parser String -pString = lexeme $ pSym '"' *> pList pChar <* pSym '"' where - pChar :: Parser Char -- todo: \[0-7]{1,3} denotes an octal escape for a character - pChar = '\n' <$ pToken "\\n" - <<|> '\t' <$ pToken "\\t" - <<|> '\r' <$ pToken "\\r" - <<|> '\b' <$ pToken "\\b" - <<|> '"' <$ pToken "\\\"" - <<|> '\\' <$ pToken "\\\\" - <<|> pToken "\\\n" *> pSatisfy (/='"') (Insertion "x" 'x' 5) - <<|> pSatisfy (/='"') (Insertion "x" 'x' 5) +pString = lexeme $ pSym '"' *> pList pChar <* pSym '"' where + pChar :: Parser Char + pChar = pSym '\\' *> ( pOctal + <<|> '\n' <$ pSym 'n' + <<|> '\t' <$ pSym 't' + <<|> '\r' <$ pSym 'r' + <<|> '\b' <$ pSym 'b' + <<|> '\\' <$ pSym '\\' + <<|> '"' <$ pSym '"' + <<|> pSym '\n' *> pChar + <<|> pure '\\') + <<|> pSatisfy (/='"') (Insertion "x" 'x' 5) + pOctal :: Parser Char + pOctal = toOct <$> octDig + <*> (Just <$> octDig <<|> pure Nothing) + <*> (Just <$> octDig <<|> pure Nothing) + toOct :: Char -> Maybe Char -> Maybe Char -> Char + toOct d1 (Just d2) (Just d3) = chr $ 64 * toNum d1 + 8 * toNum d2 + toNum d3 + toOct d1 (Just d2) Nothing = chr $ 8 * toNum d1 + toNum d2 + toOct d1 Nothing Nothing = chr $ toNum d1 + toOct _ _ _ = error $ "toOct: invariant failed" + toNum :: Char -> Int + toNum c = ord c - ord '0' + octDig :: Parser Char + octDig = pSatisfy (\c -> '0' <= c && c <= '7') (Insertion "0" '0' 5)
-- | Parse boolean expressions pTest :: Parser Test @@ -175,7 +211,7 @@ pTest = pChainl bOps pTestBase where bOps = And <$ pSymbol "&&" <<|> Or <$ pSymbol "||" pTestBase = pParens pTest - <<|> Not <$ pSym '!' + <<|> Not <$ lexeme (pSym '!') <*> pTest <<|> IsEOF <$ pSymbol "ISEOF" <<|> Match <$ pSymbol "MATCH" @@ -203,9 +239,14 @@ pTest = pChainl bOps pTestBase where ] ]
+-- | Parse a variable (possibly with array indices) +pVar :: Parser Var +pVar = Var <$> identifier + <*> ( pLBracket *> pListSep pComma pExpr <* pRBracket <<|> pure []) + -------------------------------------------------------------------------------- -- Lexing --------------------------------------------------------------------------------
identifier :: Parser String -identifier = lexeme $ (:) <$> pLetter <*> pMunch isAlphaNum +identifier = lexeme $ (:) <$> pLower <*> pMunch (\c -> isLower c || isDigit c)
-----------------------------------------------------------------------
Summary of changes: haskell_edsl/checktestdata.cabal | 1 + haskell_edsl/src/Checktestdata/Core.hs | 22 ++ haskell_edsl/src/Checktestdata/Script/AST.hs | 16 +- .../src/Checktestdata/Script/Interpreter.hs | 304 ++++++++++++--------- haskell_edsl/src/Checktestdata/Script/Parser.hs | 101 +++++-- 5 files changed, 272 insertions(+), 172 deletions(-)
Yes, it's a proof of concept so docs are still a todo ;-) In short, install Haskell platform and then (in the haskell_edsl dir), do:
cabal install --only-dependencies cabal configure cabal build
This installs the required dependencies, and then creates an executable in dist/build/checktestdata/checktestdata. Alternatively you may just do 'cabal install' but this installs the checktestdata executable globally, which may conflict with other executables of that name in your path. Jeroen Op 1-1-2017 om 15:14 schreef Jaap Eldering:
Hi Jeroen,
Could you add a description or Makefile documenting how to build this? I tried to do so by installing cabal, and the required packages, but failed. I think I didn't have exactly the right versions, and even then, the Setup binary complained that none of the packages were available.
Jaap
On 01-01-17 10:42, DOMjudge wrote:
The branch, master has been updated from c525f8b20c1d59e54db2b6399fb5dab9475bb903 (commit) via c6bcd2e71281bf990b0ca9f6254236622d4ebc97 (commit) via d7fea2aabc5ad165ce93589d47398cc99a3f0765 (commit)
- Log ----------------------------------------------------------------- ----------------------------------------------------------------------- https://www.domjudge.org/gitweb/?p=checktestdata.git;a=commitdiff;h=c6bcd2e7 commit c6bcd2e71281bf990b0ca9f6254236622d4ebc97 Author: Jeroen Bransen <jeroen@chordify.net> Date: Sun Jan 1 13:38:25 2017 +0100
[haskell_edsl] Add regex support
diff --git a/haskell_edsl/checktestdata.cabal b/haskell_edsl/checktestdata.cabal index 42babc6..9e42a30 100644 --- a/haskell_edsl/checktestdata.cabal +++ b/haskell_edsl/checktestdata.cabal @@ -27,6 +27,7 @@ library containers >=0.5 && <0.6, either >=4.3 && <4.5, mtl >=2.2 && <2.3, + regex-tdfa >= 1.2, uu-parsinglib >= 2.9 hs-source-dirs: src default-language: Haskell2010 diff --git a/haskell_edsl/src/Checktestdata/Core.hs b/haskell_edsl/src/Checktestdata/Core.hs index e3242b3..11615dc 100644 --- a/haskell_edsl/src/Checktestdata/Core.hs +++ b/haskell_edsl/src/Checktestdata/Core.hs @@ -12,6 +12,7 @@ module Checktestdata.Core ( nextHex, nextFloat, string, + regex, eof, isEOF, ) where @@ -21,6 +22,9 @@ import qualified Data.ByteString.Char8 as BS import qualified Data.ByteString.Lex.Fractional as FR import qualified Data.ByteString.Lex.Integral as INT
+import Text.Regex.TDFA +import Text.Regex.TDFA.ByteString + import Control.Monad.State import Control.Monad.Trans.Either
@@ -172,6 +176,24 @@ string s = PrimOp $ do True -> do putRemaining $ BS.drop (length s) cs
+-- | Match with the given regular expression +regex :: String -> CTD String +regex rs = PrimOp $ do + let reg = compile defaultCompOpt defaultExecOpt $ BS.pack rs + case reg of + Left e -> failWithLocation e + Right r -> do + cs <- getRemaining + let err = "Expression " ++ show rs ++ " does not match" + case regexec r cs of + Right (Just (pre,main,post,_)) -> case BS.null pre of + True -> do + putRemaining post + return $ BS.unpack main + False -> failWithLocation err + Left e -> failWithLocation e + Right _ -> failWithLocation err + -- | Check whether we are at the end of the file. isEOF :: CTD Bool isEOF = PrimOp $ do
----------------------------------------------------------------------- https://www.domjudge.org/gitweb/?p=checktestdata.git;a=commitdiff;h=d7fea2aa commit d7fea2aabc5ad165ce93589d47398cc99a3f0765 Author: Jeroen Bransen <jeroen@chordify.net> Date: Sun Jan 1 13:40:02 2017 +0100
[haskell_edsl] Almost complete backwards compatibility, passes most tests
diff --git a/haskell_edsl/src/Checktestdata/Script/AST.hs b/haskell_edsl/src/Checktestdata/Script/AST.hs index f116515..7542c24 100644 --- a/haskell_edsl/src/Checktestdata/Script/AST.hs +++ b/haskell_edsl/src/Checktestdata/Script/AST.hs @@ -1,5 +1,6 @@ module Checktestdata.Script.AST ( - Var, + VarName, + Var (..), Block, AST (..), Expr (..), @@ -8,9 +9,11 @@ module Checktestdata.Script.AST ( Test (..), CompOp (..), ) where --- data Var = Var String [Expr]
-type Var = String +type VarName = String + +data Var = Var VarName [Expr] + deriving ( Show )
type Block = [AST]
@@ -20,11 +23,12 @@ data AST = CSpace | CInt Expr Expr (Maybe Var) | CFloat Expr Expr (Maybe Var) (Maybe FloatOption) | CString Expr + | CRegex Expr (Maybe Var) | CRep (Maybe Var) Expr (Maybe AST) Block -- var, count, separator, body | CWhile (Maybe Var) Test (Maybe AST) Block | CAssert Test | CSet [(Var, Expr)] - | CUnset [Var] + | CUnset [VarName] | CIf Test Block (Maybe Block) deriving (Show)
@@ -54,8 +58,8 @@ data Test = Not Test | And Test Test | Or Test Test | Match Expr - | Unique [Var] - | InArray Expr Var + | Unique [VarName] + | InArray Expr VarName | IsEOF deriving (Show)
diff --git a/haskell_edsl/src/Checktestdata/Script/Interpreter.hs b/haskell_edsl/src/Checktestdata/Script/Interpreter.hs index c74c9a9..8013e09 100644 --- a/haskell_edsl/src/Checktestdata/Script/Interpreter.hs +++ b/haskell_edsl/src/Checktestdata/Script/Interpreter.hs @@ -8,6 +8,7 @@ import Checktestdata.Core import Checktestdata.Derived import Checktestdata.Script.AST
+import Data.List ( genericLength, transpose ) import Data.Map ( Map ) import qualified Data.Map as Map
@@ -19,26 +20,32 @@ import Control.Monad.State --------------------------------------------------------------------------------
-- todo: error handling on script parsing level --- todo: arrays
data Value = VInt Integer | VFloat Rational | VString String + deriving ( Show, Eq, Ord )
-type ValueMap = Map Var Value +type ValueMap = Map VarName (Map [Value] Value)
setValue :: Maybe Var -> Value -> InterpretMonad () setValue Nothing _ = return () -setValue (Just var) val = modify $ Map.insert var val +setValue (Just (Var var eidxs)) val = do + idxs <- mapM fExpr eidxs + modify $ Map.insertWith Map.union var $ Map.singleton idxs val
getValue :: Var -> InterpretMonad Value -getValue var = do +getValue (Var var eidxs) = do vm <- get case Map.lookup var vm of - Nothing -> error $ "Undefined variable " ++ var - Just val -> return val - -unsetVar :: Var -> InterpretMonad () + Nothing -> error $ "Undefined variable " ++ show var + Just vmi -> do + idxs <- mapM fExpr eidxs + case Map.lookup idxs vmi of + Nothing -> error $ "Undefined index " ++ show idxs + Just val -> return val + +unsetVar :: VarName -> InterpretMonad () unsetVar var = modify $ Map.delete var
toInt :: Value -> InterpretMonad Integer @@ -66,133 +73,158 @@ liftC = lift
-- | Interpret an old checktestdata script into an executable 'CTD' interpret :: Block -> CTD () -interpret = flip evalStateT Map.empty . fBlock where +interpret = flip evalStateT Map.empty . fBlock + -- Code blocks (simple fold) - fBlock :: Block -> InterpretMonad () - fBlock = mapM_ fAST - - -- AST elements - fAST :: AST -> InterpretMonad () - fAST CSpace = liftC space - fAST CNewline = liftC newline - fAST CEOF = liftC eof - fAST (CSet vs) = forM_ vs $ \(var,e) -> do - val <- fExpr e - setValue (Just var) val - fAST (CUnset vs) = mapM_ unsetVar vs - fAST (CInt low up var) = do - vlow <- fExpr low >>= toInt - vup <- fExpr up >>= toInt - val <- liftC $ int vlow vup - setValue var (VInt val) - fAST (CFloat low up var _) = do -- todo: scientific/fixed option - vlow <- fExpr low >>= toFloat - vup <- fExpr up >>= toFloat - val <- liftC $ float vlow vup - setValue var (VFloat val) - fAST (CString s) = do - str <- fExpr s >>= toString - liftC $ string str - fAST (CAssert test) = do - b <- fTest test - liftC $ assert b - fAST (CRep var count mbSep body) = do - vcount <- fExpr count >>= toInt - forM_ [0..vcount-1] $ \i -> do - -- Parse separator - case mbSep of - Just sep | i > 0 -> fAST sep - _ -> return () - - -- Set iterator - setValue var (VInt i) +fBlock :: Block -> InterpretMonad () +fBlock = mapM_ fAST + +-- AST elements +fAST :: AST -> InterpretMonad () +fAST CSpace = liftC space +fAST CNewline = liftC newline +fAST CEOF = liftC eof +fAST (CSet vs) = forM_ vs $ \(var,e) -> do + val <- fExpr e + setValue (Just var) val +fAST (CUnset vs) = mapM_ unsetVar vs +fAST (CInt low up var) = do + vlow <- fExpr low >>= toInt + vup <- fExpr up >>= toInt + val <- liftC $ int vlow vup + setValue var (VInt val) +fAST (CFloat low up var _) = do -- todo: scientific/fixed option + vlow <- fExpr low >>= toFloat + vup <- fExpr up >>= toFloat + val <- liftC $ float vlow vup + setValue var (VFloat val) +fAST (CString s) = do + str <- fExpr s >>= toString + liftC $ string str +fAST (CRegex sr var) = do + r <- fExpr sr >>= toString + val <- liftC $ regex r + setValue var (VString val) +fAST (CAssert test) = do + b <- fTest test + liftC $ assert b +fAST (CRep var count mbSep body) = do + vcount <- fExpr count >>= toInt + forM_ [0..vcount-1] $ \i -> do + -- Parse separator + case mbSep of + Just sep | i > 0 -> fAST sep + _ -> return ()
- -- Do the body - fBlock body - fAST (CWhile var test mbSep body) = do - let it :: Integer -> InterpretMonad () - it i = do - setValue var (VInt i) - b <- fTest test - when b $ do - -- Condition true, so parse separator - case mbSep of - Just sep | i > 0 -> fAST sep - _ -> return () - -- And parse body - fBlock body - -- And repeat - it $ i + 1 - it 0 - fAST (CIf test ifTrue mbIfFalse) = do - b <- fTest test - if b then fBlock ifTrue - else case mbIfFalse of - Nothing -> return () - Just bl -> fBlock bl - - -- Expression evaluation - fExpr :: Expr -> InterpretMonad Value - fExpr (EVar var) = getValue var - fExpr (ConstI v) = return $ VInt v - fExpr (ConstF v) = return $ VFloat v - fExpr (ConstS v) = return $ VString v - fExpr (Negate e) = do - val <- fExpr e - case val of - VInt v -> return $ VInt $ negate v - VFloat v -> return $ VFloat $ negate v - _ -> error "Integer of float expected" - fExpr (BinOp op e1 e2) = do - v1 <- fExpr e1 - v2 <- fExpr e2 - fBinOp op v1 v2 - - -- Binary operators - fBinOp :: BinOp -> Value -> Value -> InterpretMonad Value - fBinOp Plus v1 v2 = fNumOp (+) v1 v2 - fBinOp Minus v1 v2 = fNumOp (-) v1 v2 - fBinOp Times v1 v2 = fNumOp (*) v1 v2 - fBinOp Div v1 v2 = case (v1, v2) of - (VInt i1, VInt i2) -> return $ VInt $ i1 `div` i2 - _ -> do - f1 <- toFloat v1 - f2 <- toFloat v2 - return $ VFloat $ f1 / f2 - fBinOp Modulo v1 v2 = do - i1 <- toInt v1 - i2 <- toInt v2 - return $ VInt $ i1 `mod` i2 - fBinOp Pow v1 v2 = do - i2 <- toInt v2 - case v1 of - VInt i1 -> return $ VInt $ i1 ^ i2 - VFloat f1 -> return $ VFloat $ f1 ^^ i2 - _ -> error "Integer of float expected" - - fNumOp :: (forall a. Num a => a -> a -> a) -> Value -> Value -> InterpretMonad Value - fNumOp op v1 v2 = case (v1, v2) of - (VInt i1, VInt i2) -> return $ VInt $ i1 `op` i2 - _ -> do - f1 <- toFloat v1 - f2 <- toFloat v2 - return $ VFloat $ f1 `op` f2 - - fTest :: Test -> InterpretMonad Bool - fTest IsEOF = liftC isEOF - fTest (Not test) = liftM not (fTest test) - fTest (And t1 t2) = liftM2 (&&) (fTest t1) (fTest t2) - fTest (Or t1 t2) = liftM2 (||) (fTest t1) (fTest t2) - fTest (CompOp cmp e1 e2) = do - v1 <- fExpr e1 >>= toFloat -- note that Float here is also exact - v2 <- fExpr e2 >>= toFloat - let Just op = cmp `lookup` [ (CompGT, (>)) - , (CompGE, (>=)) - , (CompEQ, (==)) - , (CompNE, (/=)) - , (CompLT, (<)) - , (CompLE, (<=)) ] - return $ v1 `op` v2 - fTest (Match e) = do - s <- fExpr e >>= toString - liftC $ match s + -- Set iterator + setValue var (VInt i) + + -- Do the body + fBlock body +fAST (CWhile var test mbSep body) = do + let it :: Integer -> InterpretMonad () + it i = do + setValue var (VInt i) + b <- fTest test + when b $ do + -- Condition true, so parse separator + case mbSep of + Just sep | i > 0 -> fAST sep + _ -> return () + -- And parse body + fBlock body + -- And repeat + it $ i + 1 + it 0 +fAST (CIf test ifTrue mbIfFalse) = do + b <- fTest test + if b then fBlock ifTrue + else case mbIfFalse of + Nothing -> return () + Just bl -> fBlock bl + +-- Expression evaluation +fExpr :: Expr -> InterpretMonad Value +fExpr (EVar var) = getValue var +fExpr (ConstI v) = return $ VInt v +fExpr (ConstF v) = return $ VFloat v +fExpr (ConstS v) = return $ VString v +fExpr (StrLen e) = do + val <- fExpr e >>= toString + return $ VInt $ genericLength val +fExpr (Negate e) = do + val <- fExpr e + case val of + VInt v -> return $ VInt $ negate v + VFloat v -> return $ VFloat $ negate v + _ -> error "Integer of float expected" +fExpr (BinOp op e1 e2) = do + v1 <- fExpr e1 + v2 <- fExpr e2 + fBinOp op v1 v2 + +-- Binary operators +fBinOp :: BinOp -> Value -> Value -> InterpretMonad Value +fBinOp Plus v1 v2 = fNumOp (+) v1 v2 +fBinOp Minus v1 v2 = fNumOp (-) v1 v2 +fBinOp Times v1 v2 = fNumOp (*) v1 v2 +fBinOp Div v1 v2 = case (v1, v2) of + (VInt i1, VInt i2) -> return $ VInt $ i1 `div` i2 + _ -> do + f1 <- toFloat v1 + f2 <- toFloat v2 + return $ VFloat $ f1 / f2 +fBinOp Modulo v1 v2 = do + i1 <- toInt v1 + i2 <- toInt v2 + return $ VInt $ i1 `mod` i2 +fBinOp Pow v1 v2 = do + i2 <- toInt v2 + case v1 of + VInt i1 -> return $ VInt $ i1 ^ i2 + VFloat f1 -> return $ VFloat $ f1 ^^ i2 + _ -> error "Integer of float expected" + +fNumOp :: (forall a. Num a => a -> a -> a) -> Value -> Value -> InterpretMonad Value +fNumOp op v1 v2 = case (v1, v2) of + (VInt i1, VInt i2) -> return $ VInt $ i1 `op` i2 + _ -> do + f1 <- toFloat v1 + f2 <- toFloat v2 + return $ VFloat $ f1 `op` f2 + +fTest :: Test -> InterpretMonad Bool +fTest IsEOF = liftC isEOF +fTest (Not test) = liftM not (fTest test) +fTest (And t1 t2) = liftM2 (&&) (fTest t1) (fTest t2) +fTest (Or t1 t2) = liftM2 (||) (fTest t1) (fTest t2) +fTest (Unique vs) = do + vm <- get + keyvals <- forM vs $ \v -> do + let mp = Map.findWithDefault (error $ "Undefined variable " ++ v) v vm + let (keys, vals) = unzip $ Map.toList mp + return (keys, vals) + let (k:ks, vals) = unzip keyvals + let pairs = transpose vals + when (any (/=k) ks) $ liftC $ fail "Different sets of indices" + return $ unique pairs +fTest (InArray val var) = do + vm <- get + case Map.lookup var vm of + Nothing -> liftC $ fail $ "Undefined variable " ++ var + Just vals -> do + v <- fExpr val + return $ v `elem` Map.elems vals +fTest (CompOp cmp e1 e2) = do + v1 <- fExpr e1 >>= toFloat -- note that Float here is also exact + v2 <- fExpr e2 >>= toFloat + let Just op = cmp `lookup` [ (CompGT, (>)) + , (CompGE, (>=)) + , (CompEQ, (==)) + , (CompNE, (/=)) + , (CompLT, (<)) + , (CompLE, (<=)) ] + return $ v1 `op` v2 +fTest (Match e) = do + s <- fExpr e >>= toString + liftC $ match s diff --git a/haskell_edsl/src/Checktestdata/Script/Parser.hs b/haskell_edsl/src/Checktestdata/Script/Parser.hs index 125ce40..5618432 100644 --- a/haskell_edsl/src/Checktestdata/Script/Parser.hs +++ b/haskell_edsl/src/Checktestdata/Script/Parser.hs @@ -6,11 +6,6 @@ module Checktestdata.Script.Parser (
import Checktestdata.Script.AST
---import Text.ParserCombinators.Parsec ---import Text.ParserCombinators.Parsec.Language ---import Text.ParserCombinators.Parsec.Expr ---import qualified Text.ParserCombinators.Parsec.Token as Token - import Data.Char import Data.Ratio
@@ -25,12 +20,24 @@ import Text.ParserCombinators.UU.Utils parseScript :: FilePath -> IO Block parseScript fp = do contents <- readFile fp - case execParser (pSpaces *> pBlock) (dropComments contents) of - (r, []) -> return r - (r, err) -> mapM_ print err >> return r + return $ runParser fp (pSpaces *> pBlock) (dropComments contents)
+-- | Remove all comments from the text. This is less trivial than it seems +-- as # may also be inside a string literal. dropComments :: String -> String -dropComments = unlines . map (takeWhile (/='#')) . lines +dropComments = f False False where + f :: Bool -> Bool -> String -> String -- inComment, inString + f _ _ "" = "" + f True False ('\n':xs) = '\n' : f False False xs + f True False ( _:xs) = f True False xs + f False True ('\\':x:xs) = '\\' : x : f False True xs + f False True ('"' :xs) = '"' : f False False xs + f False True ( x:xs) = x : f False True xs + f False False ('"' :xs) = '"' : f False True xs + f False False ('#' :xs) = f True False xs + f False False ( x:xs) = x : f False False xs + f _ _ _ = error "dropComments: invariant failed" +
-------------------------------------------------------------------------------- -- Parsing @@ -48,19 +55,19 @@ pAST = CSpace <$ pSymbol "SPACE" <*> pExpr <* pComma <*> pExpr - <*> (Just <$ pComma <*> identifier <<|> pure Nothing) + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) <* pRParen <<|> CFloat <$ pSymbol "FLOAT" <* pLParen <*> pExpr <* pComma <*> pExpr - <*> (Just <$ pComma <*> identifier <<|> pure Nothing) + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) <*> (Just <$ pComma <*> pFloatOption <<|> pure Nothing) <* pRParen <<|> CRep <$ pSymbol "REPI" <* pLParen - <*> (Just <$> identifier <* pComma) + <*> (Just <$> pVar <* pComma) <*> pExpr <*> (Just <$ pComma <*> pAST <<|> pure Nothing) <* pRParen @@ -76,7 +83,7 @@ pAST = CSpace <$ pSymbol "SPACE" <* pSymbol "END" <<|> CWhile <$ pSymbol "WHILEI" <* pLParen - <*> (Just <$> identifier <* pComma) + <*> (Just <$> pVar <* pComma) <*> pTest <*> (Just <$ pComma <*> pAST <<|> pure Nothing) <* pRParen @@ -101,6 +108,11 @@ pAST = CSpace <$ pSymbol "SPACE" <* pLParen <*> pTest <* pRParen + <<|> CRegex <$ pSymbol "REGEX" + <* pLParen + <*> pExpr + <*> (Just <$ pComma <*> pVar <<|> pure Nothing) + <* pRParen <<|> CString <$ pSymbol "STRING" <* pLParen <*> pExpr @@ -109,11 +121,15 @@ pAST = CSpace <$ pSymbol "SPACE" <* pLParen <*> pListSep pComma ( - (,) <$> identifier - <* pSym '=' + (,) <$> pVar + <* lexeme (pSym '=') <*> pExpr ) <* pRParen + <<|> CUnset <$ pSymbol "UNSET" + <* pLParen + <*> pListSep pComma identifier + <* pRParen
pFloatOption :: Parser FloatOption pFloatOption = Scientific <$ pSymbol "SCIENTIFIC" @@ -121,12 +137,16 @@ pFloatOption = Scientific <$ pSymbol "SCIENTIFIC"
pExpr :: Parser Expr pExpr = foldr pChainl pExprBase (map same_prio operators) where - same_prio ops = msum [ BinOp op <$ pSym c | (c, op) <- ops] + same_prio ops = msum [ BinOp op <$ lexeme (pSym c) | (c, op) <- ops] pExprBase :: Parser Expr pExprBase = pParens pExpr - <<|> Negate <$ pSym '-' + <<|> Negate <$ lexeme (pSym '-') <*> pExpr - <<|> EVar <$> identifier + <<|> StrLen <$ pSymbol "STRLEN" + <* pLParen + <*> pExpr + <* pRParen + <<|> EVar <$> pVar <<|> ConstS <$> pString <<|> lexeme pNumber
@@ -151,6 +171,7 @@ pNumber = mkNum mkNum i mbF mbE = ConstF $ (fromInteger i + fpart) * epart where fpart = case mbF of Nothing -> 0 + Just "" -> 0 Just f -> (read f) % (10 ^ length f) epart = case mbE of Nothing -> 1 @@ -158,16 +179,31 @@ pNumber = mkNum
-- | Parse a literal string pString :: Parser String -pString = lexeme $ pSym '"' *> pList pChar <* pSym '"' where - pChar :: Parser Char -- todo: \[0-7]{1,3} denotes an octal escape for a character - pChar = '\n' <$ pToken "\\n" - <<|> '\t' <$ pToken "\\t" - <<|> '\r' <$ pToken "\\r" - <<|> '\b' <$ pToken "\\b" - <<|> '"' <$ pToken "\\\"" - <<|> '\\' <$ pToken "\\\\" - <<|> pToken "\\\n" *> pSatisfy (/='"') (Insertion "x" 'x' 5) - <<|> pSatisfy (/='"') (Insertion "x" 'x' 5) +pString = lexeme $ pSym '"' *> pList pChar <* pSym '"' where + pChar :: Parser Char + pChar = pSym '\\' *> ( pOctal + <<|> '\n' <$ pSym 'n' + <<|> '\t' <$ pSym 't' + <<|> '\r' <$ pSym 'r' + <<|> '\b' <$ pSym 'b' + <<|> '\\' <$ pSym '\\' + <<|> '"' <$ pSym '"' + <<|> pSym '\n' *> pChar + <<|> pure '\\') + <<|> pSatisfy (/='"') (Insertion "x" 'x' 5) + pOctal :: Parser Char + pOctal = toOct <$> octDig + <*> (Just <$> octDig <<|> pure Nothing) + <*> (Just <$> octDig <<|> pure Nothing) + toOct :: Char -> Maybe Char -> Maybe Char -> Char + toOct d1 (Just d2) (Just d3) = chr $ 64 * toNum d1 + 8 * toNum d2 + toNum d3 + toOct d1 (Just d2) Nothing = chr $ 8 * toNum d1 + toNum d2 + toOct d1 Nothing Nothing = chr $ toNum d1 + toOct _ _ _ = error $ "toOct: invariant failed" + toNum :: Char -> Int + toNum c = ord c - ord '0' + octDig :: Parser Char + octDig = pSatisfy (\c -> '0' <= c && c <= '7') (Insertion "0" '0' 5)
-- | Parse boolean expressions pTest :: Parser Test @@ -175,7 +211,7 @@ pTest = pChainl bOps pTestBase where bOps = And <$ pSymbol "&&" <<|> Or <$ pSymbol "||" pTestBase = pParens pTest - <<|> Not <$ pSym '!' + <<|> Not <$ lexeme (pSym '!') <*> pTest <<|> IsEOF <$ pSymbol "ISEOF" <<|> Match <$ pSymbol "MATCH" @@ -203,9 +239,14 @@ pTest = pChainl bOps pTestBase where ] ]
+-- | Parse a variable (possibly with array indices) +pVar :: Parser Var +pVar = Var <$> identifier + <*> ( pLBracket *> pListSep pComma pExpr <* pRBracket <<|> pure []) + -------------------------------------------------------------------------------- -- Lexing --------------------------------------------------------------------------------
identifier :: Parser String -identifier = lexeme $ (:) <$> pLetter <*> pMunch isAlphaNum +identifier = lexeme $ (:) <$> pLower <*> pMunch (\c -> isLower c || isDigit c)
-----------------------------------------------------------------------
Summary of changes: haskell_edsl/checktestdata.cabal | 1 + haskell_edsl/src/Checktestdata/Core.hs | 22 ++ haskell_edsl/src/Checktestdata/Script/AST.hs | 16 +- .../src/Checktestdata/Script/Interpreter.hs | 304 ++++++++++++--------- haskell_edsl/src/Checktestdata/Script/Parser.hs | 101 +++++-- 5 files changed, 272 insertions(+), 172 deletions(-)
_______________________________________________ DOMjudge-devel mailing list DOMjudge-devel@domjudge.org https://www.domjudge.org/mailman/listinfo/domjudge-devel
participants (2)
-
Jaap Eldering -
Jeroen Bransen