summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorRoman Smrž <roman.smrz@seznam.cz>2023-02-21 21:26:59 +0100
committerRoman Smrž <roman.smrz@seznam.cz>2023-02-21 21:26:59 +0100
commit8f4bb4eddb4dabf20a9256d406a1b9823a54879b (patch)
treefc77c594874bd641de5f11e1526e04c226831952
parentb27bbb421aa9806d1f3d6a524968a2f2df092b8e (diff)
Applicative instance for Expr
-rw-r--r--src/Parser.hs43
-rw-r--r--src/Test.hs19
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 []