{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE CPP #-}
module Text.Haiji.Syntax.Expression
( Expression(..)
, expression
, Expr(..)
, External
) where
import Prelude hiding (filter)
#if MIN_VERSION_base(4,8,0)
#else
import Control.Applicative
#endif
import Data.Attoparsec.Text
import Data.Bool
import Data.List hiding (filter)
import Data.Scientific
import Text.Haiji.Syntax.Identifier
import Text.Haiji.Syntax.Filter
data Z
data S a
type Level0 = Z
type Level1 = S Level0
type Level2 = S Level1
type Level3 = S Level2
type Level4 = S Level3
type Level5 = S Level4
type Level6 = S Level5
type Level7 = S Level6
type Level8 = S Level7
type LevelMax = Level8
data MulDiv = Mul | DivF | DivI | Mod deriving Eq
instance Show MulDiv where
show Mul = "*"
show DivF = "/"
show DivI = "//"
show Mod = "%"
data AddSub = Add | Sub deriving Eq
instance Show AddSub where
show Add = "+"
show Sub = "-"
data Internal
data External
data Expr visibility level where
ExprLift :: Expr visibility lv -> Expr visibility (S lv)
ExprIntegerLiteral :: Int -> Expr visibility Level0
ExprBooleanLiteral :: Bool -> Expr visibility Level0
ExprVariable :: Identifier -> Expr visibility Level0
ExprParen :: Expr visibility LevelMax -> Expr visibility Level0
ExprRange :: [Expr visibility LevelMax] -> Expr visibility Level0
ExprAttributed :: Expr visibility Level0 -> [Identifier] -> Expr visibility Level1
ExprFiltered :: Expr visibility Level1 -> [Filter] -> Expr visibility Level2
ExprInternalPow :: Expr Internal Level2 -> [Expr Internal Level2] -> Expr Internal Level3
ExprPow :: Expr External Level3 -> Expr External Level2 -> Expr External Level3
ExprInternalMulDiv :: Expr Internal Level3 -> [(MulDiv, Expr Internal Level3)] -> Expr Internal Level4
ExprMul :: Expr External Level4 -> Expr External Level3 -> Expr External Level4
ExprDivF :: Expr External Level4 -> Expr External Level3 -> Expr External Level4
ExprDivI :: Expr External Level4 -> Expr External Level3 -> Expr External Level4
ExprMod :: Expr External Level4 -> Expr External Level3 -> Expr External Level4
ExprInternalAddSub :: Expr Internal Level4 -> [(AddSub, Expr Internal Level4)] -> Expr Internal Level5
ExprAdd :: Expr External Level5 -> Expr External Level4 -> Expr External Level5
ExprSub :: Expr External Level5 -> Expr External Level4 -> Expr External Level5
ExprEQ :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprNEQ :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprGT :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprGE :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprLT :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprLE :: Expr visibility Level5 -> Expr visibility Level5 -> Expr visibility Level6
ExprInternalAnd :: Expr Internal Level6 -> [Expr Internal Level6] -> Expr Internal Level7
ExprAnd :: Expr External Level7 -> Expr External Level6 -> Expr External Level7
ExprInternalOr :: Expr Internal Level7 -> [Expr Internal Level7] -> Expr Internal Level8
ExprOr :: Expr External Level8 -> Expr External Level7 -> Expr External Level8
toExternal :: Expr Internal level -> Expr External level
toExternal (ExprLift e) = ExprLift $ toExternal e
toExternal (ExprIntegerLiteral n) = ExprIntegerLiteral n
toExternal (ExprBooleanLiteral b) = ExprBooleanLiteral b
toExternal (ExprVariable i) = ExprVariable i
toExternal (ExprParen e) = ExprParen $ toExternal e
toExternal (ExprRange args) = ExprRange $ map toExternal args
toExternal (ExprAttributed e attrs) = ExprAttributed (toExternal e) attrs
toExternal (ExprFiltered e filters) = ExprFiltered (toExternal e) filters
toExternal (ExprInternalPow e []) = ExprLift $ toExternal e
toExternal (ExprInternalPow e es) = ExprPow (toExternal (ExprInternalPow e $ init es)) (toExternal $ last es)
toExternal (ExprInternalMulDiv e []) = ExprLift $ toExternal e
toExternal (ExprInternalMulDiv e es) = case last es of
(Mul , e') -> ExprMul (toExternal (ExprInternalMulDiv e $ init es)) (toExternal e')
(DivF, e') -> ExprDivF (toExternal (ExprInternalMulDiv e $ init es)) (toExternal e')
(DivI, e') -> ExprDivI (toExternal (ExprInternalMulDiv e $ init es)) (toExternal e')
(Mod , e') -> ExprMod (toExternal (ExprInternalMulDiv e $ init es)) (toExternal e')
toExternal (ExprInternalAddSub e []) = ExprLift $ toExternal e
toExternal (ExprInternalAddSub e es) = case last es of
(Add, e') -> ExprAdd (toExternal (ExprInternalAddSub e $ init es)) (toExternal e')
(Sub, e') -> ExprSub (toExternal (ExprInternalAddSub e $ init es)) (toExternal e')
toExternal (ExprEQ e1 e2) = ExprEQ (toExternal e1) (toExternal e2)
toExternal (ExprNEQ e1 e2) = ExprNEQ (toExternal e1) (toExternal e2)
toExternal (ExprGT e1 e2) = ExprGT (toExternal e1) (toExternal e2)
toExternal (ExprGE e1 e2) = ExprGE (toExternal e1) (toExternal e2)
toExternal (ExprLT e1 e2) = ExprLT (toExternal e1) (toExternal e2)
toExternal (ExprLE e1 e2) = ExprLE (toExternal e1) (toExternal e2)
toExternal (ExprInternalAnd e []) = ExprLift $ toExternal e
toExternal (ExprInternalAnd e es) = ExprAnd (toExternal (ExprInternalAnd e $ init es)) (toExternal $ last es)
toExternal (ExprInternalOr e []) = ExprLift $ toExternal e
toExternal (ExprInternalOr e es) = ExprOr (toExternal (ExprInternalOr e $ init es)) (toExternal $ last es)
deriving instance Eq (Expr visibility level)
instance Show (Expr visibility phase) where
show (ExprLift e) = show e
show (ExprIntegerLiteral n) = show n
show (ExprBooleanLiteral b) = if b then "true" else "false"
show (ExprVariable v) = show v
show (ExprParen e) = '(' : shows e ")"
show (ExprRange args) = "range(" ++ intercalate ", " [ show e | e <- args ] ++ ")"
show (ExprAttributed e attrs) = shows e $ concat [ '.' : show a | a <- attrs ]
show (ExprFiltered v filters) = shows v $ filters >>= show
show (ExprInternalPow e es) = intercalate " ** " $ map show $ e:es
show (ExprPow e1 e2) = shows e1 " ** " ++ show e2
show (ExprInternalMulDiv e es) = concat $ show e : concat [ [ ' ' : shows op " ", show e' ] | (op, e') <- es ]
show (ExprMul e1 e2) = shows e1 " * " ++ show e2
show (ExprDivF e1 e2) = shows e1 " / " ++ show e2
show (ExprDivI e1 e2) = shows e1 " // " ++ show e2
show (ExprMod e1 e2) = shows e1 " % " ++ show e2
show (ExprInternalAddSub e es) = concat $ show e : concat [ [ ' ' : shows op " ", show e' ] | (op, e') <- es ]
show (ExprAdd e1 e2) = shows e1 " + " ++ show e2
show (ExprSub e1 e2) = shows e1 " - " ++ show e2
show (ExprEQ e1 e2) = shows e1 " == " ++ show e2
show (ExprNEQ e1 e2) = shows e1 " != " ++ show e2
show (ExprGT e1 e2) = shows e1 " > " ++ show e2
show (ExprGE e1 e2) = shows e1 " >= " ++ show e2
show (ExprLT e1 e2) = shows e1 " < " ++ show e2
show (ExprLE e1 e2) = shows e1 " <= " ++ show e2
show (ExprInternalAnd e es) = intercalate " and " $ map show $ e:es
show (ExprAnd e1 e2) = shows e1 " and " ++ show e2
show (ExprInternalOr e es) = intercalate " or " $ map show $ e:es
show (ExprOr e1 e2) = shows e1 " or " ++ show e2
exprIntegerLiteral :: Parser (Expr Internal Level0)
exprIntegerLiteral = either (error . (show :: Double -> String)) ExprIntegerLiteral . floatingOrInteger <$> Data.Attoparsec.Text.scientific
exprBooleanLiteral :: Parser (Expr Internal Level0)
exprBooleanLiteral = ExprBooleanLiteral <$> choice [ string "true" *> return True, string "false" *> return False ]
exprVariable :: Parser (Expr Internal Level0)
exprVariable = ExprVariable <$> identifier
exprParen :: Parser (Expr Internal Level0)
exprParen = ExprParen <$> (char '(' *> skipSpace *> exprLevelMax <* skipSpace <* char ')')
exprRange :: Parser (Expr Internal Level0)
exprRange = ExprRange <$> args where
args = do
es <- string "range" *> skipSpace *> char '(' *> skipSpace *> (exprLevelMax `sepBy1` (skipSpace *> char ',' *> skipSpace)) <* skipSpace <* char ')'
bool (fail "too many args") (return es) $ length es < 4
exprLevel0 :: Parser (Expr Internal Level0)
exprLevel0 = choice [ exprIntegerLiteral
, exprBooleanLiteral
, exprRange
, exprVariable
, exprParen
]
exprAttributed :: Parser (Expr Internal Level1)
exprAttributed = ExprAttributed <$> exprLevel0 <*> many' (skipSpace *> char '.' *> skipSpace *> identifier)
exprLevel1 :: Parser (Expr Internal Level1)
exprLevel1 = choice [ exprAttributed
]
exprFiltered :: Parser (Expr Internal Level2)
exprFiltered = ExprFiltered <$> exprLevel1 <*> many' (skipSpace *> filter)
exprLevel2 :: Parser (Expr Internal Level2)
exprLevel2 = choice [ exprFiltered
]
exprPow :: Parser (Expr Internal Level3)
exprPow = ExprInternalPow <$> exprLevel2 <*> many' (skipSpace *> string "**" *> skipSpace *> exprLevel2)
exprLevel3 :: Parser (Expr Internal Level3)
exprLevel3 = choice [ exprPow
]
exprMulDiv :: Parser (Expr Internal Level4)
exprMulDiv = ExprInternalMulDiv <$> exprLevel3 <*> many' ((,) <$> (skipSpace *> op) <*> (skipSpace *> exprLevel3)) where
op = choice [ string "//" *> return DivI
, string "/" *> return DivF
, string "*" *> return Mul
, string "%" *> return Mod
]
exprLevel4 :: Parser (Expr Internal Level4)
exprLevel4 = choice [ exprMulDiv
]
exprAddSub :: Parser (Expr Internal Level5)
exprAddSub = ExprInternalAddSub <$> exprLevel4 <*> many' ((,) <$> (skipSpace *> op) <*> (skipSpace *> exprLevel4)) where
op = choice [ string "+" *> return Add
, string "-" *> return Sub
]
exprLevel5 :: Parser (Expr Internal Level5)
exprLevel5 = choice [ exprAddSub
]
exprEQ :: Parser (Expr Internal Level6)
exprEQ = ExprEQ <$> exprLevel5 <*> (skipSpace *> string "==" *> skipSpace *> exprLevel5)
exprNEQ :: Parser (Expr Internal Level6)
exprNEQ = ExprNEQ <$> exprLevel5 <*> (skipSpace *> string "!=" *> skipSpace *> exprLevel5)
exprGT :: Parser (Expr Internal Level6)
exprGT = ExprGT <$> exprLevel5 <*> (skipSpace *> string ">" *> skipSpace *> exprLevel5)
exprGE :: Parser (Expr Internal Level6)
exprGE = ExprGE <$> exprLevel5 <*> (skipSpace *> string ">=" *> skipSpace *> exprLevel5)
exprLT :: Parser (Expr Internal Level6)
exprLT = ExprLT <$> exprLevel5 <*> (skipSpace *> string "<" *> skipSpace *> exprLevel5)
exprLE :: Parser (Expr Internal Level6)
exprLE = ExprLE <$> exprLevel5 <*> (skipSpace *> string "<=" *> skipSpace *> exprLevel5)
exprLevel6 :: Parser (Expr Internal Level6)
exprLevel6 = choice [ exprEQ
, exprNEQ
, exprGE
, exprGT
, exprLE
, exprLT
, ExprLift <$> exprLevel5
]
exprAnd :: Parser (Expr Internal Level7)
exprAnd = ExprInternalAnd <$> exprLevel6 <*> many' (skipSpace *> string "and" *> skipSpace *> exprLevel6)
exprLevel7 :: Parser (Expr Internal Level7)
exprLevel7 = choice [ exprAnd
, ExprLift <$> exprLevel6
]
exprOr :: Parser (Expr Internal Level8)
exprOr = ExprInternalOr <$> exprLevel7 <*> many' (skipSpace *> string "or" *> skipSpace *> exprLevel7)
exprLevel8 :: Parser (Expr Internal Level8)
exprLevel8 = choice [ exprOr
, ExprLift <$> exprLevel7
]
exprLevelMax :: Parser (Expr Internal LevelMax)
exprLevelMax = exprLevel8
newtype Expression = Expression (Expr External LevelMax) deriving Eq
instance Show Expression where
show (Expression e) = show e
expression :: Parser Expression
expression = Expression . toExternal <$> exprLevelMax