@@ -1,5 +1,10 @@
1+{-# LANGUAGE DeriveFunctor #-}
2+{-# LANGUAGE InstanceSigs #-}
3+{-# LANGUAGE ScopedTypeVariables #-}
4+
15module Task
26 ( calculate,
7+ Expr(..),
38 )
49where
510
@@ -7,6 +12,179 @@ import Control.Applicative
712import Control.Monad.State.Lazy
813import Data.Char
914import Data.Maybe
15+import Test.QuickCheck
16+import Text.Read
17+import Debug.Trace
18+import Control.Monad
19+
20+type ParsingResult a = Either String (a, String)
21+
22+-- Parser :: Type -> Type
23+newtype Parser a = Parser (String -> ParsingResult a)
24+ deriving Functor
25+
26+instance Applicative Parser where
27+ pure :: a -> Parser a
28+ pure x = Parser (\q -> Right (x, q))
29+
30+ (<*>) :: Parser (a -> b) -> Parser a -> Parser b
31+ (<*>)
32+ (Parser (e :: String -> ParsingResult (a -> b)))
33+ (Parser (x :: String -> ParsingResult a)) = Parser (\s ->
34+ case e s of
35+ Left err -> Left err
36+ Right (arr, sLeft) -> case x sLeft of
37+ Left err2 -> Left err2
38+ Right (resOfTypeA, sLeft2) -> Right (arr resOfTypeA, sLeft2))
39+
40+instance Monad Parser where
41+ return :: a -> Parser a
42+ return = pure
43+
44+ (>>=) :: Parser a -> (a -> Parser b) -> Parser b
45+ (>>=) (Parser x) e = Parser (\s ->
46+ case x s of
47+ Left err -> Left err
48+ Right (a, s1) -> case e a of
49+ Parser f -> f s1
50+ )
51+
52+instance MonadFail Parser where
53+ fail :: String -> Parser a
54+ fail err = Parser . const . Left $ err
55+
56+instance Alternative Parser where
57+ empty :: Parser a
58+ empty = Parser . const . Left $ "I'm empty"
59+
60+ (Parser left) <|> (Parser right) = Parser $ \s -> case (left s, right s) of
61+ (Right res, _) -> Right res
62+ (Left _, Right res) -> Right res
63+ (Left err1, Left err2) -> Left $ "Both alternatives failed: 1) " ++ err1 ++ "\n2:" ++ err2
64+
65+anyToken :: Parser Char
66+anyToken = Parser $ \s -> case s of
67+ "" -> Left "Empty String"
68+ (hd: tl) -> Right (hd, tl)
69+
70+eos :: Parser ()
71+eos = Parser $ \s -> case s of
72+ "" -> Right ((), "")
73+ s -> Left $ "unexpected trailing content: " ++ s
74+
75+token :: Char -> Parser ()
76+-- token expected = Parser $ \s -> case s of
77+-- "" -> Left "Empty String"
78+-- (hd: tl) -> if hd == expected then Right ((), tl) else Left $
79+token expected = do
80+ actual <- anyToken
81+ when (actual /= expected) $ fail $ "expected " ++ [expected] ++ ", got " ++ [actual]
82+-- when :: Applicative f => Bool -> f () -> f ()
83+
84+tokens :: String -> Parser ()
85+tokens "" = pure ()
86+tokens (c: cs) = do
87+ token c
88+ tokens cs
89+
90+-- "x"
91+-- u <- tokensWhile (== 'a')
92+
93+tokensWhile :: (Char -> Bool) -> Parser String
94+-- tokensWhile e = (do
95+-- char <- anyToken
96+-- str <- if e char then tokensWhile e else empty
97+-- pure (char:str)) <|> (pure "")
98+-- tokensWhile e = (do
99+-- char <- anyToken
100+-- str <- if e char then tokensWhile e else empty
101+-- pure (char:str)) <|> (pure "")
102+
103+tokensWhile e = tokensWhile1 e <|> pure ""
104+
105+tokensWhile1 :: (Char -> Bool) -> Parser String
106+tokensWhile1 e = do
107+ char <- anyToken
108+ -- traceShowM char
109+ str <- if e char then tokensWhile e else empty
110+ pure (char:str)
111+
112+-- isDigit :: Char -> Bool
113+
114+-- TODO: add negative numbers
115+number:: Parser Int
116+number = do
117+ chars <- tokensWhile1 isDigit
118+ case readMaybe chars of
119+ Just res -> return res
120+ Nothing -> fail $ "unexpected invalid number: '" ++ chars ++ "'"
121+
122+data Expr
123+ = Num Int
124+ | AddExpr Expr Expr
125+ | MulExpr Expr Expr
126+ | SubExpr Expr Expr
127+ | DivExpr Expr Expr
128+ deriving Show
129+
130+half :: Gen a -> Gen a
131+half = scale (`div` 2)
132+
133+instance Arbitrary Expr where
134+ arbitrary = do
135+ size <- getSize
136+ case size of
137+ 0 -> Num <$> arbitrary
138+ otherwise ->
139+ oneof [
140+ Num <$> arbitrary,
141+ AddExpgr <$> half arbitrary <*> half arbitrary,
142+ SubExpr <$> half arbitrary <*> half arbitrary,
143+ MulExpr <$> half arbitrary <*> half arbitrary,
144+ DivExpr <$> half arbitrary <*> half arbitrary
145+ ]
146+
147+parse :: Parser Expr
148+parse = Num <$> number <|> (do
149+ token '('
150+ tokensWhile isSpace
151+ expr1 <- parse
152+ tokensWhile isSpace
153+ operator <- anyToken
154+ tokensWhile isSpace
155+ expr2 <- parse
156+ tokensWhile isSpace
157+ token ')'
158+ case operator of
159+ '+' -> return $ AddExpr expr1 expr2
160+ '*' -> return $ MulExpr expr1 expr2
161+ '-' -> return $ SubExpr expr1 expr2
162+ '/' -> return $ DivExpr expr1 expr2
163+ _ -> fail "unknown operator"
164+ )
165+
166+parseFull :: Parser Expr
167+parseFull = do
168+ e <- parse
169+ eos
170+ return e
171+
172+evaluate :: Expr -> Maybe Int
173+evaluate (Num x) = Just x
174+evaluate (AddExpr left right) = (+) <$> (evaluate left) <*> (evaluate right)
175+evaluate (MulExpr left right) = (*) <$> (evaluate left) <*> (evaluate right)
176+evaluate (SubExpr left right) = (-) <$> (evaluate left) <*> (evaluate right)
177+evaluate (DivExpr _ right) | evaluate right == Just 0 = Nothing
178+evaluate (DivExpr left right) = div <$> (evaluate left) <*> (evaluate right)
179+
180+
181+runParser :: Parser x -> String -> Maybe x
182+runParser (Parser parser_fun) context =
183+ case parser_fun context of
184+ Left msg -> trace msg Nothing
185+ Right (x, _) -> Just x
10186
11187calculate :: String -> Maybe Int
12−calculate = error "TODO: calculate"
188+calculate s = do
189+ expression <- runParser parseFull s
190+ evaluate expression