Applicative instance for Expr

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 []