haiji 0.2.0.0 → 0.2.1.0

raw patch · 7 files changed

+102/−118 lines, 7 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• haiji.cabal +2/−1
• src/Text/Haiji/Dictionary.hs +32/−77
• src/Text/Haiji/Parse.hs +21/−7
• src/Text/Haiji/Runtime.hs +3/−4
• src/Text/Haiji/TH.hs +11/−10
• src/Text/Haiji/Types.hs +0/−1
• test/tests.hs +33/−18

@@ -2,7 +2,7 @@ --  see http://haskell.org/cabal/users-guide/  name:                haiji-version:             0.2.0.0+version:             0.2.1.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@@ -45,6 +45,7 @@                      , unordered-containers                      , scientific                      , data-default+                     , unordered-containers   hs-source-dirs:      src   ghc-options:         -Wall   default-language:    Haskell2010

@@ -1,23 +1,15 @@-{-# LANGUAGE CPP #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE UndecidableInstances #-}-{-# LANGUAGE ConstraintKinds #-}-#if MIN_VERSION_base(4,8,0)-#else-{-# LANGUAGE OverlappingInstances #-}-#endif-{-# LANGUAGE ScopedTypeVariables #-} module Text.Haiji.Dictionary        ( Dict(..)        , toDict-       , (:->)(..)+       , (:->)        , empty        , singleton        , merge@@ -26,8 +18,10 @@        ) where  import Data.Aeson+import Data.Dynamic+import qualified Data.HashMap.Strict as M+import Data.Maybe 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@@ -35,96 +29,57 @@ import Data.Type.Equality import GHC.TypeLits -data Key (k :: Symbol) where Key :: Key k+data Key (k :: Symbol) where+  Key :: KnownSymbol k => Key k  infixl 2 :->-data (k :: Symbol) :-> (v :: *) where Value :: v -> k :-> v--newtype VK v k = VK (k :-> v)+data (k :: Symbol) :-> (v :: *)  -- | Empty dictionary empty :: Dict '[]-empty = Empty+empty = Dict M.empty -singleton :: x -> Key k -> Dict '[ k :-> x ]-singleton x _ = Ext (Value x) Empty+singleton :: Typeable x => x -> Key k -> Dict '[ k :-> x ]+singleton x k = Dict $ M.singleton (keyVal k) (toDyn x)  -- | Create single element dictionary (with TypeApplications extention)-toDict :: forall k x . x -> Dict '[ k :-> x ]+toDict :: (KnownSymbol k, Typeable x) => x -> Dict '[ k :-> x ] toDict = flip singleton Key -value :: k :-> v -> v-value (Value v) = v+keyVal :: Key k -> String+keyVal k = case k of Key -> symbolVal k -key :: KnownSymbol k => k :-> v -> String-key = symbolVal . VK+retrieve :: Typeable (Retrieve xs k) => Dict xs -> Key k -> Retrieve xs k+retrieve (Dict d) k = fromJust $ fromDynamic $ d M.! keyVal k -class Retrieve d k v where-  retrieve :: d -> Key k -> v-#if MIN_VERSION_base(4,8,0)-instance {-# OVERLAPPABLE #-} Retrieve (Dict d) k v => Retrieve (Dict (kv ': d)) k v where-#else-instance                      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 #-} v' ~ v => Retrieve (Dict ((k :-> v') ': d)) k v where-#else-instance                     v' ~ v => Retrieve (Dict ((k :-> v') ': d)) k v where-#endif-  retrieve (Ext (Value v) _) _ = v+type family Retrieve (a :: [*]) (b :: Symbol) where+  Retrieve ((kx :-> vx) ': xs) key = If (CmpSymbol kx key == 'EQ) vx (Retrieve xs key)  -- | Type level Dictionary-data Dict (kv :: [*]) where-  Empty :: Dict '[]-  Ext :: k :-> v -> Dict d -> Dict ((k :-> v) ': d)+data Dict (kv :: [*]) = Dict (M.HashMap String Dynamic)  instance ToJSON (Dict '[]) where-  toJSON Empty = object []+  toJSON _ = object [] -instance (ToJSON (Dict s), ToJSON kv) => ToJSON (Dict (kv ': s)) where-  toJSON (Ext x xs) = Object (a <> b) where-    Object a = toJSON x+instance (ToJSON (Dict d), ToJSON v, KnownSymbol k, Typeable v) => ToJSON (Dict ((k :-> v) ': d)) where+  toJSON dict = Object (a <> b) where+    (x, v, xs) = headKV dict+    Object a = object [ T.pack (keyVal x) .= v ]     Object b = toJSON xs--instance (ToJSON v, KnownSymbol k) => ToJSON (k :-> v) where-  toJSON x = object [ T.pack (key x) .= value x ]+    headKV :: (KnownSymbol k, Typeable v) => Dict ((k :-> v) ': d) -> (Key k, v, Dict d)+    headKV (Dict d) = (k, fromJust $ fromDynamic $ d M.! keyVal k, Dict $ M.delete (keyVal k) d) where+      k = Key  instance ToJSON (Dict s) => Show (Dict s) where   show = LT.unpack . LT.decodeUtf8 . encode -class Mergeable xs ys where-  merge :: Dict xs -> Dict ys -> Dict (Merge xs ys)-instance Mergeable xs '[] where-  merge xs Empty = xs-instance Mergeable '[] (y ': ys) where-  merge Empty ys = ys-instance (Conder (Cmp x y == 'EQ), Conder (Cmp x y == 'LT), Mergeable xs ys, Mergeable (x ': xs) ys, Mergeable xs (y ': ys)) => Mergeable (x ': xs) (y ': ys) where-  merge (Ext x xs) (Ext y ys) = cond (Proxy :: Proxy (Cmp x y == 'EQ))-                                     (Ext y (merge xs ys))-                                     (cond (Proxy :: Proxy (Cmp x y == 'LT))-                                           (Ext x (merge xs (Ext y ys)))-                                           (Ext y (merge (Ext x xs) ys)))+merge :: Dict xs -> Dict ys -> Dict (Merge xs ys)+merge (Dict x) (Dict y) = Dict (y `M.union` x)  type family Merge a b :: [*] where   Merge xs '[] = xs   Merge '[] ys = ys-  Merge (x ': xs) (y ': ys) = If (Cmp x y == 'EQ)-                                  (y ': Merge xs ys) -- select last one-                                  (If (Cmp x y == 'LT)-                                      (x ': Merge xs (y ': ys))-                                      (y ': Merge (x ': xs) ys))--type family Append (xs :: [k]) (ys :: [k]) :: [k] where-  Append '[] ys = ys-  Append (x ': xs) ys = x ': Append xs ys--type family Cmp (a :: k) (b :: k) :: Ordering-type instance Cmp (k1 :-> v1) (k2 :-> v2) = CmpSymbol k1 k2+  Merge (x ': xs) (y ': ys) = If (Cmp x y == 'EQ) (y ': Merge xs ys) (If (Cmp x y == 'LT) (x ': Merge xs (y ': ys)) (y ': Merge (x ': xs) ys)) -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+type family Cmp (a :: k) (b :: k) :: Ordering where+  Cmp (k1 :-> v1) (k2 :-> v2) = CmpSymbol k1 k2

@@ -6,6 +6,7 @@        ( Jinja2(..)        , parseString        , parseFile+       , runQWF        ) where  #if MIN_VERSION_base(4,8,0)@@ -19,6 +20,7 @@ import qualified Data.Text as T import qualified Data.Text.Lazy as LT import qualified Data.Text.Lazy.IO as LT+import Language.Haskell.TH.Syntax hiding (lift)  import Text.Haiji.Syntax @@ -33,16 +35,28 @@   tmpl = toJinja2 base toJinja2 asts = Jinja2 { jinja2Base = asts, jinja2Child = [] } -parseString :: String -> IO Jinja2+parseString :: QuasiWithFile q => String -> q 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+class Quasi q => QuasiWithFile q where+  runQWF :: q a -> Q a+  withFile :: FilePath -> q LT.Text -readAllFile :: [AST 'Partially] -> IO [AST 'Fully]+instance QuasiWithFile IO where+  runQWF = runIO+  withFile file = LT.readFile file++instance QuasiWithFile Q where+  runQWF = id+  withFile file = runQ (addDependentFile file >> runIO (withFile file))++parseFileWith :: QuasiWithFile q => (LT.Text -> LT.Text) -> FilePath -> q Jinja2+parseFileWith f file = withFile file >>= parseString . LT.unpack . f++readAllFile :: QuasiWithFile q => [AST 'Partially] -> q [AST 'Fully] readAllFile asts = concat <$> mapM parseFileRecursively asts -parseFileRecursively :: AST 'Partially -> IO [AST 'Fully]+parseFileRecursively :: QuasiWithFile q => AST 'Partially -> q [AST 'Fully] parseFileRecursively (Literal l) = return [ Literal l ] parseFileRecursively (Eval v) = return [ Eval v ] parseFileRecursively (Condition p ts fs) =@@ -61,7 +75,7 @@ parseFileRecursively Super = return [ Super ] parseFileRecursively (Comment c) = return [ Comment c ] -parseFile :: FilePath -> IO Jinja2+parseFile :: QuasiWithFile q => FilePath -> q Jinja2 parseFile = parseFileWith deleteLastOneLF where   deleteLastOneLF :: LT.Text -> LT.Text   deleteLastOneLF xs@@ -70,7 +84,7 @@     | not ("\n" `LT.isSuffixOf` xs) = xs `LT.append` "\n"     | otherwise                     = xs -parseIncludeFile :: FilePath -> IO Jinja2+parseIncludeFile :: QuasiWithFile q => FilePath -> q Jinja2 parseIncludeFile = parseFileWith deleteLastOneLF where   deleteLastOneLF xs     | LT.null xs         = xs

@@ -39,7 +39,7 @@ 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)+haijiASTs env parentBlock children asts = LT.concat <$> mapM (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) =@@ -50,7 +50,7 @@      case obj of        JSON.String s -> return $ (`escapeBy` esc) $ toLT s        JSON.Number n -> case floatingOrInteger n of-         Left  r -> const undefined (r :: Double)+         Left  r -> undefined          Right i -> return $ (`escapeBy` esc) $ toLT (i :: Integer)        _ -> undefined haijiAST  env  parentBlock  children (Condition p ts fs) =@@ -68,8 +68,7 @@                      (let JSON.Object obj = p                       in  JSON.Object                           $ HM.insert "loop" (loopVariables len ix)-                          $ HM.insert (T.pack $ show k) x-                          $ obj)+                          $ HM.insert (T.pack $ show k) x obj)                    | (ix, x) <- zip [0..] (V.toList dicts)                    ]      else maybe (return "") (haijiASTs env parentBlock children) elseBody

@@ -14,6 +14,8 @@ import Control.Applicative #endif import Control.Monad.Trans.Reader+import Data.Dynamic+import qualified Data.HashMap.Strict as M import Data.Maybe import Language.Haskell.TH import Language.Haskell.TH.Quote@@ -35,7 +37,7 @@  -- | Generate a Haiji template from external file haijiFile :: Quasi q => Environment -> FilePath -> q Exp-haijiFile env file = runQ (runIO $ parseFile file) >>= haijiTemplate env+haijiFile env file = runQ (parseFile file) >>= haijiTemplate env  haijiExp :: Quasi q => Environment -> String -> q Exp haijiExp env str = runQ (runIO $ parseString str) >>= haijiTemplate env@@ -92,15 +94,14 @@ 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+loopVariables len ix = Dict $ M.fromList [ ("first", toDyn (ix == 0))+                                         , ("index", toDyn (ix + 1))+                                         , ("index0", toDyn ix)+                                         , ("last", toDyn (ix == len - 1))+                                         , ("length", toDyn len)+                                         , ("revindex", toDyn (len - ix))+                                         , ("revindex0", toDyn (len - ix - 1))+                                         ]  eval :: Quasi q => Expression -> q Exp eval (Expression var _) = deref var

@@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Text.Haiji.Types        ( Template(..)

@@ -130,24 +130,14 @@       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_condition = forM_ (replicateM 3 [True, False]) $ \[foo, bar, baz] -> do+  let dict = [key|foo|] foo `merge`+             [key|bar|] bar `merge`+             [key|baz|] baz+  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)  case_foreach :: Assertion case_foreach = do@@ -237,3 +227,28 @@       dict = [key|foo|] ("foo" :: T.Text) `merge`              [key|bar|] ("bar" :: T.Text) `merge`              [key|baz|] ("baz" :: T.Text)++case_many_variables :: Assertion+case_many_variables = do+  expected <- jinja2 "test/many_variables.tmpl" dict --+  expected @=? render $(haijiFile def "test/many_variables.tmpl") dict+  tmpl <- readTemplateFile def "test/many_variables.tmpl"+  expected @=? render tmpl (toJSON dict)+    where+      dict = [key|a|] ("b" :: T.Text) `merge`+             [key|b|] ("b" :: LT.Text) `merge`+             [key|c|] ("b" :: LT.Text) `merge`+             [key|d|] ("b" :: LT.Text) `merge`+             [key|e|] ("b" :: LT.Text) `merge`+             [key|f|] ("b" :: LT.Text) `merge`+             [key|g|] ("b" :: LT.Text) `merge`+             [key|h|] ("b" :: LT.Text) `merge`+             [key|i|] ("b" :: LT.Text) `merge`+             [key|j|] ("b" :: LT.Text) `merge`+             [key|k|] ("b" :: LT.Text) `merge`+             [key|l|] ("b" :: LT.Text) `merge`+             [key|m|] ("b" :: LT.Text) `merge`+             [key|n|] ("b" :: LT.Text) `merge`+             [key|o|] ("b" :: LT.Text) `merge`+             [key|p|] ("b" :: LT.Text) `merge`+             [key|q|] ("b" :: LT.Text)