-
Notifications
You must be signed in to change notification settings - Fork 2
/
GUI.hs
130 lines (115 loc) · 4.67 KB
/
GUI.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
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NoMonomorphismRestriction #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecursiveDo #-}
module Calculator.GUI where
import Calculator.Evaluation
import Calculator.Parsing
import Calculator.Pretty
import Calculator.Printing
import Calculator.Types
import Calculator.Value
import Control.Applicative ((<$>), (<*>))
import Data.Monoid ((<>))
import Data.Text.Encoding (encodeUtf8)
import Data.Text (Text)
import Prelude hiding (div, head)
import Reflex
import Reflex.Class (fmapMaybe)
import Reflex.Dom
import Reflex.Dom.Extras
import qualified Data.Text as T
main :: IO ()
main = mainWidgetWithHead head body
head :: DomBuilder t m => m ()
head = do styleSheet "https://fonts.googleapis.com/css?family=Noto Sans"
styleSheet "https://fonts.googleapis.com/css?family=Roboto"
styleSheet "style.css"
body :: MonadWidget t m => m ()
body = do title
content
title :: DomBuilder t m => m ()
title = divClass "title" $ text "Haskell Reflex Calculator Example"
introduction :: DomBuilder t m => m ()
introduction = div $ p $ do
text "A calculator implemented in "
linkHaskell (text "Haskell" ) >> text ", "
linkGhcjs (text "GHCJS" ) >> text ", and "
linkReflex (text "Reflex" ) >> text ". ["
linkSource (text "source code") >> text "]"
where
linkHaskell = a "https://www.haskell.org/"
linkGhcjs = a "https:/ghcjs/ghcjs"
linkReflex = a "https:/reflex-frp/reflex-platform"
linkSource = a "https:/jonathanknowles/haskell-calculator"
usage :: DomBuilder t m => m ()
usage = divClass "usage" $ p $ do
divClass "heading" $ text "Usage"
text "This calculator supports:"
ul $ do li $ text "addition, subtraction, multiplication and division"
li $ text "natural numbers"
li $ text "parentheses"
content :: MonadWidget t m => m ()
content = divClass "content" $ do
introduction
expressionUpdates <- updated <$> expressionInput
maybeExpression <- foldDyn update Nothing expressionUpdates
dyn $ maybe usage evaluateExpression <$> maybeExpression
pure ()
where
update p m = case p of
ExpressionParseSuccess e -> Just e -- update with expression
ExpressionParseFailure ExpressionEmpty -> Nothing -- update with empty
ExpressionParseFailure _ -> m -- no update
expressionInput :: MonadWidget t m => m (Dynamic t ExpressionParseResult)
expressionInput = do
divClass "heading" $ text "Enter an arithmetic expression"
rec t <- div $ textInput $ def
& textInputConfig_initialValue .~ T.empty
& textInputConfig_attributes .~ attributes
let attributes = (autofocus <>) . resultClass <$> parseResult
let parseResult = parseExpression <$> _textInput_value t
divClass "feedback" $ dyn $ feedback <$> parseResult
return parseResult
where
autofocus = "autofocus" =: T.empty
resultClass = ("class" =:) . \case
ExpressionParseSuccess _ -> "valid"
ExpressionParseFailure ExpressionEmpty -> "empty"
ExpressionParseFailure _ -> "error"
feedback = text . \case
ExpressionParseSuccess _ -> hardSpace
ExpressionParseFailure ExpressionEmpty -> hardSpace
ExpressionParseFailure e -> pretty e
evaluateExpression :: MonadWidget t m => UExp -> m ()
evaluateExpression e =
divClass "result" $ do
divClass "heading" $ text "Result"
divClass "value" $ text $ pretty $ eval e
divClass "heading" $ text "Visualization"
divClass "graphic" $ renderExpression e
renderExpression :: MonadWidget t m => UExp -> m ()
renderExpression = \case
UVal a -> tableClass "val" $ tr $ text $ pretty a
UNeg a -> tableClass "neg" $ tr $ do td $ text symbolNeg
td $ renderExpression a
UAdd a b -> binop "add" symbolAdd a b
USub a b -> binop "sub" symbolSub a b
UMul a b -> binop "mul" symbolMul a b
UDiv a b -> binop "div" symbolDiv a b
where
binop c o a b =
tableClass c $ tr $ do
td $ renderExpression a
td $ text o
td $ renderExpression b
hardSpace = " "
symbolAdd = "+"
symbolSub = "−"
symbolMul = "×"
symbolDiv = "÷"
symbolBra = "("
symbolKet = ")"
symbolNeg = symbolSub