summaryrefslogtreecommitdiff
path: root/src/Parser.hs
diff options
context:
space:
mode:
Diffstat (limited to 'src/Parser.hs')
-rw-r--r--src/Parser.hs43
1 files changed, 22 insertions, 21 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