summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorNoriyukiOhkawa <>2019-04-15 07:01:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2019-04-15 07:01:00 (GMT)
commit02ae84a27594b636a4ef6dce7b5118d4af2fe704 (patch)
treec4ac0eb7bceea0678272ec6e650d363cc4a06e7f
parent50593a20b0a8e171a6bb5ab6ea10211b38a89d89 (diff)
version 0.2.3.00.2.3.0
-rw-r--r--haiji.cabal4
-rw-r--r--src/Text/Haiji/Runtime.hs121
-rw-r--r--src/Text/Haiji/Syntax.hs6
-rw-r--r--src/Text/Haiji/Syntax/Expression.hs450
-rw-r--r--src/Text/Haiji/Syntax/Filter.hs81
-rw-r--r--src/Text/Haiji/Syntax/Variable.hs54
-rw-r--r--src/Text/Haiji/TH.hs39
-rw-r--r--src/Text/Haiji/Types.hs1
-rw-r--r--test/tests.hs40
9 files changed, 716 insertions, 80 deletions
diff --git a/haiji.cabal b/haiji.cabal
index 96392c3..e93bfd3 100644
--- a/haiji.cabal
+++ b/haiji.cabal
@@ -2,7 +2,7 @@
-- see http://haskell.org/cabal/users-guide/
name: haiji
-version: 0.2.2.3
+version: 0.2.3.0
synopsis: A typed template engine, subset of jinja2
description: Haiji is a template engine which is subset of jinja2.
This is designed to free from the unintended rendering result
@@ -31,8 +31,8 @@ library
Text.Haiji.Syntax
Text.Haiji.Syntax.AST
Text.Haiji.Syntax.Identifier
+ Text.Haiji.Syntax.Filter
Text.Haiji.Syntax.Expression
- Text.Haiji.Syntax.Variable
build-depends: base >=4.7 && <5
, text
, attoparsec >=0.10
diff --git a/src/Text/Haiji/Runtime.hs b/src/Text/Haiji/Runtime.hs
index 832bc47..b4f40cc 100644
--- a/src/Text/Haiji/Runtime.hs
+++ b/src/Text/Haiji/Runtime.hs
@@ -48,6 +48,7 @@ haijiAST env _parentBlock _children (Eval x) =
do let esc = if autoEscape env then htmlEscape else rawEscape
obj <- eval x
case obj of
+ JSON.Bool b -> return $ (`escapeBy` esc) $ toLT b
JSON.String s -> return $ (`escapeBy` esc) $ toLT s
JSON.Number n -> case floatingOrInteger (n :: Scientific) of
Left r -> let _ = (r :: Double) in error "invalid value type"
@@ -101,12 +102,116 @@ loopVariables len ix = JSON.object [ "first" JSON..= (ix == 0)
]
eval :: Expression -> Reader JSON.Value JSON.Value
-eval (Expression var _) = deref var
+eval (Expression expression) = go expression where
+ go :: Expr External level -> Reader JSON.Value JSON.Value
+ go (ExprLift e) = go e
+ go (ExprIntegerLiteral n) = return $ JSON.Number $ scientific (toEnum n) 0
+ go (ExprBooleanLiteral b) = return $ JSON.Bool b
+ go (ExprVariable v) = either error id . JSON.parseEither (JSON.withObject (show v) (JSON..: (T.pack $ show v))) <$> ask
+ go (ExprParen e) = go e
+ go (ExprRange [stop]) = do
+ sstop <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go stop
+ case floatingOrInteger sstop :: Either Float Integer of
+ (Right istop) -> return $ JSON.Array $ V.fromList $ map (JSON.Number . flip scientific 0) [0..istop-1]
+ _ -> error "range"
+ go (ExprRange [start, stop]) = do
+ sstart <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go start
+ sstop <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go stop
+ case (floatingOrInteger sstart :: Either Float Integer, floatingOrInteger sstop :: Either Float Integer) of
+ (Right istart, Right istop) -> return $ JSON.Array $ V.fromList $ map (JSON.Number . flip scientific 0) [istart..istop-1]
+ _ -> error "range"
+ go (ExprRange [start, stop, step]) = do
+ sstart <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go start
+ sstop <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go stop
+ sstep <- either error id . JSON.parseEither (JSON.withScientific "range" return) <$> go step
+ case (floatingOrInteger sstart :: Either Float Integer, floatingOrInteger sstop :: Either Float Integer, floatingOrInteger sstep :: Either Float Integer) of
+ (Right istart, Right istop, Right istep) -> return $ JSON.Array $ V.fromList $ map (JSON.Number . flip scientific 0) [istart,istart+istep..istop-1]
+ _ -> error "range"
+ go (ExprRange _) = error "unreachable"
+ go (ExprAttributed e []) = go e
+ go (ExprAttributed e attrs) = either error id . JSON.parseEither (JSON.withObject (show $ last attrs) (JSON..: (T.pack $ show $ last attrs))) <$> go (ExprAttributed e $ init attrs)
+ go (ExprFiltered e []) = go e
+ go (ExprFiltered e filters) = applyFilter (last filters) $ ExprFiltered e $ init filters where
+ applyFilter FilterAbs e' = either error id . JSON.parseEither (JSON.withScientific "abs" (return . JSON.Number . abs)) <$> go e'
+ applyFilter FilterLength e' = either error id . JSON.parseEither (JSON.withArray "length" (return . JSON.Number . flip scientific 0 . toEnum . V.length)) <$> go e'
-deref :: Variable -> Reader JSON.Value JSON.Value
-deref (VariableBase v) = do
- dict <- ask
- maybe (error $ show (VariableBase v, dict)) return $ JSON.parseMaybe (JSON.withObject (show v) (JSON..: (T.pack $ show v))) dict
-deref (VariableAttribute v f) = do
- dict <- deref v
- maybe (error "2") return $ JSON.parseMaybe (JSON.withObject (show f) (JSON..: (T.pack $ show f))) dict
+ go (ExprPow e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (**)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (**)" return) <$> go e2
+ case (floatingOrInteger v1 :: Either Float Integer, floatingOrInteger v2 :: Either Float Integer) of
+ (Right l, Right r) -> return $ JSON.Number $ scientific (l ^ r) 0
+ _ -> error "(**)"
+ go (ExprMul e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (*)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (*)" return) <$> go e2
+ return $ JSON.Number $ v1 * v2
+ go (ExprDivF e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (/)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (/)" return) <$> go e2
+ return $ JSON.Number $ v1 / v2
+ go (ExprDivI e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (//)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (//)" return) <$> go e2
+ case (floatingOrInteger v1 :: Either Float Integer, floatingOrInteger v2 :: Either Float Integer) of
+ (Right l, Right r) -> return $ JSON.Number $ scientific (l `div` r) 0
+ _ -> error "(//)"
+ go (ExprMod e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (%)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (%)" return) <$> go e2
+ case (floatingOrInteger v1 :: Either Float Integer, floatingOrInteger v2 :: Either Float Integer) of
+ (Right l, Right r) -> return $ JSON.Number $ scientific (l `mod` r) 0
+ _ -> error "(%)"
+ go (ExprAdd e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (/)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (/)" return) <$> go e2
+ return $ JSON.Number $ v1 + v2
+ go (ExprSub e1 e2) = do
+ v1 <- either error id . JSON.parseEither (JSON.withScientific "lhs of (/)" return) <$> go e1
+ v2 <- either error id . JSON.parseEither (JSON.withScientific "rhs of (/)" return) <$> go e2
+ return $ JSON.Number $ v1 - v2
+ go (ExprEQ e1 e2) = JSON.Bool <$> ((==) <$> go e1 <*> go e2)
+ go (ExprNEQ e1 e2) = JSON.Bool <$> ((/=) <$> go e1 <*> go e2)
+ go (ExprGT e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Number l, JSON.Number r) -> return $ JSON.Bool $ l > r
+ (JSON.String l, JSON.String r) -> return $ JSON.Bool $ l > r
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l > r
+ _ -> error "(>)"
+ go (ExprGE e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Number l, JSON.Number r) -> return $ JSON.Bool $ l >= r
+ (JSON.String l, JSON.String r) -> return $ JSON.Bool $ l >= r
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l >= r
+ _ -> error "(>=)"
+ go (ExprLT e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Number l, JSON.Number r) -> return $ JSON.Bool $ l < r
+ (JSON.String l, JSON.String r) -> return $ JSON.Bool $ l < r
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l < r
+ _ -> error "(<)"
+ go (ExprLE e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Number l, JSON.Number r) -> return $ JSON.Bool $ l <= r
+ (JSON.String l, JSON.String r) -> return $ JSON.Bool $ l <= r
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l <= r
+ _ -> error "(<=)"
+ go (ExprAnd e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l && r
+ _ -> error "(<=)"
+ go (ExprOr e1 e2) = do
+ v1 <- go e1
+ v2 <- go e2
+ case (v1, v2) of
+ (JSON.Bool l, JSON.Bool r) -> return $ JSON.Bool $ l || r
+ _ -> error "(<=)"
diff --git a/src/Text/Haiji/Syntax.hs b/src/Text/Haiji/Syntax.hs
index 134a882..7446bfe 100644
--- a/src/Text/Haiji/Syntax.hs
+++ b/src/Text/Haiji/Syntax.hs
@@ -1,7 +1,9 @@
module Text.Haiji.Syntax
( Expression(..)
+ , Expr(..)
+ , External
+ , Filter(..)
, Identifier
- , Variable(..)
, AST(..)
, Loaded(..)
, parser
@@ -9,5 +11,5 @@ module Text.Haiji.Syntax
import Text.Haiji.Syntax.AST
import Text.Haiji.Syntax.Identifier
+import Text.Haiji.Syntax.Filter
import Text.Haiji.Syntax.Expression
-import Text.Haiji.Syntax.Variable
diff --git a/src/Text/Haiji/Syntax/Expression.hs b/src/Text/Haiji/Syntax/Expression.hs
index 646c708..f93128d 100644
--- a/src/Text/Haiji/Syntax/Expression.hs
+++ b/src/Text/Haiji/Syntax/Expression.hs
@@ -1,25 +1,461 @@
+{-# 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 Text.Haiji.Syntax.Variable
+import Data.Bool
+import Data.List hiding (filter)
+import Data.Scientific
+import Text.Haiji.Syntax.Identifier
+import Text.Haiji.Syntax.Filter
-data Filter = Filter deriving Eq
+-- $setup
+-- >>> import Control.Arrow (left)
-instance Show Filter where
- show _ = ""
+data Z
+data S a
-data Expression = Expression Variable [Filter] deriving Eq
+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
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprIntegerLiteral
+-- >>> eval "1"
+-- Right 1
+-- >>> eval "2"
+-- Right 2
+exprIntegerLiteral :: Parser (Expr Internal Level0)
+exprIntegerLiteral = either (error . (show :: Double -> String)) ExprIntegerLiteral . floatingOrInteger <$> Data.Attoparsec.Text.scientific
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprBooleanLiteral
+-- >>> eval "true"
+-- Right true
+-- >>> eval "false"
+-- Right false
+exprBooleanLiteral :: Parser (Expr Internal Level0)
+exprBooleanLiteral = ExprBooleanLiteral <$> choice [ string "true" *> return True, string "false" *> return False ]
+
+exprVariable :: Parser (Expr Internal Level0)
+exprVariable = ExprVariable <$> identifier
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprParen
+-- >>> eval "(1)"
+-- Right (1)
+-- >>> eval "(foo)"
+-- Right (foo)
+-- >>> eval "(true)"
+-- Right (true)
+-- >>> eval "(foo )"
+-- Right (foo)
+-- >>> eval "( foo)"
+-- Right (foo)
+exprParen :: Parser (Expr Internal Level0)
+exprParen = ExprParen <$> (char '(' *> skipSpace *> exprLevelMax <* skipSpace <* char ')')
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprRange
+-- >>> eval "range(1)"
+-- Right range(1)
+-- >>> eval "range (1)"
+-- Right range(1)
+-- >>> eval "range(1, 2)"
+-- Right range(1, 2)
+-- >>> eval "range (1,2)"
+-- Right range(1, 2)
+-- >>> eval "range(1 ,2 , 3)"
+-- Right range(1, 2, 3)
+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
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprFiltered
+-- >>> eval "foo|abs"
+-- Right foo|abs
+-- >>> eval "foo| abs"
+-- Right foo|abs
+-- >>> eval "foo |abs"
+-- Right foo|abs
+-- >>> eval "foo | abs"
+-- Right foo|abs
+exprFiltered :: Parser (Expr Internal Level2)
+exprFiltered = ExprFiltered <$> exprLevel1 <*> many' (skipSpace *> filter)
+
+exprLevel2 :: Parser (Expr Internal Level2)
+exprLevel2 = choice [ exprFiltered
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprPow
+-- >>> eval "1**2"
+-- Right 1 ** 2
+-- >>> eval "1** 2"
+-- Right 1 ** 2
+-- >>> eval "1 **2"
+-- Right 1 ** 2
+exprPow :: Parser (Expr Internal Level3)
+exprPow = ExprInternalPow <$> exprLevel2 <*> many' (skipSpace *> string "**" *> skipSpace *> exprLevel2)
+
+exprLevel3 :: Parser (Expr Internal Level3)
+exprLevel3 = choice [ exprPow
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprMulDiv
+-- >>> eval "1*2//3"
+-- Right 1 * 2 // 3
+-- >>> eval "1 * 2 // 3"
+-- Right 1 * 2 // 3
+-- >>> eval "1//2*3"
+-- Right 1 // 2 * 3
+-- >>> eval "1*2/3"
+-- Right 1 * 2 / 3
+-- >>> eval "1 * 2 % 3"
+-- Right 1 * 2 % 3
+-- >>> eval "1%2*3"
+-- Right 1 % 2 * 3
+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
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprAddSub
+-- >>> eval "1+2-3"
+-- Right 1 + 2 - 3
+-- >>> eval "1 + 2 - 3"
+-- Right 1 + 2 - 3
+-- >>> eval "1-2+3"
+-- Right 1 - 2 + 3
+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
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprEQ
+-- >>> eval "1==1"
+-- Right 1 == 1
+-- >>> eval "1== 1"
+-- Right 1 == 1
+-- >>> eval "1 ==1"
+-- Right 1 == 1
+exprEQ :: Parser (Expr Internal Level6)
+exprEQ = ExprEQ <$> exprLevel5 <*> (skipSpace *> string "==" *> skipSpace *> exprLevel5)
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprNEQ
+-- >>> eval "1!=1"
+-- Right 1 != 1
+-- >>> eval "1!= 1"
+-- Right 1 != 1
+-- >>> eval "1 !=1"
+-- Right 1 != 1
+exprNEQ :: Parser (Expr Internal Level6)
+exprNEQ = ExprNEQ <$> exprLevel5 <*> (skipSpace *> string "!=" *> skipSpace *> exprLevel5)
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprGT
+-- >>> eval "1>1"
+-- Right 1 > 1
+-- >>> eval "1> 1"
+-- Right 1 > 1
+-- >>> eval "1 >1"
+-- Right 1 > 1
+exprGT :: Parser (Expr Internal Level6)
+exprGT = ExprGT <$> exprLevel5 <*> (skipSpace *> string ">" *> skipSpace *> exprLevel5)
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprGE
+-- >>> eval "1>=1"
+-- Right 1 >= 1
+-- >>> eval "1>= 1"
+-- Right 1 >= 1
+-- >>> eval "1 >=1"
+-- Right 1 >= 1
+exprGE :: Parser (Expr Internal Level6)
+exprGE = ExprGE <$> exprLevel5 <*> (skipSpace *> string ">=" *> skipSpace *> exprLevel5)
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprLT
+-- >>> eval "1<1"
+-- Right 1 < 1
+-- >>> eval "1< 1"
+-- Right 1 < 1
+-- >>> eval "1 <1"
+-- Right 1 < 1
+exprLT :: Parser (Expr Internal Level6)
+exprLT = ExprLT <$> exprLevel5 <*> (skipSpace *> string "<" *> skipSpace *> exprLevel5)
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprLE
+-- >>> eval "1<=1"
+-- Right 1 <= 1
+-- >>> eval "1<= 1"
+-- Right 1 <= 1
+-- >>> eval "1 <=1"
+-- Right 1 <= 1
+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
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprAnd
+-- >>> eval "true and false"
+-- Right true and false
+exprAnd :: Parser (Expr Internal Level7)
+exprAnd = ExprInternalAnd <$> exprLevel6 <*> many' (skipSpace *> string "and" *> skipSpace *> exprLevel6)
+
+exprLevel7 :: Parser (Expr Internal Level7)
+exprLevel7 = choice [ exprAnd
+ , ExprLift <$> exprLevel6
+ ]
+
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly exprOr
+-- >>> eval "true or false"
+-- Right true or false
+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 var fs) = show var ++ concat [ '|' : show f | f <- fs ]
+ show (Expression e) = show e
+-- |
+--
+-- >>> let eval = left (const "parse error") . parseOnly expression
+-- >>> eval "foo"
+-- Right foo
+-- >>> eval "(foo)"
+-- Right (foo)
+-- >>> eval "1"
+-- Right 1
+-- >>> eval "true"
+-- Right true
+-- >>> eval "false"
+-- Right false
+-- >>> eval "foo.bar"
+-- Right foo.bar
+-- >>> eval "(foo).bar"
+-- Right (foo).bar
+-- >>> eval "(foo.bar)"
+-- Right (foo.bar)
+-- >>> eval "foo.b}}ar"
+-- Right foo.b
+-- >>> eval "foo.b ar"
+-- Right foo.b
+-- >>> eval "foo.b }ar"
+-- Right foo.b
+-- >>> eval " foo.bar"
+-- Left "parse error"
+-- >>> eval "foo. bar"
+-- Right foo.bar
+-- >>> eval "foo .bar"
+-- Right foo.bar
+-- >>> eval "foo.bar "
+-- Right foo.bar
+-- >>> eval "foo.bar "
+-- Right foo.bar
+-- >>> eval "foo.bar.baz"
+-- Right foo.bar.baz
+--
expression :: Parser Expression
-expression = Expression <$> variable <*> return [] -- many (skipSpace >> char '|' >> skipSpace >> filter)
+expression = Expression . toExternal <$> exprLevelMax
diff --git a/src/Text/Haiji/Syntax/Filter.hs b/src/Text/Haiji/Syntax/Filter.hs
new file mode 100644
index 0000000..5bcebf5
--- /dev/null
+++ b/src/Text/Haiji/Syntax/Filter.hs
@@ -0,0 +1,81 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Text.Haiji.Syntax.Filter
+ ( Filter(..)
+ , filter
+ ) where
+
+#if MIN_VERSION_base(4,8,0)
+#else
+import Control.Applicative
+#endif
+import Data.Attoparsec.Text
+import Prelude hiding (filter)
+
+-- http://jinja.pocoo.org/docs/dev/templates/#builtin-filters
+data Filter = FilterAbs
+ | FilterLength
+ deriving Eq
+{-
+ -- | FilterAttr Identifier
+ -- | FilterBatch
+ -- | FilterCapitalize
+ -- | FilterCenter Int
+ -- | FilterDefault
+ -- | FilterDictSort
+ -- | FilterEscape
+ -- | FilterFileSizeFormat
+ -- | FilterFirst
+ -- | FilterFloat
+ -- | FilterForceEscape
+ -- | FilterFormat
+ -- | FilterGroupBy Variable
+ -- | FilterIndent Int Bool
+ -- | FilterInt Int Int
+ -- | FilterJoin String (Maybe Identifier)
+ -- | FilterLast
+ -- | FilterList
+ -- | FilterLower
+ -- | FilterMap
+ -- | FilterPprint
+ -- | FilterRandom
+ -- | FilterReject
+ -- | FilterRejectAttr
+ -- | FilterReplace
+ -- | FilterReverse
+ -- | FilterRound
+ -- | FilterSafe
+ -- | FilterSelect
+ -- | FilterSelectAttr
+ -- | FilterSlice
+ -- | FilterSort
+ -- | FilterString
+ -- | FilterStripTags
+ -- | FilterSum
+ -- | FilterTitle
+ -- | FilterTrim
+ -- | FilterTruncate
+ -- | FilterUpper
+ -- | FilterURLEncode
+ -- | FilterURLize
+ -- | FilterWordCount
+ -- | FilterWordWrap
+ -- | FilterXMLAttr
+-}
+instance Show Filter where
+ show (FilterAbs) = "|abs"
+ show (FilterLength) = "|length"
+
+filter :: Parser Filter
+filter = char '|' *>
+ skipSpace *>
+ choice
+ [ filterAbs
+ , filterLength
+ ]
+
+filterAbs :: Parser Filter
+filterAbs = string "abs" *> return FilterAbs
+
+filterLength :: Parser Filter
+filterLength = string "length" *> return FilterLength
diff --git a/src/Text/Haiji/Syntax/Variable.hs b/src/Text/Haiji/Syntax/Variable.hs
deleted file mode 100644
index a8bcb06..0000000
--- a/src/Text/Haiji/Syntax/Variable.hs
+++ /dev/null
@@ -1,54 +0,0 @@
-module Text.Haiji.Syntax.Variable
- ( Variable(..)
- , variable
- ) where
-
-import Data.Attoparsec.Text
-import Text.Haiji.Syntax.Identifier
-
-data Variable = VariableBase Identifier
- | VariableAttribute Variable Identifier
- deriving Eq
-
-instance Show Variable where
- show (VariableBase var) = show var
- show (VariableAttribute var attr) = shows var "." ++ show attr
-
--- |
---
--- >>> import Control.Arrow (left)
--- >>> let eval = left (const "parse error") . parseOnly variable
--- >>> eval "foo"
--- Right foo
--- >>> eval "foo.bar"
--- Right foo.bar
--- >>> eval "foo.b}}ar"
--- Right foo.b
--- >>> eval "foo.b ar"
--- Right foo.b
--- >>> eval "foo.b }ar"
--- Right foo.b
--- >>> eval " foo.bar"
--- Left "parse error"
--- >>> eval "foo. bar"
--- Right foo.bar
--- >>> eval "foo .bar"
--- Right foo.bar
--- >>> eval "foo.bar "
--- Right foo.bar
--- >>> eval "foo.bar "
--- Right foo.bar
--- >>> eval "foo.bar.baz"
--- Right foo.bar.baz
---
-variable :: Parser Variable
-variable = identifier >>= go . VariableBase where
- go var = do
- skipSpace
- peek <- peekChar
- case peek of
- Nothing -> return var
- Just '}' -> return var
- Just ' ' -> return var
- Just '.' -> char '.' >> skipSpace >> identifier >>= go . VariableAttribute var
- _ -> return var
diff --git a/src/Text/Haiji/TH.hs b/src/Text/Haiji/TH.hs
index 50e2dd8..293994c 100644
--- a/src/Text/Haiji/TH.hs
+++ b/src/Text/Haiji/TH.hs
@@ -110,10 +110,35 @@ loopVariables len ix = Dict $ M.fromList [ ("first", toDyn (ix == 0))
]
eval :: Quasi q => Expression -> q Exp
-eval (Expression var _) = deref var
-
-deref :: Quasi q => Variable -> q Exp
-deref (VariableBase v) =
- runQ [e| retrieve <$> ask <*> return (Key :: Key $(litT . strTyLit $ show v)) |]
-deref (VariableAttribute v f) =
- runQ [e| retrieve <$> $(deref v) <*> return (Key :: Key $(litT . strTyLit $ show f)) |]
+eval (Expression expression) = go expression where
+ go :: Quasi q => Expr External level -> q Exp
+ go (ExprLift e) = go e
+ go (ExprIntegerLiteral n) = runQ [e| return (n :: Int) |]
+ go (ExprBooleanLiteral b) = runQ [e| return b|]
+ go (ExprVariable v) = runQ [e| retrieve <$> ask <*> return (Key :: Key $(litT . strTyLit $ show v)) |]
+ go (ExprParen e) = go e
+ go (ExprRange [stop]) = runQ [e| enumFromTo 0 <$> (pred <$> $(go stop)) |]
+ go (ExprRange [start, stop]) = runQ [e| enumFromTo <$> $(go start) <*> (pred <$> $(go stop)) |]
+ go (ExprRange [start, stop, step]) = runQ [e| (\a b c -> [a,a+c..b]) <$> $(go start) <*> (pred <$> $(go stop)) <*> $(go step) |]
+ go (ExprRange _) = error "unreachable"
+ go (ExprAttributed e []) = go e
+ go (ExprAttributed e attrs) = runQ [e| retrieve <$> $(go $ ExprAttributed e $ init attrs) <*> return (Key :: Key $(litT . strTyLit $ show $ last attrs)) |]
+ go (ExprFiltered e []) = go e
+ go (ExprFiltered e filters) = runQ [e| $(applyFilter (last filters) $ ExprFiltered e $ init filters) |] where
+ applyFilter FilterAbs e' = runQ [e| abs <$> $(go e') |]
+ applyFilter FilterLength e' = runQ [e| length <$> $(go e') |]
+ go (ExprPow e1 e2) = runQ [e| (^) <$> $(go e1) <*> $(go e2) |]
+ go (ExprMul e1 e2) = runQ [e| (*) <$> $(go e1) <*> $(go e2) |]
+ go (ExprDivF e1 e2) = runQ [e| (/) <$> $(go e1) <*> $(go e2) |]
+ go (ExprDivI e1 e2) = runQ [e| div <$> $(go e1) <*> $(go e2) |]
+ go (ExprMod e1 e2) = runQ [e| mod <$> $(go e1) <*> $(go e2) |]
+ go (ExprAdd e1 e2) = runQ [e| (+) <$> $(go e1) <*> $(go e2) |]
+ go (ExprSub e1 e2) = runQ [e| (-) <$> $(go e1) <*> $(go e2) |]
+ go (ExprEQ e1 e2) = runQ [e| (==) <$> $(go e1) <*> $(go e2) |]
+ go (ExprNEQ e1 e2) = runQ [e| (/=) <$> $(go e1) <*> $(go e2) |]
+ go (ExprGT e1 e2) = runQ [e| (>) <$> $(go e1) <*> $(go e2) |]
+ go (ExprGE e1 e2) = runQ [e| (>=) <$> $(go e1) <*> $(go e2) |]
+ go (ExprLT e1 e2) = runQ [e| (<) <$> $(go e1) <*> $(go e2) |]
+ go (ExprLE e1 e2) = runQ [e| (<=) <$> $(go e1) <*> $(go e2) |]
+ go (ExprAnd e1 e2) = runQ [e| (&&) <$> $(go e1) <*> $(go e2) |]
+ go (ExprOr e1 e2) = runQ [e| (||) <$> $(go e1) <*> $(go e2) |]
diff --git a/src/Text/Haiji/Types.hs b/src/Text/Haiji/Types.hs
index f822c53..b0d440f 100644
--- a/src/Text/Haiji/Types.hs
+++ b/src/Text/Haiji/Types.hs
@@ -58,3 +58,4 @@ instance ToLT T.Text where toLT = LT.fromStrict
instance ToLT LT.Text where toLT = id
instance ToLT Int where toLT = toLT . show
instance ToLT Integer where toLT = toLT . show
+instance ToLT Bool where toLT = toLT . show
diff --git a/test/tests.hs b/test/tests.hs
index 52bd22a..17378b7 100644
--- a/test/tests.hs
+++ b/test/tests.hs
@@ -122,6 +122,46 @@ case_variables = do
[key|F__o_o__|] ("include '_'" :: String) `merge`
[key|F1a2b3c|] ("include num" :: String)
+case_range :: Assertion
+case_range = do
+ expected <- jinja2 "test/range.tmpl" dict
+ tmpl <- readTemplateFile def "test/range.tmpl"
+ expected @=? render tmpl (toJSON dict)
+ expected @=? render $(haijiFile def "test/range.tmpl") dict
+ where
+ dict = [key|value|] (5 :: Int) `merge`
+ [key|array|] ([1,2,3] :: [Int])
+
+case_arith :: Assertion
+case_arith = do
+ expected <- jinja2 "test/arith.tmpl" dict
+ tmpl <- readTemplateFile def "test/arith.tmpl"
+ expected @=? render tmpl (toJSON dict)
+ expected @=? render $(haijiFile def "test/arith.tmpl") dict
+ where
+ dict = [key|value|] ((-1) :: Int) `merge`
+ [key|array|] ([1,2,3] :: [Int])
+
+case_comparison :: Assertion
+case_comparison = do
+ expected <- jinja2 "test/comparison.tmpl" dict
+ tmpl <- readTemplateFile def "test/comparison.tmpl"
+ expected @=? render tmpl (toJSON dict)
+ expected @=? render $(haijiFile def "test/comparison.tmpl") dict
+ where
+ dict = [key|value|] ((1) :: Int) `merge` -- There exists jinja2 bug (https://github.com/pallets/jinja/issues/755)
+ [key|array|] ([1,2,3] :: [Int])
+
+case_logic :: Assertion
+case_logic = do
+ expected <- jinja2 "test/logic.tmpl" dict
+ tmpl <- readTemplateFile def "test/logic.tmpl"
+ expected @=? render tmpl (toJSON dict)
+ expected @=? render $(haijiFile def "test/logic.tmpl") dict
+ where
+ dict = [key|value|] ((1) :: Int) `merge`
+ [key|array|] ([1,2,3] :: [Int])
+
case_HTML_escape :: Assertion
case_HTML_escape = do
expected <- jinja2 "test/HTML_escape.tmpl" dict