diff --git a/haiji.cabal b/haiji.cabal --- a/haiji.cabal +++ b/haiji.cabal @@ -2,7 +2,7 @@ -- see http://haskell.org/cabal/users-guide/ name: haiji -version: 0.2.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 diff --git a/src/Text/Haiji/Dictionary.hs b/src/Text/Haiji/Dictionary.hs --- a/src/Text/Haiji/Dictionary.hs +++ b/src/Text/Haiji/Dictionary.hs @@ -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 diff --git a/src/Text/Haiji/Parse.hs b/src/Text/Haiji/Parse.hs --- a/src/Text/Haiji/Parse.hs +++ b/src/Text/Haiji/Parse.hs @@ -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 diff --git a/src/Text/Haiji/Runtime.hs b/src/Text/Haiji/Runtime.hs --- a/src/Text/Haiji/Runtime.hs +++ b/src/Text/Haiji/Runtime.hs @@ -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 diff --git a/src/Text/Haiji/TH.hs b/src/Text/Haiji/TH.hs --- a/src/Text/Haiji/TH.hs +++ b/src/Text/Haiji/TH.hs @@ -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 diff --git a/src/Text/Haiji/Types.hs b/src/Text/Haiji/Types.hs --- a/src/Text/Haiji/Types.hs +++ b/src/Text/Haiji/Types.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE FlexibleInstances #-} module Text.Haiji.Types ( Template(..) diff --git a/test/tests.hs b/test/tests.hs --- a/test/tests.hs +++ b/test/tests.hs @@ -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)