{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}
module Main where
import Control.Lens
import Data.Aeson
import Data.FileEmbed
import Data.List as L
import Data.List.Split as L
import Data.Text
import Data.Text.Encoding
import GHC.Generics (Generic)
import Shpadoinkle
import Shpadoinkle.Backend.ParDiff
import Shpadoinkle.Console
import Shpadoinkle.Html as H
default (ClassList)
data Digit
= Seven | Eight | Nine
| Four | Five | Six
| One | Two | Three
| Zero deriving (Eq, Show, Ord, Enum, Bounded, Generic, ToJSON)
data Operator = Addition | Multiplication | Subtraction | Division
deriving (Eq, Enum, Bounded, Generic, ToJSON)
instance Show Operator where
show = \case
Addition -> "+"
Subtraction -> "−"
Multiplication -> "×"
Division -> "÷"
data Entry
= Whole [Digit]
| [Digit] :<.> [Digit]
| Negate Entry
deriving (Eq, Generic, ToJSON)
noEntry :: Entry
noEntry = Whole []
instance Show Entry where
show = let asChar = traverse . re charDigit in \case
Whole xs -> xs ^.. asChar
xs :<.> ys -> xs ^.. asChar <> "." <> ys ^.. asChar
Negate e -> '-' : show e
frac :: Iso' Entry Double
frac = iso toFrac fromFrac where
toFrac =
let f x = case L.reverse x of
"" -> "0"
'.':xs -> L.reverse xs
_ -> x
in read . f . show
fromFrac d =
let asChar = traverse . charDigit
ab xs = case L.splitOn "." xs of
[whole, []] -> Whole $ whole ^.. asChar
[whole, dec] -> (whole ^.. asChar)
:<.> (dec ^.. asChar)
_ -> noEntry
in case show d of
'-':xs -> Negate $ ab xs
xs -> ab xs
charDigit :: Prism' Char Digit
charDigit = prism'
(\case Seven -> '7'; Eight -> '8'; Nine -> '9'
Four -> '4'; Five -> '5'; Six -> '6'
One -> '1'; Two -> '2'; Three -> '3'
Zero -> '0')
(\case '7' -> Just Seven; '8' -> Just Eight; '9' -> Just Nine
'4' -> Just Four; '5' -> Just Five; '6' -> Just Six
'1' -> Just One; '2' -> Just Two; '3' -> Just Three
'0' -> Just Zero; _ -> Nothing)
data Operation = Operation
{ _operator :: Operator
, _previous :: Entry
} deriving (Eq, Show, Generic, ToJSON)
makeFieldsNoPrefix ''Operation
data Model = Model
{ _current :: Entry
, _operation :: Maybe Operation
} deriving (Eq, Show, Generic, ToJSON)
makeFieldsNoPrefix ''Model
initial :: Model
initial = Model noEntry Nothing
digit :: Model -> Digit -> Html m Model
digit m d = button [ onClick $ m & current %~ applyDigit d, class' $ "d" <> d' ] [ text d' ]
where d' = d ^. re charDigit . to (pack . pure)
operate :: Maybe Operator -> Operator -> Html m Operator
operate active o = button
[ onClick o, class' ("active" :: Text, Just o == active) ]
[ text . pack $ show o ]
applyDigit :: Digit -> Entry -> Entry
applyDigit d = \case
Whole xs -> Whole $ xs <> [d]
xs :<.> ys -> xs :<.> (ys <> [d])
Negate e -> Negate $ applyDigit d e
addDecimal :: Entry -> Entry
addDecimal = \case
Whole xs -> xs :<.> []
ys -> ys
cleanEntry :: Entry -> Entry
cleanEntry = \case
xs :<.> [] -> Whole xs
xs :<.> [Zero] -> Whole xs
x -> x
calcResult :: Model -> Model
calcResult x = x
& operation .~ Nothing
& current .~ case x ^. operation of
Nothing -> x ^. current
Just o -> let l = o ^. previous . frac; r = x ^. current . frac
in cleanEntry . (^. from frac) $ case o ^. operator of
Addition -> l + r
Subtraction -> l - r
Multiplication -> l * r
Division -> if r == 0 then l else l / r
neg :: Entry -> Entry
neg = \case
Negate e -> e
e -> Negate e
readout :: Model -> Html m a
readout x = H.div "readout" $
[ text . pack . show $ x ^. current
] <> case x ^? operation . traverse . operator of
Nothing -> []
Just o -> [ H.div "operator"
[ text $ pack (show o) <> " " <>
x ^. operation . traverse . previous . to (pack .show)
]
]
clear :: Html m Model
clear = button [ class' "clear", onClick initial ] [ "AC" ]
posNeg :: Model -> Html m Model
posNeg x = button [ class' "posNeg", onClick (x & current %~ neg) ] [ "-/+" ]
numberpad :: Model -> Html m Model
numberpad m = H.div "numberpad" . L.intercalate [ br'_ ] . L.chunksOf 3 $
digit m <$> [minBound .. pred maxBound]
operations :: Functor m => Model -> Html m Model
operations x = H.div "operate" $ (\o' -> liftC (\o _ -> x
& operation .~ Just (Operation o (x ^. current))
& current .~ noEntry) (const o')
$ operate (x ^? operation . traverse . operator) o') <$> ([minBound .. maxBound] :: [Operator])
dot :: Model -> Html m Model
dot x = button [ onClick $ x & current %~ addDecimal ] [ "." ]
equals :: Model -> Html m Model
equals x = button [ class' "equals", onClick $ calcResult x ] [ "=" ]
view :: Monad m => Model -> Html m Model
view m = H.div "calculator"
[ readout m
, H.div "buttons"
[ clear, posNeg m, operations m
, numberpad m
, H.div "zerodot"
[ digit m Zero
, dot m
, equals m
]
]
]
main :: IO ()
main = runJSorWarp 8080 $ do
setTitle "Calculator"
ctx <- askJSM
addInlineStyle $ decodeUtf8 $(embedFile "./CalculatorIE.css")
Shpadoinkle.simple runParDiff initial (Main.view . trapper @ToJSON ctx) getBody