/
Arithmetic.hs
111 lines (93 loc) · 3.9 KB
/
Arithmetic.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
{-# LANGUAGE FlexibleContexts, FlexibleInstances, RecordWildCards, ScopedTypeVariables #-}
module Arithmetic where
import Control.Applicative
import Data.Char (isDigit)
import Data.Functor.Compose (Compose(..))
import Data.Monoid ((<>))
import Text.Parser.Token (symbol)
import Text.Grampa
import Text.Grampa.ContextFree.SortedMemoizing.LeftRecursive (Parser)
import Utilities (infixJoin)
import qualified Rank2
import Prelude hiding (negate, product, subtract, sum)
class ArithmeticDomain e where
number :: Int -> e
add :: e -> e -> e
multiply :: e -> e -> e
negate :: e -> e
subtract :: e -> e -> e
divide :: e -> e -> e
instance ArithmeticDomain Int where
number = id
add = (+)
multiply = (*)
negate = (0 -)
subtract = (-)
divide = div
instance ArithmeticDomain [Char] where
number = show
add = infixJoin "+"
multiply = infixJoin "*"
negate = ("-" <>)
subtract = infixJoin "-"
divide = infixJoin "/"
data Arithmetic e f = Arithmetic{expr :: f e,
sum :: f e,
product :: f e,
factor :: f e,
primary :: f e}
instance Show (f e) => Show (Arithmetic e f) where
showsPrec prec a rest = "Arithmetic{expr=" ++ showsPrec prec (expr a)
(", sum=" ++ showsPrec prec (sum a)
(", product=" ++ showsPrec prec (product a)
(", factor=" ++ showsPrec prec (factor a)
(", primary=" ++ showsPrec prec (primary a) ("}" ++ rest)))))
instance Rank2.Functor (Arithmetic e) where
f <$> a = a{expr= f (expr a),
sum= f (sum a),
product= f (product a),
factor= f (factor a),
primary= f (primary a)}
instance Rank2.Apply (Arithmetic e) where
a <*> a' = Arithmetic (expr a `Rank2.apply` expr a')
(sum a `Rank2.apply` sum a')
(product a `Rank2.apply` product a')
(factor a `Rank2.apply` factor a')
(primary a `Rank2.apply` primary a')
instance Rank2.Applicative (Arithmetic e) where
pure f = Arithmetic f f f f f
instance Rank2.DistributiveTraversable (Arithmetic e)
instance Rank2.Distributive (Arithmetic e) where
cotraverse w f = Arithmetic{expr= w (expr <$> f),
sum= w (sum <$> f),
product= w (product <$> f),
factor= w (factor <$> f),
primary= w (primary <$> f)}
instance Rank2.Foldable (Arithmetic e) where
foldMap f a = f (expr a) <> f (sum a) <> f (product a) <> f (factor a) <> f (primary a)
instance Rank2.Traversable (Arithmetic e) where
traverse f a = Arithmetic
<$> f (expr a)
<*> f (sum a)
<*> f (product a)
<*> f (factor a)
<*> f (primary a)
instance TokenParsing (Parser (Arithmetic e) String) where
token = lexicalToken
instance LexicalParsing (Parser (Arithmetic e) String)
arithmetic :: (LexicalParsing (Parser g String), ArithmeticDomain e) => GrammarBuilder (Arithmetic e) g Parser String
arithmetic Arithmetic{..} = Arithmetic{
expr= lexicalWhiteSpace *> sum,
sum= product
<|> symbol "-" *> (negate <$> product)
<|> add <$> sum <* symbol "+" <*> product
<|> subtract <$> sum <* symbol "-" <*> product,
product= factor
<|> multiply <$> product <* symbol "*" <*> factor
<|> divide <$> product <* symbol "/" <*> factor,
factor= primary
<|> symbol "(" *> expr <* symbol ")",
primary= lexicalToken ((number . read) <$> takeCharsWhile1 isDigit) <?> "digits"}
main :: IO ()
main = getContents >>=
print . (getCompose . expr . parseComplete (fixGrammar arithmetic) :: String -> ParseResults String [Int])