Skip to content

Commit 74fccf3

Browse files
reximrexim
authored
Merge pull request #800 from tsoding/599
(#599) Implement Expr parser
2 parents 74e8d77 + 8f49da0 commit 74fccf3

File tree

6 files changed

+185
-13
lines changed

6 files changed

+185
-13
lines changed

‎HyperNerd.cabal‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -243,6 +243,8 @@ test-suite HyperNerdTest
243243
, Data.Bool.Extra
244244
, Data.Either.Extra
245245
, Free
246+
, Bot.Expr
247+
, Bot.ExprTest
246248

247249
other-extensions: OverloadedStrings
248250

‎src/Bot.hs‎

Lines changed: 2 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -564,7 +564,8 @@ shuffle :: RandomGen gen => ([a], gen) -> ([a], gen)
564564
shuffle t = fromMaybe t $ headMay $ drop 100 $ iterate swapDeck t
565565

566566
replaceAt :: Int -> T.Text -> T.Text -> T.Text
567-
replaceAt i rep input = T.concat [left, rep, T.tail right]
567+
replaceAt i rep input =
568+
maybe input (T.append (T.append left rep) . snd) (T.uncons right)
568569
where
569570
(left, right) = T.splitAt i input
570571

‎src/Bot/Expr.hs‎

Lines changed: 109 additions & 8 deletions
Original file line numberDiff line numberDiff line change
@@ -1,9 +1,12 @@
1-
module Bot.Expr
2-
( parseExprs
3-
, interpretExprs
4-
) where
1+
{-# LANGUAGE DeriveFunctor #-}
2+
{-# LANGUAGE OverloadedStrings #-}
53

4+
module Bot.Expr where
5+
6+
import Control.Applicative
7+
import Data.Char
68
import qualified Data.Text as T
9+
import Data.Tuple
710
import Effect
811

912
data Expr
@@ -13,10 +16,108 @@ data Expr
1316
| VarExpr T.Text
1417
deriving (Eq, Show)
1518

16-
-- TODO(#599): parseExprs is not implemented
17-
parseExprs :: T.Text -> Either String [Expr]
18-
parseExprs = undefined
19+
type NameTable = ()
20+
21+
data ParserStop
22+
= EOF
23+
| SyntaxError T.Text
24+
deriving (Eq, Show)
25+
26+
newtype Parser a = Parser
27+
{ runParser :: T.Text -> Either ParserStop (T.Text, a)
28+
} deriving (Functor)
29+
30+
instance Applicative Parser where
31+
pure x = Parser $ \text -> Right (text, x)
32+
(Parser f) <*> (Parser x) =
33+
Parser $ \input1 -> do
34+
(input2, f') <- f input1
35+
(input3, x') <- x input2
36+
return (input3, f' x')
37+
38+
instance Monad Parser where
39+
Parser a >>= f =
40+
Parser $ \input1 -> do
41+
(input2, b) <- a input1
42+
runParser (f b) input2
43+
44+
instance Alternative Parser where
45+
empty = Parser $ const $ Left EOF
46+
(Parser p1) <|> (Parser p2) =
47+
Parser $ \input ->
48+
case (p1 input, p2 input) of
49+
(Left _, x) -> x
50+
(x, _) -> x
51+
52+
symbol :: Parser T.Text
53+
symbol = notNull "Symbol name cannot be empty" $ takeWhileP isAlphaNum
54+
55+
stringLiteral :: Parser Expr
56+
stringLiteral = do
57+
_ <- charP '"'
58+
value <- takeWhileP (/= '"')
59+
_ <- charP '"'
60+
return $ TextExpr value
61+
62+
sepBy :: Parser a -> Parser b -> Parser [a]
63+
sepBy element sep = do
64+
arg <- element
65+
args <- many (sep >> element)
66+
return (arg : args)
67+
68+
funcall :: Parser Expr
69+
funcall = do
70+
_ <- charP '%' >> whitespaces
71+
name <- symbol
72+
_ <- whitespaces >> charP '(' >> whitespaces
73+
args <-
74+
sepBy (funcall <|> var <|> stringLiteral) (whitespaces >> charP ',') <|>
75+
return []
76+
_ <- whitespaces >> charP ')'
77+
return $ FunCallExpr name args
78+
79+
charP :: Char -> Parser Char
80+
charP a =
81+
Parser $ \input ->
82+
case T.uncons input of
83+
Just (b, rest)
84+
| a == b -> Right (rest, b)
85+
_ -> Left $ SyntaxError ("Expected `" <> T.pack [a] <> "`")
86+
87+
takeWhileP :: (Char -> Bool) -> Parser T.Text
88+
takeWhileP p = Parser $ \input -> return $ swap $ T.span p input
89+
90+
syntaxError :: T.Text -> Parser a
91+
syntaxError message = Parser $ \_ -> Left $ SyntaxError message
92+
93+
notNull :: T.Text -> Parser T.Text -> Parser T.Text
94+
notNull message next =
95+
next >>=
96+
(\value ->
97+
if T.null value
98+
then syntaxError message
99+
else return value)
100+
101+
whitespaces :: Parser T.Text
102+
whitespaces = takeWhileP isSpace
103+
104+
var :: Parser Expr
105+
var = charP '%' >> whitespaces >> (VarExpr <$> symbol)
106+
107+
textBlock :: Parser Expr
108+
textBlock =
109+
Parser $ \input ->
110+
case T.uncons input of
111+
Nothing -> Left EOF
112+
Just ('%', _) -> Left (SyntaxError "Text block does not start with %")
113+
_ -> return $ fmap TextExpr $ swap $ T.span (/= '%') input
114+
115+
expr :: Parser Expr
116+
expr = funcall <|> var <|> textBlock
117+
118+
exprs :: Parser [Expr]
119+
exprs = many expr
19120

20121
-- TODO(#600): interpretExprs is not implemented
21-
interpretExprs :: [Expr] -> Effect T.Text
122+
interpretExprs :: NameTable -> [Expr] -> Effect T.Text
22123
interpretExprs = undefined

‎src/MarkovMain.hs‎

Lines changed: 9 additions & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -13,14 +13,20 @@ import System.Environment
1313
import Text.InterpolatedString.QM
1414

1515
asteriskCorrectionFilter :: [T.Text] -> [T.Text]
16-
asteriskCorrectionFilter = filter ((/= '*') . T.last)
16+
asteriskCorrectionFilter = filter $ lastIsNot '*'
17+
18+
firstIsNot :: Char -> T.Text -> Bool
19+
firstIsNot x = maybe False ((/= x) . fst) . T.uncons
20+
21+
lastIsNot :: Char -> T.Text -> Bool
22+
lastIsNot x s = T.findIndex (== x) s /= Just (T.length s - 1)
1723

1824
mentionsFilter :: [T.Text] -> [T.Text]
1925
mentionsFilter =
20-
filter (not . T.null) . map (T.unwords . filter ((/= '@') . T.head) . T.words)
26+
filter (not . T.null) . map (T.unwords . filter (firstIsNot '@') . T.words)
2127

2228
commandsFilter :: [T.Text] -> [T.Text]
23-
commandsFilter = filter ((/= '!') . T.head)
29+
commandsFilter = filter (firstIsNot '!')
2430

2531
trainTextMain :: [String] -> IO ()
2632
trainTextMain (textPath:output:_) = file2Markov textPath >>= saveMarkov output

‎test/Bot/ExprTest.hs‎

Lines changed: 60 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,60 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
3+
module Bot.ExprTest where
4+
5+
import Bot.Expr
6+
import Test.HUnit
7+
8+
-- TODO(#801): Let's fuzz Bot.Expr.exprs to make sure that it has expected behaviour
9+
exprsTest :: Test
10+
exprsTest =
11+
TestLabel "Expression parsing" $
12+
TestList $
13+
map
14+
(\(input, expected) ->
15+
TestCase $ assertEqual "" expected $ runParser exprs input)
16+
[ ("", Right ("", []))
17+
, ("hello world", Right ("", [TextExpr "hello world"]))
18+
, ("%x", Right ("", [VarExpr "x"]))
19+
, ( "%x% y % z"
20+
, Right ("", [VarExpr "x", VarExpr "y", TextExpr " ", VarExpr "z"]))
21+
, ( "%x% y hello % z"
22+
, Right ("", [VarExpr "x", VarExpr "y", TextExpr " hello ", VarExpr "z"]))
23+
, ("%f()", Right ("", [FunCallExpr "f" []]))
24+
, ( "%f()% g() % k ()"
25+
, Right
26+
( ""
27+
, [ FunCallExpr "f" []
28+
, FunCallExpr "g" []
29+
, TextExpr " "
30+
, FunCallExpr "k" []
31+
]))
32+
, ( "%f()% g() %x % k ()"
33+
, Right
34+
( ""
35+
, [ FunCallExpr "f" []
36+
, FunCallExpr "g" []
37+
, TextExpr " "
38+
, VarExpr "x"
39+
, TextExpr " "
40+
, FunCallExpr "k" []
41+
]))
42+
, ( "test %f()% g() foo %x bar % k baz ()"
43+
, Right
44+
( ""
45+
, [ TextExpr "test "
46+
, FunCallExpr "f" []
47+
, FunCallExpr "g" []
48+
, TextExpr " foo "
49+
, VarExpr "x"
50+
, TextExpr " bar "
51+
, VarExpr "k"
52+
, TextExpr " baz ()"
53+
]))
54+
, ("%f(%x)", Right ("", [FunCallExpr "f" [VarExpr "x"]]))
55+
, ( "\"hello %x world\""
56+
, Right ("", [TextExpr "\"hello ", VarExpr "x", TextExpr " world\""]))
57+
]
58+
59+
spec :: Test
60+
spec = TestList [exprsTest]

‎test/Test.hs‎

Lines changed: 3 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -9,6 +9,7 @@ module Main where
99
3. All of the `spec`-s from all of the `*Test` modules are accumulated in
1010
the `main` function and fed into `runTestTT`.
1111
-}
12+
import qualified Bot.ExprTest
1213
import qualified Bot.FridayTest
1314
import qualified Bot.LinksTest
1415
import qualified Bot.LogTest
@@ -25,7 +26,8 @@ main = do
2526
results <-
2627
runTestTT $
2728
TestList
28-
[ Bot.LinksTest.spec
29+
[ Bot.ExprTest.spec
30+
, Bot.LinksTest.spec
2931
, Bot.LogTest.spec
3032
, Bot.PollTest.spec
3133
, Bot.TwitchTest.spec

0 commit comments

Comments
 (0)