diff options
| -rw-r--r-- | src/Parser.hs | 43 | ||||
| -rw-r--r-- | src/Test.hs | 19 |
2 files changed, 32 insertions, 30 deletions
diff --git a/src/Parser.hs b/src/Parser.hs index 0bc5995..f80e805 100644 --- a/src/Parser.hs +++ b/src/Parser.hs @@ -6,6 +6,7 @@ module Parser ( parseTestFile, ) where +import Control.Applicative (liftA2) import Control.Monad.Combinators.Expr import Control.Monad.Identity import Control.Monad.State @@ -153,10 +154,10 @@ numberLiteral :: TestParser SomeExpr numberLiteral = label "number" $ lexeme $ do x <- L.scientific choice - [ return (SomeExpr $ Literal (x / 100)) <* void (char ('%')) + [ return (SomeExpr $ Pure (x / 100)) <* void (char ('%')) , if base10Exponent x == 0 - then return $ SomeExpr $ Literal (coefficient x) - else return $ SomeExpr $ Literal x + then return $ SomeExpr $ Pure (coefficient x) + else return $ SomeExpr $ Pure x ] quotedString :: TestParser (Expr Text) @@ -164,7 +165,7 @@ quotedString = label "string" $ lexeme $ do void $ char '"' let inner = choice [ char '"' >> return [] - , takeWhile1P Nothing (`notElem` ['\"', '\\', '$']) >>= \s -> (Literal (TL.toStrict s):) <$> inner + , takeWhile1P Nothing (`notElem` ['\"', '\\', '$']) >>= \s -> (Pure (TL.toStrict s):) <$> inner ,do void $ char '\\' c <- choice [ char '\\' >> return '\\' @@ -174,11 +175,11 @@ quotedString = label "string" $ lexeme $ do , char 'r' >> return '\r' , char 't' >> return '\t' ] - (Literal (T.singleton c) :) <$> inner + (Pure (T.singleton c) :) <$> inner ,do e <- stringExpansion (T.pack "string") $ \e -> [ cast e - , UnOp (T.pack . show @Integer) <$> cast e - , UnOp (T.pack . show @Scientific) <$> cast e + , fmap (T.pack . show @Integer) <$> cast e + , fmap (T.pack . show @Scientific) <$> cast e ] (e:) <$> inner ] @@ -189,18 +190,18 @@ regex = label "regular expression" $ lexeme $ do void $ char '/' let inner = choice [ char '/' >> return [] - , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Literal (RegexPart (TL.toStrict s)) :) <$> inner + , takeWhile1P Nothing (`notElem` ['/', '\\', '$']) >>= \s -> (Pure (RegexPart (TL.toStrict s)) :) <$> inner ,do void $ char '\\' s <- choice - [ char '/' >> return (Literal $ RegexPart $ T.singleton '/') - , anySingle >>= \c -> return (Literal $ RegexPart $ T.pack ['\\', c]) + [ char '/' >> return (Pure $ RegexPart $ T.singleton '/') + , anySingle >>= \c -> return (Pure $ RegexPart $ T.pack ['\\', c]) ] (s:) <$> inner ,do e <- stringExpansion (T.pack "regex") $ \e -> [ cast e - , UnOp RegexString <$> cast e - , UnOp (RegexString . T.pack . show @Integer) <$> cast e - , UnOp (RegexString . T.pack . show @Scientific) <$> cast e + , fmap RegexString <$> cast e + , fmap (RegexString . T.pack . show @Integer) <$> cast e + , fmap (RegexString . T.pack . show @Scientific) <$> cast e ] (e:) <$> inner ] @@ -217,14 +218,14 @@ list = label "list" $ do "list range enumeration not defined for '" <> textExprType x <> "'" choice [do symbol "]" - return $ SomeExpr $ UnOp (:[]) x + return $ SomeExpr $ fmap (:[]) x ,do off <- stateOffset <$> getParserState osymbol ".." ExprEnumerator fromTo _ <- maybe (enumErr off) return $ exprEnumerator x y <- typedExpr symbol "]" - return $ SomeExpr $ UnOp fromTo x `App` y + return $ SomeExpr $ fromTo <$> x <*> y ,do symbol "," y <- typedExpr @@ -235,12 +236,12 @@ list = label "list" $ do ExprEnumerator _ fromThenTo <- maybe (enumErr off) return $ exprEnumerator x z <- typedExpr symbol "]" - return $ SomeExpr $ UnOp fromThenTo x `App` y `App` z + return $ SomeExpr $ fromThenTo <$> x <*> y <*> z ,do symbol "," xs <- listOf typedExpr symbol "]" - return $ SomeExpr $ foldr (BinOp (:)) (Literal []) (x:y:xs) + return $ SomeExpr $ foldr (liftA2 (:)) (Pure []) (x:y:xs) ] ] @@ -253,7 +254,7 @@ applyUnOp :: forall a b sa. (a -> b) -> Expr sa -> Maybe (Expr b) applyUnOp op x = do Refl :: a :~: sa <- eqT - return $ UnOp op x + return $ op <$> x data SomeBinOp = forall a b c. (ExprType a, ExprType b, ExprType c) => SomeBinOp (a -> b -> c) @@ -263,7 +264,7 @@ applyBinOp :: forall a b c sa sb. applyBinOp op x y = do Refl :: a :~: sa <- eqT Refl :: b :~: sb <- eqT - return $ BinOp op x y + return $ op <$> x <*> y someExpr :: TestParser SomeExpr someExpr = join inner <?> "expression" @@ -369,7 +370,7 @@ someExpr = join inner <?> "expression" maybe err return $ applyRecordSelector e <$> lookup m recordMembers applyRecordSelector :: ExprType a => Expr a -> RecordSelector a -> SomeExpr - applyRecordSelector e (RecordSelector f) = SomeExpr $ UnOp f e + applyRecordSelector e (RecordSelector f) = SomeExpr $ f <$> e literal = label "literal" $ choice [ return <$> numberLiteral @@ -441,7 +442,7 @@ forStatement = do let tname = TypedVarName name addVarName voff tname body <- testBlock indent - return [For line tname (UnOp unpack e) body] + return [For line tname (unpack <$> e) body] class (Typeable a, Typeable (ParamRep a)) => ParamType a where type ParamRep a :: Type diff --git a/src/Test.hs b/src/Test.hs index 2acd7eb..6077b92 100644 --- a/src/Test.hs +++ b/src/Test.hs @@ -132,17 +132,22 @@ data ExprEnumerator a = ExprEnumerator (a -> a -> [a]) (a -> a -> a -> [a]) data Expr a where Variable :: ExprType a => VarName -> Expr a - Literal :: ExprType a => a -> Expr a + Pure :: a -> Expr a App :: Expr (a -> b) -> Expr a -> Expr b Concat :: [Expr Text] -> Expr Text Regex :: [Expr Regex] -> Expr Regex - UnOp :: (b -> a) -> Expr b -> Expr a - BinOp :: (b -> c -> a) -> Expr b -> Expr c -> Expr a RootNetwork :: Expr Network +instance Functor Expr where + fmap f x = Pure f `App` x + +instance Applicative Expr where + pure = Pure + (<*>) = App + eval :: MonadEval m => Expr a -> m a eval (Variable name) = fromSomeVarValue name =<< lookupVar name -eval (Literal value) = return value +eval (Pure value) = return value eval (App f x) = eval f <*> eval x eval (Concat xs) = T.concat <$> mapM eval xs eval (Regex xs) = mapM eval xs >>= \case @@ -150,8 +155,6 @@ eval (Regex xs) = mapM eval xs >>= \case parts -> case regexCompile $ T.concat $ map regexSource parts of Left err -> fail err Right re -> return re -eval (UnOp f x) = f <$> eval x -eval (BinOp f x y) = f <$> eval x <*> eval y eval (RootNetwork) = rootNetwork gatherVars :: forall a m. MonadEval m => Expr a -> m [(VarName, SomeVarValue)] @@ -159,12 +162,10 @@ gatherVars = fmap (uniqOn fst . sortOn fst) . helper where helper :: forall b. Expr b -> m [(VarName, SomeVarValue)] helper (Variable var) = (:[]) . (var,) <$> lookupVar var - helper (Literal _) = return [] + helper (Pure _) = return [] helper (App f x) = (++) <$> helper f <*> helper x helper (Concat es) = concat <$> mapM helper es helper (Regex es) = concat <$> mapM helper es - helper (UnOp _ e) = helper e - helper (BinOp _ e f) = (++) <$> helper e <*> helper f helper (RootNetwork) = return [] |