haiji 0.2.2.3 → 0.2.3.0
raw patch · 9 files changed
+716/−80 lines, 9 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- haiji.cabal +2/−2
- src/Text/Haiji/Runtime.hs +113/−8
- src/Text/Haiji/Syntax.hs +4/−2
- src/Text/Haiji/Syntax/Expression.hs +443/−7
- src/Text/Haiji/Syntax/Filter.hs +81/−0
- src/Text/Haiji/Syntax/Variable.hs +0/−54
- src/Text/Haiji/TH.hs +32/−7
- src/Text/Haiji/Types.hs +1/−0
- test/tests.hs +40/−0
haiji.cabal view
@@ -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
src/Text/Haiji/Runtime.hs view
@@ -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 "(<=)"
src/Text/Haiji/Syntax.hs view
@@ -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
src/Text/Haiji/Syntax/Expression.hs view
@@ -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
+ src/Text/Haiji/Syntax/Filter.hs view
@@ -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
− src/Text/Haiji/Syntax/Variable.hs
@@ -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
src/Text/Haiji/TH.hs view
@@ -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) |]
src/Text/Haiji/Types.hs view
@@ -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
test/tests.hs view
@@ -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