packages feed

haiji (empty) → 0.1.0.0

raw patch · 16 files changed

+1577/−0 lines, 16 filesdep +aesondep +attoparsecdep +basesetup-changed

Dependencies added: aeson, attoparsec, base, data-default, doctest, filepath, haiji, mtl, process-extras, scientific, tagged, tasty, tasty-hunit, tasty-th, template-haskell, text, transformers, unordered-containers, vector

Files

+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2014, Noriyuki OHKAWA++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of notogawa nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ haiji.cabal view
@@ -0,0 +1,76 @@+-- Initial haiji.cabal generated by cabal init.  For further documentation,+--  see http://haskell.org/cabal/users-guide/++name:                haiji+version:             0.1.0.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+                     by strictly typed variable interpolation.+license:             BSD3+license-file:        LICENSE+author:              Noriyuki OHKAWA <n.ohkawa@gmail.com>+maintainer:          Noriyuki OHKAWA <n.ohkawa@gmail.com>+copyright:           Copyright (c) 2014, Noriyuki OHKAWA+category:            Text+build-type:          Simple+-- extra-source-files:+cabal-version:       >=1.10++source-repository head+  type:                git+  location:            https://github.com/notogawa/haiji.git++library+  exposed-modules:     Text.Haiji+                       Text.Haiji.Runtime+  other-modules:       Text.Haiji.Parse+                       Text.Haiji.TH+                       Text.Haiji.Types+                       Text.Haiji.Dictionary+                       Text.Haiji.Syntax+                       Text.Haiji.Syntax.AST+                       Text.Haiji.Syntax.Identifier+                       Text.Haiji.Syntax.Expression+                       Text.Haiji.Syntax.Variable+  build-depends:       base >=4.7 && <4.9+                     , text+                     , attoparsec >=0.10+                     , template-haskell >=2.8+                     , tagged >=0.2+                     , aeson+                     , transformers+                     , mtl >=1.1+                     , vector+                     , unordered-containers+                     , scientific+                     , data-default+  hs-source-dirs:      src+  ghc-options:         -Wall+  default-language:    Haskell2010++test-suite doctests+  type:                exitcode-stdio-1.0+  main-is:             doctests.hs+  build-depends:       base+                     , doctest+                     , filepath+  hs-source-dirs:      test+  ghc-options:         -Wall -threaded -O0+  default-language:    Haskell2010++test-suite tests+  type:                exitcode-stdio-1.0+  main-is:             tests.hs+  build-depends:       base+                     , aeson+                     , haiji+                     , tasty+                     , tasty-th+                     , tasty-hunit+                     , text+                     , process-extras+                     , data-default+  hs-source-dirs:      test+  ghc-options:         -Wall -threaded -O0+  default-language:    Haskell2010
+ src/Text/Haiji.hs view
@@ -0,0 +1,74 @@+-- |+-- Module      : Text.Haiji+-- Copyright   : 2015 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : portable+--+-- Haiji is a template engine which is subset of Jinja2.+-- This is designed to free from the unintended rendering result by strictly typed variable interpolation.+--+-- Rendering result will be same as Jinja2's one. However, Haiji doesn't aim to be Jinja2.+-- Some feature and built-in Test\/Function\/Filter of Jinja2 allow rendering time type inspection.+-- Haiji will not support these type unsafe features.+-- Haiji generates a statically typed template by Template Haskell,+-- and check that a given dictionary includes enough information to render template.+--+-- >{-# LANGUAGE OverloadedStrings #-}+-- >{-# LANGUAGE TemplateHaskell #-}+-- >{-# LANGUAGE QuasiQuotes #-}+-- >{-# LANGUAGE DataKinds #-}+-- >module Main where+-- >+-- >import Data.Default+-- >import Text.Haiji+-- >import qualified Data.Text as T+-- >import qualified Data.Text.Lazy as LT+-- >import qualified Data.Text.Lazy.IO as LT+-- >+-- >main :: IO ()+-- >main = LT.putStr+-- >       $ render $(haijiFile def "example.tmpl")+-- >       $ [key|a_variable|] ("Hello,World!" :: LT.Text) `merge`+-- >         [key|navigation|] [ [key|caption|] cap `merge` [key|href|] href+-- >                           | (cap, href) <- [ ("A", "content/a.html")+-- >                                            , ("B", "content/b.html")+-- >                                            ] :: [ (T.Text, String) ]+-- >                           ] `merge`+-- >         [key|foo|] (1 :: Int) `merge`+-- >         [key|bar|] ("" :: String)++module Text.Haiji+    ( -- * Typed Template+      -- $template+      Template+      -- ** Generators+    , haiji+    , haijiFile+      -- ** Renderer+    , render+      -- * Rendering Environment+    , Environment+    , autoEscape+      -- * Dictionary+    , Dict+    , empty+      -- ** Builder+    , key+    , merge+    ) where++import Text.Haiji.TH+import Text.Haiji.Types+import Text.Haiji.Dictionary++-- $template+-- >{{ foo }}+--+-- For example, this Jinja2 template requires "foo".+-- A dictionary which provides a variable "foo" is required to render it.+-- If a variable "foo" does not exist in a given dictionary,+-- Jinja2 evaluates it to an empty string by default,+-- whereas haiji treats this case as compile error.
+ src/Text/Haiji/Dictionary.hs view
@@ -0,0 +1,192 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE PolyKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE ConstraintKinds #-}+#if MIN_VERSION_base(4,8,0)+#else+{-# LANGUAGE OverlappingInstances #-}+#endif+{-# LANGUAGE ScopedTypeVariables #-}+module Text.Haiji.Dictionary+       ( Dict(..)+       , (:->)(..)+       , empty+       , singleton+       , merge+       , Key(..)+       , retrieve+       ) where++import Data.Aeson+import Data.Monoid+import Data.Proxy+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.Encoding as LT+import Data.Type.Bool+import Data.Type.Equality+import GHC.TypeLits++data Key (k :: Symbol) where Key :: Key k++infixl 2 :->+data (k :: Symbol) :-> (v :: *) where Value :: v -> k :-> v++newtype VK v k = VK (k :-> v)++-- | Empty dictionary+empty :: Dict '[]+empty = Empty++singleton :: x -> Key k -> Dict '[ k :-> x ]+singleton x _ = Ext (Value x) Empty++value :: k :-> v -> v+value (Value v) = v++key :: KnownSymbol k => k :-> v -> String+key = symbolVal . VK++class Retrieve d k v where+  retrieve :: d -> Key k -> v+#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPABLE #-} (IsDict d, IsDict (kv ': d), Retrieve (Dict d) k v) => Retrieve (Dict (kv ': d)) k v where+#else+instance                      (IsDict d, IsDict (kv ': d), Retrieve (Dict d) k v) => Retrieve (Dict (kv ': d)) k v where+#endif+  retrieve (Ext _ d) k = retrieve d k+#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} (IsDict d, IsDict (((k :-> v') ': d)), v' ~ v) => Retrieve (Dict ((k :-> v') ': d)) k v where+#else+instance                     (IsDict d, IsDict (((k :-> v') ': d)), v' ~ v) => Retrieve (Dict ((k :-> v') ': d)) k v where+#endif+  retrieve (Ext (Value v) _) _ = v++-- | Type level Dictionary+data Dict (kv :: [*]) where+  Empty :: Dict '[]+  Ext :: k :-> v -> Dict d -> Dict ((k :-> v) ': d)++instance ToJSON (Dict '[]) where+  toJSON Empty = object []++instance (ToJSON (Dict s), ToJSON kv) => ToJSON (Dict (kv ': s)) where+  toJSON (Ext x xs) = Object (a <> b) where+    Object a = toJSON x+    Object b = toJSON xs++instance (ToJSON v, KnownSymbol k) => ToJSON (k :-> v) where+  toJSON x = object [ T.pack (key x) .= value x ]++instance ToJSON (Dict s) => Show (Dict s) where+  show = LT.unpack . LT.decodeUtf8 . encode++type AsDict s = Normalize (Sort s)++asDict :: (Sortable d, Normalizable (Sort d)) => Dict d -> Dict (AsDict d)+asDict = normalize . quicksort++type IsDict d = (d ~ Normalize (Sort d))++type Merge xs ys = Normalize (Sort (xs :++ ys))++-- | Merge 2 dictionaries+merge :: (Mergeable a b) => Dict a -> Dict b -> Dict (Merge a b)+merge a b = asDict $ append a b++type Mergeable a b = (Sortable (a :++ b), Normalizable (Sort (a :++ b)))++type family Append (xs :: [k]) (ys :: [k]) :: [k] where+  Append '[] ys = ys+  Append (x ': xs) ys = x ': Append xs ys++type (xs :: [k]) :++ (ys :: [k]) = Append xs ys++append :: Dict xs -> Dict ys -> Dict (xs :++ ys)+append Empty ys = ys+append (Ext x xs) ys = Ext x (append xs ys)++type family Normalize d :: [*] where+  Normalize '[]           = '[]+  Normalize '[kv]         = '[kv]+  Normalize ((k :-> v1) ': (k :-> v2) ': d) = Normalize ((k :-> v2) ': d) -- select last one+  Normalize (kv1 ': kv2 ': d) = kv1 ': Normalize (kv2 ': d)++class Normalizable d where+  normalize :: Dict d -> Dict (Normalize d)+instance Normalizable '[] where+  normalize d = d+instance Normalizable '[kv] where+  normalize d = d+#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPABLE #-} (Normalize (x ': y ': d) ~ (x ': Normalize (y ': d)), Normalizable (y ': d)) => Normalizable (x ': y ': d) where+#else+instance                      (Normalize (x ': y ': d) ~ (x ': Normalize (y ': d)), Normalizable (y ': d)) => Normalizable (x ': y ': d) where+#endif+  normalize (Ext x d) = Ext x (normalize d)+#if MIN_VERSION_base(4,8,0)+instance {-# OVERLAPPING #-} Normalizable ((k :-> v2) ': d) => Normalizable ((k :-> v1) ': (k :-> v2) ': d) where+#else+instance                     Normalizable ((k :-> v2) ': d) => Normalizable ((k :-> v1) ': (k :-> v2) ': d) where+#endif+  normalize (Ext _ d) = normalize d++type family Sort (xs :: [k]) :: [k] where+  Sort '[]       = '[]+  Sort (x ': xs) = Sort (Filter 'FMin x xs) :++ '[x] :++ Sort (Filter 'FMax x xs)++data Flag = FMin | FMax++type family Cmp (a :: k) (b :: k) :: Ordering+type instance Cmp (k1 :-> v1) (k2 :-> v2) = CmpSymbol k1 k2++type family Filter (f :: Flag) (p :: k) (xs :: [k]) :: [k] where+  Filter f    p '[]       = '[]+  Filter 'FMin p (x ': xs) = If (Cmp x p == 'LT) (x ': Filter 'FMin p xs) (Filter 'FMin p xs)+  Filter 'FMax p (x ': xs) = If (Cmp x p == 'GT || Cmp x p == 'EQ) (x ': Filter 'FMax p xs) (Filter 'FMax p xs)++class Sortable xs where+  quicksort :: Dict xs -> Dict (Sort xs)+instance Sortable '[] where+  quicksort Empty = Empty+instance ( Sortable (Filter 'FMin p xs)+         , Sortable (Filter 'FMax p xs)+         , FilterV 'FMin p xs+         , FilterV 'FMax p xs) => Sortable (p ': xs) where+  quicksort (Ext p xs) = quicksort (less p xs) `append`+                         Ext p Empty           `append`+                         quicksort (more p xs) where+    less = filterV (Proxy :: Proxy 'FMin)+    more = filterV (Proxy :: Proxy 'FMax)++class FilterV (f::Flag) p xs where+  filterV :: Proxy f -> p -> Dict xs -> Dict (Filter f p xs)+instance FilterV f p '[] where+  filterV _ _ _ = Empty++class Conder g where+  cond :: Proxy g -> Dict s -> Dict t -> Dict (If g s t)+instance Conder 'True where+  cond _ s _ = s+instance Conder 'False where+  cond _ _ t = t++instance (Conder (Cmp x p == 'LT), FilterV 'FMin p xs) => FilterV 'FMin p (x ': xs) where+  filterV f@Proxy p (Ext x xs) =+    cond+    (Proxy :: Proxy (Cmp x p == 'LT))+    (Ext x (filterV f p xs))+    (filterV f p xs)+instance (Conder (Cmp x p == 'GT || Cmp x p == 'EQ), FilterV 'FMax p xs) => FilterV 'FMax p (x ': xs) where+  filterV f@Proxy p (Ext x xs) =+    cond+    (Proxy :: Proxy (Cmp x p == 'GT || Cmp x p == 'EQ))+    (Ext x (filterV f p xs))+    (filterV f p xs)
+ src/Text/Haiji/Parse.hs view
@@ -0,0 +1,78 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE DataKinds #-}+module Text.Haiji.Parse+       ( Jinja2(..)+       , parseString+       , parseFile+       ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Trans.Maybe+import Data.Attoparsec.Text+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as LT++import Text.Haiji.Syntax++data Jinja2 =+  Jinja2+  { jinja2Base :: [AST 'Fully]+  , jinja2Child :: [AST 'Fully]+  } deriving (Eq, Show)++toJinja2 :: [AST 'Fully] -> Jinja2+toJinja2 (Base base : asts) = tmpl { jinja2Child = jinja2Child tmpl ++ asts } where+  tmpl = toJinja2 base+toJinja2 asts = Jinja2 { jinja2Base = asts, jinja2Child = [] }++parseString :: String -> IO Jinja2+parseString = (toJinja2 <$>) . either error readAllFile . parseOnly parser . T.pack++parseFileWith :: (LT.Text -> LT.Text) -> FilePath -> IO Jinja2+parseFileWith f file = LT.readFile file >>= parseString . LT.unpack . f++readAllFile :: [AST 'Partially] -> IO [AST 'Fully]+readAllFile asts = concat <$> mapM parseFileRecursively asts++parseFileRecursively :: AST 'Partially -> IO [AST 'Fully]+parseFileRecursively (Literal l) = return [ Literal l ]+parseFileRecursively (Eval v) = return [ Eval v ]+parseFileRecursively (Condition p ts fs) =+  ((:[]) .) . Condition p+  <$> readAllFile ts+  <*> runMaybeT (maybe mzero return fs >>= lift . readAllFile)+parseFileRecursively (Foreach k xs loopBody elseBody) =+  ((:[]) .) . Foreach k xs+  <$> readAllFile loopBody+  <*> runMaybeT (maybe mzero return elseBody >>= lift . readAllFile)+parseFileRecursively (Include includeFile) = jinja2Base <$> parseIncludeFile includeFile+parseFileRecursively (Raw content) = return [ Raw content ]+parseFileRecursively (Extends extendsfile) = (:[]) . Base . jinja2Base <$> parseFile extendsfile+parseFileRecursively (Block base name scoped body) =+  (:[]) . Block base name scoped <$> readAllFile body+parseFileRecursively Super = return [ Super ]+parseFileRecursively (Comment c) = return [ Comment c ]++parseFile :: FilePath -> IO Jinja2+parseFile = parseFileWith deleteLastOneLF where+  deleteLastOneLF :: LT.Text -> LT.Text+  deleteLastOneLF xs+    | "%}\n" `LT.isSuffixOf` xs     = LT.init xs+    | "\n\n" `LT.isSuffixOf` xs     = LT.init xs+    | not ("\n" `LT.isSuffixOf` xs) = xs `LT.append` "\n"+    | otherwise                     = xs++parseIncludeFile :: FilePath -> IO Jinja2+parseIncludeFile = parseFileWith deleteLastOneLF where+  deleteLastOneLF xs+    | LT.null xs         = xs+    | LT.last xs == '\n' = LT.init xs+    | otherwise          = xs
+ src/Text/Haiji/Runtime.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+-- |+-- Module      : Text.Haiji.Runtime+-- Copyright   : 2015 Noriyuki OHKAWA+-- License     : BSD3+--+-- Maintainer  : n.ohkawa@gmail.com+-- Stability   : experimental+-- Portability : portable+module Text.Haiji.Runtime+       ( readTemplateFile+       ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Monad.Trans.Reader+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import Data.Maybe+import qualified Data.HashMap.Strict as HM+import Data.Scientific+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Vector as V+import Text.Haiji.Parse+import Text.Haiji.Syntax+import Text.Haiji.Types++-- | Dynamically template loader (for template development use)+readTemplateFile :: Environment -> FilePath -> IO (Template JSON.Value)+readTemplateFile env file = unsafeTemplate env <$> parseFile file++unsafeTemplate :: Environment -> Jinja2 -> Template JSON.Value+unsafeTemplate env tmpl = Template $ haijiASTs env Nothing (jinja2Child tmpl) (jinja2Base tmpl)++haijiASTs :: Environment -> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> Reader JSON.Value LT.Text+haijiASTs env parentBlock children asts = LT.concat <$> sequence (map (haijiAST env parentBlock children) asts)++haijiAST :: Environment -> Maybe [AST 'Fully] -> [AST 'Fully] -> AST 'Fully -> Reader JSON.Value LT.Text+haijiAST _env _parentBlock _children (Literal l) =+  return $ LT.fromStrict l+haijiAST  env _parentBlock _children (Eval x) =+  do let esc = if autoEscape env then htmlEscape else rawEscape+     obj <- eval x+     case obj of+       JSON.String s -> return $ (`escapeBy` esc) $ toLT s+       JSON.Number n -> case floatingOrInteger n of+         Left  r -> const undefined (r :: Double)+         Right i -> return $ (`escapeBy` esc) $ toLT (i :: Integer)+       _ -> undefined+haijiAST  env  parentBlock  children (Condition p ts fs) =+  do JSON.Bool cond <- eval p+     if cond+     then haijiASTs env parentBlock children ts+     else maybe (return "") (haijiASTs env parentBlock children) fs+haijiAST  env  parentBlock  children (Foreach k xs loopBody elseBody) =+  do JSON.Array dicts <- eval xs+     p <- ask+     let len = V.length dicts+     if 0 < len+     then return $ LT.concat+                   [ runReader (haijiASTs env parentBlock children loopBody)+                     (let JSON.Object obj = p+                      in  JSON.Object+                          $ HM.insert "loop" (loopVariables len ix)+                          $ HM.insert (T.pack $ show k) x+                          $ obj)+                   | (ix, x) <- zip [0..] (V.toList dicts)+                   ]+     else maybe (return "") (haijiASTs env parentBlock children) elseBody++haijiAST _env _parentBlock _children (Raw raw) = return $ LT.pack raw+haijiAST _env _parentBlock _children (Base _asts) = undefined+haijiAST  env  parentBlock  children (Block _base name _scoped body) =+  case listToMaybe [ b | Block _ n _ b <- children, n == name ] of+    Nothing    -> haijiASTs env parentBlock children body+    Just child -> haijiASTs env (Just body) children child+haijiAST  env  parentBlock  children Super = maybe (error "invalid super()") (haijiASTs env Nothing children) parentBlock+haijiAST _env _parentBlock _children (Comment _) = return ""++loopVariables :: Int -> Int -> JSON.Value+loopVariables len ix = JSON.object [ "first"     JSON..= (ix == 0)+                                   , "index"     JSON..= (ix + 1)+                                   , "index0"    JSON..= ix+                                   , "last"      JSON..= (ix == len - 1)+                                   , "length"    JSON..= len+                                   , "revindex"  JSON..= (len - ix)+                                   , "revindex0" JSON..= (len - ix - 1)+                                   ]++eval :: Expression -> Reader JSON.Value JSON.Value+eval (Expression var _) = deref var++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
+ src/Text/Haiji/Syntax.hs view
@@ -0,0 +1,13 @@+module Text.Haiji.Syntax+       ( Expression(..)+       , Identifier+       , Variable(..)+       , AST(..)+       , Loaded(..)+       , parser+       ) where++import Text.Haiji.Syntax.AST+import Text.Haiji.Syntax.Identifier+import Text.Haiji.Syntax.Expression+import Text.Haiji.Syntax.Variable
+ src/Text/Haiji/Syntax/AST.hs view
@@ -0,0 +1,442 @@+{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE OverloadedStrings #-}+module Text.Haiji.Syntax.AST+       ( AST(..)+       , Loaded(..)+       , parser+       ) where++import Control.Applicative+import Control.Monad+import Control.Monad.State.Strict+import Data.Attoparsec.Text+import Data.Char+import Data.Maybe+import qualified Data.Text as T++import Text.Haiji.Syntax.Identifier+import Text.Haiji.Syntax.Expression++-- $setup+-- >>> :set -XOverloadedStrings+-- >>> let execHaijiParser p = snd <$> runHaijiParser p++type Scoped = Bool++type Base = Bool++data Loaded = Fully+            | Partially++data AST :: Loaded -> * where+  Literal :: T.Text -> AST a+  Eval :: Expression -> AST a+  Condition :: Expression -> [AST a] -> Maybe [AST a] -> AST a+  Foreach :: Identifier -> Expression -> [AST a] -> Maybe [AST a] -> AST a+  Include :: FilePath -> AST 'Partially+  Raw :: String -> AST a+  Extends :: FilePath -> AST 'Partially+  Base :: [AST 'Fully] -> AST 'Fully+  Block :: Base -> Identifier -> Scoped -> [AST a] -> AST a+  Super :: AST a+  Comment :: String -> AST a++deriving instance Eq (AST a)++instance Show (AST a) where+  show (Literal l) = T.unpack l+  show (Eval v) = "{{ " ++ shows v " }}"+  show (Condition p ts mfs) =+    "{% if " ++ show p ++ " %}" +++    concatMap show ts +++    maybe "" (\fs -> "{% else %}" ++ concatMap show fs) mfs +++    "{% endif %}"+  show (Foreach x xs loopBody elseBody) =+    "{% for " ++ show x ++ " in " ++ show xs ++ " %}" +++    concatMap show loopBody +++    maybe "" (("{% else %}" ++) . concatMap show) elseBody +++    "{% endfor %}"+  show (Include file) = "{% include \"" ++ file ++ "\" %}"+  show (Raw content) = "{% raw %}" ++ content ++ "{% endraw %}"+  show (Extends file) = "{% extends \"" ++ file ++ "\" %}"+  show (Base asts) = concatMap show asts+  show (Block _ name scoped body) =+    "{% block " ++ show name ++ (if scoped then " scoped" else "") ++" %}" +++    concatMap show body +++    "{% endblock %}"+  show Super = "{{ super() }}"+  show (Comment c) = "{#" ++ c ++ "#}"++data ParserState =+  ParserState+  { parserStateLeadingSpaces :: Maybe (AST 'Partially)+  , parserStateInBaseTemplate :: Bool+  } deriving (Eq, Show)++defaultParserState :: ParserState+defaultParserState =+  ParserState+  { parserStateLeadingSpaces = Nothing+  , parserStateInBaseTemplate = True+  }++newtype HaijiParser a =+  HaijiParser+  { unHaijiParser :: StateT ParserState Parser a+  } deriving (Functor, Applicative, Alternative, Monad, MonadState ParserState)++runHaijiParser :: HaijiParser a -> Parser (a, ParserState)+runHaijiParser p = runStateT (unHaijiParser p) defaultParserState++evalHaijiParser :: HaijiParser a -> Parser a+evalHaijiParser p = fst <$> runHaijiParser p++liftParser :: Parser a -> HaijiParser a+liftParser = HaijiParser . lift++saveLeadingSpaces :: HaijiParser ()+saveLeadingSpaces = liftParser leadingSpaces >>= setLeadingSpaces where+  leadingSpaces = option Nothing (Just . Literal <$> takeWhile1 isSpace)++withLeadingSpacesOf :: HaijiParser a -> (a -> HaijiParser b) -> HaijiParser b+withLeadingSpacesOf p q = do+  a <- p+  getLeadingSpaces >>= (q a <*) . setLeadingSpaces++setLeadingSpaces :: Maybe (AST 'Partially) -> HaijiParser ()+setLeadingSpaces ss = modify (\s -> s { parserStateLeadingSpaces = ss })++resetLeadingSpaces :: HaijiParser ()+resetLeadingSpaces = setLeadingSpaces Nothing++getLeadingSpaces :: HaijiParser (Maybe (AST 'Partially))+getLeadingSpaces = gets parserStateLeadingSpaces++setWhetherBaseTemplate :: Bool -> HaijiParser ()+setWhetherBaseTemplate x = modify (\s -> s { parserStateInBaseTemplate = x })++getWhetherBaseTemplate :: HaijiParser Bool+getWhetherBaseTemplate = gets parserStateInBaseTemplate++parser :: Parser [AST 'Partially]+parser = evalHaijiParser (haijiParser <* liftParser endOfInput)++haijiParser :: HaijiParser [AST 'Partially]+haijiParser = concat <$> many (resetLeadingSpaces *> choice (map toList parsers)) where+  parsers = [ literal+            , evaluation+            , condition+            , foreach+            , include+            , raw+            , extends+            , block+            , super+            , comment+            ]+  toList p = do+    b <- p+    a <- getLeadingSpaces+    return $ maybe id (:) a [b]++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser literal)+-- >>> eval "テスト{test"+-- テスト+-- >>> eval "   テスト  {test"+--    テスト+-- >>> eval "   テスト  {%-test"+--    テスト+-- >>> eval "   テスト  テスト  {%-test"+--    テスト  テスト+--+literal :: HaijiParser (AST 'Partially)+literal = liftParser $ Literal . T.concat <$> many1 go where+  go = do+    sp <- takeTill (not . isSpace)+    pc <- peekChar+    case pc of+      Nothing  -> if T.null sp then fail "literal" else return sp+      Just '{' -> fail "literal"+      _        -> T.append sp <$> takeWhile1 (\c -> c /= '{' && not (isSpace c))++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser evaluation)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser evaluation)+-- >>> eval "{{ foo }}"+-- {{ foo }}+-- >>> exec "{{ foo }}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{{bar}}"+-- {{ bar }}+-- >>> eval "{{   baz}}"+-- {{ baz }}+-- >>> eval " {{ foo }}"+-- {{ foo }}+-- >>> exec " {{ foo }}"+-- ParserState {parserStateLeadingSpaces = Just  , parserStateInBaseTemplate = True}+-- >>> eval "{ { foo }}"+-- *** Exception: parse error+-- >>> eval "{{ foo } }"+-- *** Exception: parse error+-- >>> eval "{{ foo }} "+-- {{ foo }}+--+evaluation :: HaijiParser (AST 'Partially)+evaluation = saveLeadingSpaces *> liftParser deref where+  deref = Eval <$> ((string "{{" >> skipSpace) *> expression <* (skipSpace >> string "}}"))++-- |+--+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser $ statement $ return ())+-- >>> exec "{%%}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> exec "{% %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> exec " {% %} "+-- ParserState {parserStateLeadingSpaces = Just  , parserStateInBaseTemplate = True}+-- >>> exec " {%- -%} "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+statement :: Parser a -> HaijiParser a+statement f = start "{%" <|> (start "{%-" <* resetLeadingSpaces) where+  start s = saveLeadingSpaces *> liftParser ((string s  >> skipSpace) *> f <* (skipSpace >> end))+  end = string "%}" <|> (string "-%}" <* skipSpace)++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser condition)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser condition)+-- >>> eval "{% if foo %}テスト{% endif %}"+-- {% if foo %}テスト{% endif %}+-- >>> exec "{% if foo %}テスト{% endif %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{%if foo%}テスト{%endif%}"+-- {% if foo %}テスト{% endif %}+-- >>> eval "{% iffoo %}テスト{% endif %}"+-- *** Exception: parse error+-- >>> eval "{% if foo %}真{% else %}偽{% endif %}"+-- {% if foo %}真{% else %}偽{% endif %}+-- >>> eval "{%if foo%}{%if bar%}{%else%}{%endif%}{%else%}{%if baz%}{%else%}{%endif%}{%endif%}"+-- {% if foo %}{% if bar %}{% else %}{% endif %}{% else %}{% if baz %}{% else %}{% endif %}{% endif %}+-- >>> eval "    {% if foo %}テスト{% endif %}"+-- {% if foo %}テスト{% endif %}+-- >>> exec "    {% if foo %}テスト{% endif %}"+-- ParserState {parserStateLeadingSpaces = Just     , parserStateInBaseTemplate = True}+-- >>> eval "    {%- if foo -%}    テスト    {%- endif -%}    "+-- {% if foo %}テスト{% endif %}+-- >>> exec "    {%- if foo -%}    テスト    {%- endif -%}    "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+condition :: HaijiParser (AST 'Partially)+condition = withLeadingSpacesOf start rest where+  start = statement $ string "if" >> skipMany1 space >> expression+  rest cond = do+    ifPart <- haijiParser+    mElsePart <- mayElse+    leadingElseSpaces <- getLeadingSpaces+    _ <- statement $ string "endif"+    leadingEndIfSpaces <- getLeadingSpaces+    return $ case mElsePart of+      Nothing       -> Condition cond (ifPart ++ maybeToList leadingEndIfSpaces) Nothing+      Just elsePart -> Condition cond (ifPart ++ maybeToList leadingElseSpaces ) (Just $ elsePart ++ maybeToList leadingEndIfSpaces)++mayElse :: HaijiParser (Maybe [AST 'Partially])+mayElse = option Nothing (Just <$> elseParser) where+  elseParser = withLeadingSpacesOf (statement (string "else")) $ const haijiParser++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser foreach)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser foreach)+-- >>> eval "{% for _ in foo %}loop{% endfor %}"+-- {% for _ in foo %}loop{% endfor %}+-- >>> exec "{% for _ in foo %}loop{% endfor %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{%for _ in foo%}loop{%endfor%}"+-- {% for _ in foo %}loop{% endfor %}+-- >>> eval "{% for_ in foo %}loop{% endfor %}"+-- *** Exception: parse error+-- >>> eval "{% for _in foo %}loop{% endfor %}"+-- *** Exception: parse error+-- >>> eval "{% for _ infoo %}loop{% endfor %}"+-- *** Exception: parse error+-- >>> eval "{% for _ in foo %}loop{% else %}else block{% endfor %}"+-- {% for _ in foo %}loop{% else %}else block{% endfor %}+-- >>> eval "{%for _ in foo%}loop{%else%}else block{%endfor%}"+-- {% for _ in foo %}loop{% else %}else block{% endfor %}+-- >>> eval "  {% for _ in foo %}  loop  {% endfor %}  "+-- {% for _ in foo %}  loop  {% endfor %}+-- >>> exec "  {% for _ in foo %}  loop  {% endfor %}  "+-- ParserState {parserStateLeadingSpaces = Just   , parserStateInBaseTemplate = True}+-- >>> eval "  {%- for _ in foo -%}  loop  {%- endfor -%}  "+-- {% for _ in foo %}loop{% endfor %}+-- >>> exec "  {%- for _ in foo -%}  loop  {%- endfor -%}  "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+foreach :: HaijiParser (AST 'Partially)+foreach = withLeadingSpacesOf start rest where+  start = statement $ Foreach+          <$> (string "for" >> skipMany1 space >> identifier)+          <*> (skipMany1 space >> string "in" >> skipMany1 space >> expression)+  rest f = do+    loopPart <- haijiParser+    mElsePart <- mayElse+    leadingElseSpaces <- getLeadingSpaces+    _ <- statement (string "endfor")+    leadingEndForSpaces <- getLeadingSpaces+    return $ case mElsePart of+      Nothing       -> f (loopPart ++ maybeToList leadingEndForSpaces) Nothing+      Just elsePart -> f (loopPart ++ maybeToList leadingElseSpaces  ) (Just $ elsePart ++ maybeToList leadingEndForSpaces)++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser include)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser include)+-- >>> eval "{% include \"foo.tmpl\" %}"+-- {% include "foo.tmpl" %}+-- >>> exec "{% include \"foo.tmpl\" %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{%include\"foo.tmpl\"%}"+-- {% include "foo.tmpl" %}+-- >>> eval "{% include 'foo.tmpl' %}"+-- {% include "foo.tmpl" %}+-- >>> eval "  {% include \"foo.tmpl\" %}"+-- {% include "foo.tmpl" %}+-- >>> exec "  {% include \"foo.tmpl\" %}"+-- ParserState {parserStateLeadingSpaces = Just   , parserStateInBaseTemplate = True}+-- >>> eval "  {%- include \"foo.tmpl\" -%}   "+-- {% include "foo.tmpl" %}+-- >>> exec "  {%- include \"foo.tmpl\" -%}   "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+include :: HaijiParser (AST 'Partially)+include = statement $ string "include" >> skipSpace >> Include . T.unpack <$> (quotedBy '"' <|> quotedBy '\'') where+    quotedBy c = char c *> takeTill (== c) <* char c -- TODO: ここもっとマジメにやらないと++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser raw)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser raw)+-- >>> eval "{% raw %}test{% endraw %}"+-- {% raw %}test{% endraw %}+-- >>> exec "{% raw %}test{% endraw %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{%raw%}test{%endraw%}"+-- {% raw %}test{% endraw %}+-- >>> eval "{% raw %}{{ test }}{% endraw %}"+-- {% raw %}{{ test }}{% endraw %}+-- >>> eval "  {% raw %}  test  {% endraw %}"+-- {% raw %}  test  {% endraw %}+-- >>> exec "  {% raw %}  test  {% endraw %}"+-- ParserState {parserStateLeadingSpaces = Just   , parserStateInBaseTemplate = True}+-- >>> eval "  {%- raw -%}   test  {%- endraw -%}  "+-- {% raw %}test{% endraw %}+-- >>> exec "  {%- raw -%}   test  {%- endraw -%}  "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+raw :: HaijiParser (AST 'Partially)+raw = withLeadingSpacesOf start rest where+  start = statement $ string "raw"+  rest _ = do+    (content, leadingEndRawSpaces) <- till (liftParser anyChar) (statement (string "endraw") >> getLeadingSpaces)+    return $ Raw $ content ++ maybe "" show leadingEndRawSpaces where+      till :: Alternative f => f a -> f b -> f ([a], b)+      till p end = go where+        go = ((,) [] <$> end) <|> ((\a (as,b) -> (a:as, b)) <$> p <*> go)++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser extends)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser extends)+-- >>> eval "{% extends \"foo.tmpl\" %}"+-- {% extends "foo.tmpl" %}+-- >>> exec "{% extends \"foo.tmpl\" %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = False}+-- >>> eval "{%extends\"foo.tmpl\"%}"+-- {% extends "foo.tmpl" %}+-- >>> eval "{% extends 'foo.tmpl' %}"+-- {% extends "foo.tmpl" %}+-- >>> eval "  {% extends \"foo.tmpl\" %}"+-- {% extends "foo.tmpl" %}+-- >>> exec "  {% extends \"foo.tmpl\" %}"+-- ParserState {parserStateLeadingSpaces = Just   , parserStateInBaseTemplate = False}+-- >>> eval "  {%- extends \"foo.tmpl\" -%}   "+-- {% extends "foo.tmpl" %}+-- >>> exec "  {%- extends \"foo.tmpl\" -%}   "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = False}+--+extends :: HaijiParser (AST 'Partially)+extends = do+  base <- getWhetherBaseTemplate+  unless base $ fail "extends"+  go <* setWhetherBaseTemplate False where+    go = statement $ string "extends" >> skipSpace >> Extends . T.unpack <$> (quotedBy '"' <|> quotedBy '\'')+    quotedBy c = char c *> takeTill (== c) <* char c -- TODO: ここもっとマジメにやらないと++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser block)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser block)+-- >>> eval "{% block foo %}テスト{% endblock %}"+-- {% block foo %}テスト{% endblock %}+-- >>> exec "{% block foo %}テスト{% endblock %}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "{% block foo %}テスト{% endblock foo %}"+-- {% block foo %}テスト{% endblock %}+-- >>> eval "{% block foo %}テスト{% endblock bar %}"+-- *** Exception: parse error+-- >>> eval "{%block foo%}テスト{%endblock%}"+-- {% block foo %}テスト{% endblock %}+-- >>> eval "{% blockfoo %}テスト{% endblock %}"+-- *** Exception: parse error+-- >>> eval "    {% block foo %}テスト{% endblock %}"+-- {% block foo %}テスト{% endblock %}+-- >>> exec "    {% block foo %}テスト{% endblock %}"+-- ParserState {parserStateLeadingSpaces = Just     , parserStateInBaseTemplate = True}+-- >>> eval "    {%- block foo -%}    テスト    {%- endblock -%}    "+-- {% block foo %}テスト{% endblock %}+-- >>> exec "    {%- block foo -%}    テスト    {%- endblock -%}    "+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+--+block :: HaijiParser (AST 'Partially)+block = withLeadingSpacesOf start rest where+  start = statement $ string "block" >> skipMany1 space >> identifier+  rest name = do+    body <- haijiParser+    mayEndName <- statement $ string "endblock" >> option Nothing (Just <$> (skipMany1 space >> identifier))+    leadingEndBlockSpaces <- getLeadingSpaces+    base <- getWhetherBaseTemplate+    if maybe True (name ==) mayEndName+      then return $ Block base name False (body ++ maybeToList leadingEndBlockSpaces)+      else fail "block"++super :: HaijiParser (AST 'Partially)+super = do+  saveLeadingSpaces+  _ <- liftParser ((string "{{" *> skipSpace) *>+                   (string "super" *> skipSpace >> char '(' >> skipSpace >> char ')') <*+                   (skipSpace *> string "}}"))+  return Super++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly (evalHaijiParser comment)+-- >>> let exec = either (error "parse error") id . parseOnly (execHaijiParser comment)+-- >>> eval "{# comment #}"+-- {# comment #}+-- >>> exec "{# comment #}"+-- ParserState {parserStateLeadingSpaces = Nothing, parserStateInBaseTemplate = True}+-- >>> eval "  {# comment #}"+-- {# comment #}+-- >>> exec "  {# comment #}"+-- ParserState {parserStateLeadingSpaces = Just   , parserStateInBaseTemplate = True}+--+comment :: HaijiParser (AST 'Partially)+comment = saveLeadingSpaces *> liftParser (string "{#" >> Comment <$> manyTill anyChar (string "#}"))
+ src/Text/Haiji/Syntax/Expression.hs view
@@ -0,0 +1,25 @@+{-# LANGUAGE CPP #-}+module Text.Haiji.Syntax.Expression+       ( Expression(..)+       , expression+       ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Data.Attoparsec.Text+import Text.Haiji.Syntax.Variable++data Filter = Filter deriving Eq++instance Show Filter where+  show _ = ""++data Expression = Expression Variable [Filter] deriving Eq++instance Show Expression where+  show (Expression var fs) = show var ++ concat [ '|' : show f | f <- fs ]++expression :: Parser Expression+expression = Expression <$> variable <*> return [] -- many (skipSpace >> char '|' >> skipSpace >> filter)
+ src/Text/Haiji/Syntax/Identifier.hs view
@@ -0,0 +1,72 @@+module Text.Haiji.Syntax.Identifier+       ( Identifier+       , identifier+       ) where++import Control.Applicative+import Control.Monad+import Data.Attoparsec.Text+import Data.String++newtype Identifier = Identifier { unIdentifier :: String } deriving Eq++instance Show Identifier where+  show = unIdentifier++instance IsString Identifier where+  fromString = Identifier++-- | python identifier+--+-- https://docs.python.org/2.7/reference/lexical_analysis.html#identifiers+--+-- >>> let eval = either (error "parse error") id . parseOnly identifier+-- >>> eval "a"+-- a+-- >>> eval "ab"+-- ab+-- >>> eval "A"+-- A+-- >>> eval "Ab"+-- Ab+-- >>> eval "_"+-- _+-- >>> eval "_a"+-- _a+-- >>> eval "_1"+-- _1+-- >>> eval "__"+-- __+-- >>> eval "_ "+-- _+-- >>> eval " _"+-- *** Exception: parse error+-- >>> eval "and"+-- *** Exception: parse error+-- >>> eval "1"+-- *** Exception: parse error+-- >>> eval "1b"+-- *** Exception: parse error+-- >>> eval "'x"+-- *** Exception: parse error+--+identifier :: Parser Identifier+identifier = do+  h <- letter <|> char '_'+  ts <- many (letter <|> digit <|> char '_')+  let candidate = h : ts+  when (candidate `elem` keywords) $ fail "identifier"+  return $ Identifier candidate++-- | python keywords+--+-- https://docs.python.org/2.7/reference/lexical_analysis.html#keywords+--+keywords :: [String]+keywords = words "and       del       from      not       while \+                 \as        elif      global    or        with  \+                 \assert    else      if        pass      yield \+                 \break     except    import    print           \+                 \class     exec      in        raise           \+                 \continue  finally   is        return          \+                 \def       for       lambda    try             "
+ src/Text/Haiji/Syntax/Variable.hs view
@@ -0,0 +1,53 @@+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++-- |+--+-- >>> let eval = either (error "parse error") id . parseOnly variable+-- >>> eval "foo"+-- foo+-- >>> eval "foo.bar"+-- foo.bar+-- >>> eval "foo.b}}ar"+-- foo.b+-- >>> eval "foo.b ar"+-- foo.b+-- >>> eval "foo.b }ar"+-- foo.b+-- >>> eval " foo.bar"+-- *** Exception: parse error+-- >>> eval "foo.  bar"+-- foo.bar+-- >>> eval "foo  .bar"+-- foo.bar+-- >>> eval "foo.bar  "+-- foo.bar+-- >>> eval "foo.bar  "+-- foo.bar+-- >>> eval "foo.bar.baz"+-- 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
@@ -0,0 +1,112 @@+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE CPP #-}+module Text.Haiji.TH+       ( haiji+       , haijiFile+       , key+       ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative+#endif+import Control.Monad.Trans.Reader+import Data.Maybe+import Language.Haskell.TH+import Language.Haskell.TH.Quote+import Language.Haskell.TH.Syntax hiding (lift)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import Text.Haiji.Parse+import Text.Haiji.Syntax+import Text.Haiji.Dictionary+import Text.Haiji.Types++-- | QuasiQuoter to generate a Haiji template+haiji :: Environment -> QuasiQuoter+haiji env = QuasiQuoter { quoteExp = haijiExp env+                        , quotePat = undefined+                        , quoteType = undefined+                        , quoteDec = undefined+                        }++-- | Generate a Haiji template from external file+haijiFile :: Quasi q => Environment -> FilePath -> q Exp+haijiFile env file = runQ (runIO $ parseFile file) >>= haijiTemplate env++haijiExp :: Quasi q => Environment -> String -> q Exp+haijiExp env str = runQ (runIO $ parseString str) >>= haijiTemplate env++-- | Generate a dictionary with single item+key :: QuasiQuoter+key = QuasiQuoter { quoteExp = \k -> [e| \v -> singleton v (Key :: Key $(litT . strTyLit $ k)) |]+                  , quotePat = undefined+                  , quoteType = undefined+                  , quoteDec = undefined+                  }++haijiTemplate :: Quasi q => Environment -> Jinja2 -> q Exp+haijiTemplate env tmpl = runQ [e| Template $(haijiASTs env Nothing (jinja2Child tmpl) (jinja2Base tmpl)) |]++haijiASTs :: Quasi q => Environment -> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp+haijiASTs env parentBlock children asts = runQ [e| LT.concat <$> sequence $(listE $ map (haijiAST env parentBlock children) asts) |]++haijiAST :: Quasi q => Environment -> Maybe [AST 'Fully] -> [AST 'Fully] -> AST 'Fully -> q Exp+haijiAST _env _parentBlock _children (Literal l) =+  runQ [e| return $(litE $ stringL $ T.unpack l) |]+haijiAST  env _parentBlock _children (Eval x) =+  if autoEscape env+  then runQ [e| (`escapeBy` htmlEscape) . toLT <$> $(eval x) |]+  else runQ [e| (`escapeBy` rawEscape) . toLT <$> $(eval x) |]+haijiAST  env  parentBlock  children (Condition p ts fs) =+  runQ [e| do cond <- $(eval p)+              if cond+              then $(haijiASTs env parentBlock children ts)+              else $(maybe [e| return "" |] (haijiASTs env parentBlock children) fs)+         |]+haijiAST  env  parentBlock  children (Foreach k xs loopBody elseBody) =+  runQ [e| do dicts <- $(eval xs)+              p <- ask+              let len = length dicts+              if 0 < len+              then return $ LT.concat+                            [ runReader $(haijiASTs env parentBlock children loopBody)+                              (p `merge`+                               singleton x (Key :: Key $(litT . strTyLit $ show k)) `merge`+                               singleton (loopVariables len ix) (Key :: Key "loop")+                              )+                            | (ix, x) <- zip [0..] dicts+                            ]+              else $(maybe [e| return "" |] (haijiASTs env parentBlock children) elseBody)+         |]+haijiAST _env _parentBlock _children (Raw raw) = runQ [e| return raw |]+haijiAST _env _parentBlock _children (Base _asts) = undefined+haijiAST  env  parentBlock  children (Block _base name _scoped body) =+  case listToMaybe [ b | Block _ n _ b <- children, n == name ] of+    Nothing    -> haijiASTs env parentBlock children body+    Just child -> haijiASTs env (Just body) children child+haijiAST  env  parentBlock  children Super = maybe (error "invalid super()") (haijiASTs env Nothing children) parentBlock+haijiAST _env _parentBlock _children (Comment _) = runQ [e| return "" |]++loopVariables :: Int -> Int -> Dict '["first" :-> Bool, "index" :-> Int, "index0" :-> Int, "last" :-> Bool, "length" :-> Int, "revindex" :-> Int, "revindex0" :-> Int]+loopVariables len ix =+  Ext (Value (ix == 0)       :: "first"     :-> Bool) $+  Ext (Value (ix + 1)        :: "index"     :-> Int ) $+  Ext (Value ix              :: "index0"    :-> Int ) $+  Ext (Value (ix == len - 1) :: "last"      :-> Bool) $+  Ext (Value len             :: "length"    :-> Int ) $+  Ext (Value (len - ix)      :: "revindex"  :-> Int ) $+  Ext (Value (len - ix - 1)  :: "revindex0" :-> Int ) $+  Empty++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)) |]
+ src/Text/Haiji/Types.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+module Text.Haiji.Types+       ( Template(..)+       , render+       , Environment+       , autoEscape+       , Escape+       , escapeBy+       , rawEscape+       , htmlEscape+       , ToLT+       , toLT+       ) where++import Control.Monad.Trans.Reader+import Data.Default+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT++data Escape = Escape { unEscape :: LT.Text -> LT.Text }++escapeBy :: LT.Text -> Escape -> LT.Text+escapeBy = flip unEscape++rawEscape :: Escape+rawEscape = Escape id++htmlEscape :: Escape+htmlEscape = Escape (LT.concatMap replace) where+  replace '&'  = "&amp;"+  replace '"'  = "&#34;"+  replace '\'' = "&#39;"+  replace '<'  = "&lt;"+  replace '>'  = "&gt;"+  replace h    = LT.singleton h++-- | A template environment+data Environment =+  Environment+  { autoEscape :: Bool -- ^ XML/HTML autoescaping+  } deriving (Eq, Show)++instance Default Environment where+  def = Environment { autoEscape = True+                    }++-- | Haiji template+newtype Template dict = Template { unTmpl :: Reader dict LT.Text }++-- | Render Haiji template with given dictionary+render :: Template dict -> dict -> LT.Text+render = runReader . unTmpl++class ToLT a where toLT :: a -> LT.Text+instance ToLT String  where toLT = LT.pack+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
+ test/doctests.hs view
@@ -0,0 +1,17 @@+module Main ( main ) where++import Test.DocTest++import System.FilePath+import System.Environment++main :: IO ()+main = do+  confDistDir <- fmap (takeDirectory . takeDirectory . takeDirectory) getExecutablePath+  doctest [ "-isrc"+          , "-itest"+          , "-i" ++ confDistDir ++ "/build/autogen/"+          , "-optP-include"+          , "-optP" ++ confDistDir ++ "/build/autogen/cabal_macros.h"+          , "Text.Haiji"+          ]
+ test/tests.hs view
@@ -0,0 +1,225 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE CPP #-}+module Main ( main ) where++#if MIN_VERSION_base(4,8,0)+#else+import Control.Applicative ( (<$>) )+#endif+import Control.Monad+import Text.Haiji+import Text.Haiji.Runtime+import Data.Aeson+import Data.Default+import Data.Monoid+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import qualified Data.Text.Lazy.IO as LT+import System.Exit+import System.Process.Text.Lazy+import Test.Tasty.TH+import Test.Tasty.HUnit++main :: IO ()+main = $(defaultMainGenerator)++jinja2 :: Show a => FilePath -> a -> IO LT.Text+jinja2 template dict = do+  (code, out, err) <- readProcessWithExitCode "python2" [] script+  unless (code == ExitSuccess) $ LT.putStrLn err+  return out where+    script = LT.unlines+             [ "import sys, codecs, json"+             , "from jinja2 import Environment, PackageLoader"+             , "sys.stdout = codecs.lookup('utf_8')[-1](sys.stdout)"+             , "env = Environment(loader=PackageLoader('example', '.'),autoescape=True)"+             , "template = env.get_template('" <> LT.pack template <> "')"+             , "object = json.loads(" <> LT.pack (show $ show dict) <> ")"+             , "print template.render(object),"+             , "exit()"+             ]++case_example :: Assertion+case_example = do+  expected <- jinja2 "example.tmpl" dict+  expected @=? render $(haijiFile def "example.tmpl") dict+  tmpl <- readTemplateFile def "example.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|a_variable|] ("Hello,World!" :: T.Text) `merge`+             [key|navigation|] [ [key|caption|] ("A" :: LT.Text) `merge`+                                 [key|href|] ("content/a.html" :: String)+                               , [key|caption|] ("B" :: LT.Text) `merge`+                                 [key|href|] ("content/b.html" :: String)+                               ] `merge`+             [key|foo|] (1 :: Int) `merge`+             [key|bar|] ("" :: String)++case_empty :: Assertion+case_empty = do+  expected <- jinja2 "test/empty.tmpl" empty+  expected @=? render $(haijiFile def "test/empty.tmpl") empty+  tmpl <- readTemplateFile def "test/empty.tmpl"+  expected @=? render tmpl (toJSON empty)++case_lf1 :: Assertion+case_lf1 = do+  expected <- jinja2 "test/lf1.tmpl" empty+  expected @=? render $(haijiFile def "test/lf1.tmpl") empty+  tmpl <- readTemplateFile def "test/lf1.tmpl"+  expected @=? render tmpl (toJSON empty)++case_lf2 :: Assertion+case_lf2 = do+  expected <- jinja2 "test/lf2.tmpl" empty+  expected @=? render $(haijiFile def "test/lf2.tmpl") empty+  tmpl <- readTemplateFile def "test/lf2.tmpl"+  expected @=? render tmpl (toJSON empty)++case_line_without_newline :: Assertion+case_line_without_newline = do+  expected <- jinja2 "test/line_without_newline.tmpl" empty+  expected @=? render $(haijiFile def "test/line_without_newline.tmpl") empty+  tmpl <- readTemplateFile def "test/line_without_newline.tmpl"+  expected @=? render tmpl (toJSON empty)++case_line_with_newline :: Assertion+case_line_with_newline = do+  expected <- jinja2 "test/line_with_newline.tmpl" empty+  expected @=? render $(haijiFile def "test/line_with_newline.tmpl") empty+  tmpl <- readTemplateFile def "test/line_with_newline.tmpl"+  expected @=? render tmpl (toJSON empty)++case_variables :: Assertion+case_variables = do+  expected <- jinja2 "test/variables.tmpl" dict+  expected @=? render $(haijiFile def "test/variables.tmpl") dict+  tmpl <- readTemplateFile def "test/variables.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ("normal" :: T.Text) `merge`+             [key|_foo|] ("start '_'" :: LT.Text) `merge`+             [key|Foo|] ("start upper case" :: T.Text) `merge`+             [key|F__o_o__|] ("include '_'" :: String) `merge`+             [key|F1a2b3c|] ("include num" :: String)++case_HTML_escape :: Assertion+case_HTML_escape = do+  expected <- jinja2 "test/HTML_escape.tmpl" dict+  expected @=? render $(haijiFile def "test/HTML_escape.tmpl") dict+  tmpl <- readTemplateFile def "test/HTML_escape.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ([' '..'\126'] :: String)++case_condition :: Assertion+case_condition = do+  testCondition True  True  True+  testCondition True  True  False+  testCondition True  False True+  testCondition True  False False+  testCondition False True  True+  testCondition False True  False+  testCondition False False True+  testCondition False False False where+    testCondition foo bar baz = do+      expected <- jinja2 "test/condition.tmpl" dict+      expected @=? render $(haijiFile def "test/condition.tmpl") dict+      tmpl <- readTemplateFile def "test/condition.tmpl"+      expected @=? render tmpl (toJSON dict)+        where+          dict = [key|foo|] foo `merge`+                 [key|bar|] bar `merge`+                 [key|baz|] baz++case_foreach :: Assertion+case_foreach = do+  expected <- jinja2 "test/foreach.tmpl" dict+  expected @=? render $(haijiFile def "test/foreach.tmpl") dict+  tmpl <- readTemplateFile def "test/foreach.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ([0,2..10] :: [Int])++case_foreach_shadowing :: Assertion+case_foreach_shadowing = do+  expected <- jinja2 "test/foreach.tmpl" dict+  expected @=? render $(haijiFile def "test/foreach.tmpl") dict+  tmpl <- readTemplateFile def "test/foreach.tmpl"+  expected @=? render tmpl (toJSON dict)+  False @=? ("bar" `LT.isInfixOf` expected)+    where+      dict = [key|foo|] ([0,2..10] :: [Int]) `merge`+             [key|bar|] ("bar" :: String)++case_foreach_else_block :: Assertion+case_foreach_else_block = do+  expected <- jinja2 "test/foreach_else_block.tmpl" dict+  expected @=? render $(haijiFile def "test/foreach_else_block.tmpl") dict+  tmpl <- readTemplateFile def "test/foreach_else_block.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ([] :: [Int])++case_include :: Assertion+case_include = do+  testInclude ([0..10] :: [Int])+  testInclude (["","\n","\n\n"] :: [String]) where+    testInclude xs = do+      expected <- jinja2 "test/include.tmpl" dict+      expected @=? render $(haijiFile def "test/include.tmpl") dict+      tmpl <- readTemplateFile def "test/include.tmpl"+      expected @=? render tmpl (toJSON dict)+        where+          dict = [key|foo|] xs++case_raw :: Assertion+case_raw = do+  expected <- jinja2 "test/raw.tmpl" dict+  expected @=? render $(haijiFile def "test/raw.tmpl") dict+  tmpl <- readTemplateFile def "test/raw.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ([0,2..10] :: [Int]) `merge`+             [key|bar|] ("bar" :: String)++case_loop_variables :: Assertion+case_loop_variables = do+  expected <- jinja2 "test/loop_variables.tmpl" dict+  expected @=? render $(haijiFile def "test/loop_variables.tmpl") dict+  tmpl <- readTemplateFile def "test/loop_variables.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ([0,2..10] :: [Integer])++case_whitespace_control :: Assertion+case_whitespace_control = do+  expected <- jinja2 "test/whitespace_control.tmpl" dict+  expected @=? render $(haijiFile def "test/whitespace_control.tmpl") dict+  tmpl <- readTemplateFile def "test/whitespace_control.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|seq|] ([0,2..10] :: [Integer])++case_comment :: Assertion+case_comment = do+  expected <- jinja2 "test/comment.tmpl" dict+  expected @=? render $(haijiFile def "test/comment.tmpl") dict+  tmpl <- readTemplateFile def "test/comment.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|seq|] ([0,2..10] :: [Integer])++case_extends :: Assertion+case_extends = do+  expected <- jinja2 "test/child.tmpl" dict+  expected @=? render $(haijiFile def "test/child.tmpl") dict+  tmpl <- readTemplateFile def "test/child.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|foo|] ("foo" :: T.Text) `merge`+             [key|bar|] ("bar" :: T.Text) `merge`+             [key|baz|] ("baz" :: T.Text)