diff --git a/haiji.cabal b/haiji.cabal --- 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 @@ 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 --- a/src/Text/Haiji/Runtime.hs +++ b/src/Text/Haiji/Runtime.hs @@ -48,6 +48,7 @@ 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 @@ ] 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 --- 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 @@ 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 --- 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 --- /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 --- 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 --- a/src/Text/Haiji/TH.hs +++ b/src/Text/Haiji/TH.hs @@ -110,10 +110,35 @@ ] 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 --- a/src/Text/Haiji/Types.hs +++ b/src/Text/Haiji/Types.hs @@ -58,3 +58,4 @@ 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 --- a/test/tests.hs +++ b/test/tests.hs @@ -122,6 +122,46 @@ [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