117 lines
2.9 KiB
Haskell
117 lines
2.9 KiB
Haskell
|
{-# LANGUAGE BlockArguments #-}
|
||
|
|
{-# LANGUAGE ExplicitForAll #-}
|
||
|
|
{-# LANGUAGE FlexibleInstances #-}
|
||
|
|
{-# LANGUAGE GADTs #-}
|
||
|
|
{-# LANGUAGE OverloadedStrings #-}
|
||
|
|
{-# LANGUAGE StandaloneDeriving #-}
|
||
|
|
|
||
|
|
module Main where
|
||
|
|
|
||
|
|
import qualified Control.Monad.Combinators.Expr as E
|
||
|
|
import qualified Text.Megaparsec as M
|
||
|
|
import qualified Text.Megaparsec.Char as MC
|
||
|
|
import qualified Text.Megaparsec.Char.Lexer as ML
|
||
|
|
|
||
|
|
import Control.Applicative ((<|>))
|
||
|
|
import Data.Char (isDigit)
|
||
|
|
import Data.Foldable (foldl')
|
||
|
|
import Data.Functor (($>))
|
||
|
|
import Data.Text (Text)
|
||
|
|
import Data.Void (Void)
|
||
|
|
import Numeric (readDec)
|
||
|
|
import System.Environment (getArgs)
|
||
|
|
|
||
|
|
-- ========================================
|
||
|
|
-- GADT
|
||
|
|
-- ========================================
|
||
|
|
|
||
|
|
data Expr a where
|
||
|
|
EInt :: Integer -> Expr Integer
|
||
|
|
EBool :: Bool -> Expr Bool
|
||
|
|
EAdd :: Expr Integer -> Expr Integer -> Expr Integer
|
||
|
|
ESub :: Expr Integer -> Expr Integer -> Expr Integer
|
||
|
|
EAnd :: Expr Bool -> Expr Bool -> Expr Bool
|
||
|
|
EOr :: Expr Bool -> Expr Bool -> Expr Bool
|
||
|
|
|
||
|
|
deriving instance Show (Expr Integer)
|
||
|
|
deriving instance Show (Expr Bool)
|
||
|
|
|
||
|
|
eval :: forall a. Expr a -> Either Bool Integer
|
||
|
|
eval (EInt e) = Right e
|
||
|
|
eval (EBool e) = Left e
|
||
|
|
eval (EAdd lhs rhs) =
|
||
|
|
let Right r1 = eval lhs
|
||
|
|
Right r2 = eval rhs
|
||
|
|
in Right (r1 + r2)
|
||
|
|
eval (ESub lhs rhs) =
|
||
|
|
let Right r1 = eval lhs
|
||
|
|
Right r2 = eval rhs
|
||
|
|
in Right (r1 - r2)
|
||
|
|
eval (EAnd lhs rhs) =
|
||
|
|
let Left r1 = eval lhs
|
||
|
|
Left r2 = eval rhs
|
||
|
|
in Left (r1 && r2)
|
||
|
|
eval (EOr lhs rhs) =
|
||
|
|
let Left r1 = eval lhs
|
||
|
|
Left r2 = eval rhs
|
||
|
|
in Left (r1 || r2)
|
||
|
|
|
||
|
|
-- ========================================
|
||
|
|
-- Unused parser code
|
||
|
|
-- ========================================
|
||
|
|
|
||
|
|
type Parser = M.Parsec Void Text
|
||
|
|
|
||
|
|
space :: Parser ()
|
||
|
|
space = ML.space MC.space1 M.empty M.empty
|
||
|
|
{-# INLINE space #-}
|
||
|
|
|
||
|
|
lexeme_ :: forall a. Parser a -> Parser a
|
||
|
|
lexeme_ = ML.lexeme $ MC.space1 <|> M.eof
|
||
|
|
{-# INLINE lexeme_ #-}
|
||
|
|
|
||
|
|
symbol :: Text -> Parser Text
|
||
|
|
symbol = ML.symbol space
|
||
|
|
{-# INLINE symbol #-}
|
||
|
|
|
||
|
|
parens :: forall a. Parser a -> Parser a
|
||
|
|
parens = M.between (symbol "(") (symbol ")")
|
||
|
|
{-# INLINE parens #-}
|
||
|
|
|
||
|
|
boolean :: Parser Bool
|
||
|
|
boolean = lexeme_ do
|
||
|
|
MC.string "true" $> True <|> MC.string "false" $> False
|
||
|
|
{-# INLINE boolean #-}
|
||
|
|
|
||
|
|
integer :: Parser Integer
|
||
|
|
integer = lexeme_ do
|
||
|
|
i <- M.some $ M.satisfy isDigit
|
||
|
|
case readDec i of
|
||
|
|
[(value, "")] -> pure value
|
||
|
|
_ -> fail "integer"
|
||
|
|
{-# INLINE integer #-}
|
||
|
|
|
||
|
|
{-
|
||
|
|
Couldn't match type `Bool` with `Integer`
|
||
|
|
|
||
|
|
parseExpr = E.makeExprParser parseTerm
|
||
|
|
[ [binary "+" EAdd, binary "-" ESub]
|
||
|
|
, [binary "&&" EAnd, binary "||" EOr]
|
||
|
|
]
|
||
|
|
where
|
||
|
|
binary name f = E.InfixL (f <$ symbol name)
|
||
|
|
parseTerm = parens parseExpr <|>
|
||
|
|
EInt <$> integer <|>
|
||
|
|
EBool <$> boolean
|
||
|
|
-}
|
||
|
|
|
||
|
|
-- ========================================
|
||
|
|
-- Main
|
||
|
|
-- ========================================
|
||
|
|
|
||
|
|
main :: IO ()
|
||
|
|
main = do
|
||
|
|
[count] <- map read <$> getArgs
|
||
|
|
let expr = foldl' EAdd (EInt 0) $ take count (EInt <$> [1..])
|
||
|
|
print $ {-# SCC "evaluated" #-} eval expr
|