{-# 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.Dynamic
import qualified Data.HashMap.Strict as M
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 :: Environment -> QuasiQuoter
haiji Environment
env = QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = forall (q :: * -> *). Quasi q => Environment -> String -> q Exp
haijiExp Environment
env
                        , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => a
undefined
                        , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => a
undefined
                        , quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => a
undefined
                        }

-- | Generate a Haiji template from external file
haijiFile :: Quasi q => Environment -> FilePath -> q Exp
haijiFile :: forall (q :: * -> *). Quasi q => Environment -> String -> q Exp
haijiFile Environment
env String
file = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (forall (q :: * -> *). QuasiWithFile q => String -> q Jinja2
parseFile String
file) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (q :: * -> *). Quasi q => Environment -> Jinja2 -> q Exp
haijiTemplate Environment
env

haijiExp :: Quasi q => Environment -> String -> q Exp
haijiExp :: forall (q :: * -> *). Quasi q => Environment -> String -> q Exp
haijiExp Environment
env String
str = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ (forall a. IO a -> Q a
runIO forall a b. (a -> b) -> a -> b
$ forall (q :: * -> *). QuasiWithFile q => String -> q Jinja2
parseString String
str) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (q :: * -> *). Quasi q => Environment -> Jinja2 -> q Exp
haijiTemplate Environment
env

-- | Generate a dictionary with single item
key :: QuasiQuoter
key :: QuasiQuoter
key = QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = \String
k -> [e| \v -> singleton v (Key :: Key $(litT . strTyLit $ k)) |]
                  , quotePat :: String -> Q Pat
quotePat = forall a. HasCallStack => a
undefined
                  , quoteType :: String -> Q Type
quoteType = forall a. HasCallStack => a
undefined
                  , quoteDec :: String -> Q [Dec]
quoteDec = forall a. HasCallStack => a
undefined
                  }

haijiTemplate :: Quasi q => Environment -> Jinja2 -> q Exp
haijiTemplate :: forall (q :: * -> *). Quasi q => Environment -> Jinja2 -> q Exp
haijiTemplate Environment
env Jinja2
tmpl = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| Template $(haijiASTs env Nothing (jinja2Child tmpl) (jinja2Base tmpl)) |]

haijiASTs :: Quasi q => Environment -> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp
haijiASTs :: forall (q :: * -> *).
Quasi q =>
Environment
-> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp
haijiASTs Environment
env Maybe [AST 'Fully]
parentBlock [AST 'Fully]
children [AST 'Fully]
asts = forall (m :: * -> *) a. Quasi m => Q a -> m a
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 :: forall (q :: * -> *).
Quasi q =>
Environment
-> Maybe [AST 'Fully] -> [AST 'Fully] -> AST 'Fully -> q Exp
haijiAST Environment
_env Maybe [AST 'Fully]
_parentBlock [AST 'Fully]
_children (Literal Text
l) =
  forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return $(litE $ stringL $ T.unpack l) |]
haijiAST  Environment
env Maybe [AST 'Fully]
_parentBlock [AST 'Fully]
_children (Eval Expression
x) =
  if Environment -> Bool
autoEscape Environment
env
  then forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (`escapeBy` htmlEscape) . toLT <$> $(eval x) |]
  else forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (`escapeBy` rawEscape) . toLT <$> $(eval x) |]
haijiAST  Environment
env  Maybe [AST 'Fully]
parentBlock  [AST 'Fully]
children (Condition Expression
p [AST 'Fully]
ts Maybe [AST 'Fully]
fs) =
  forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| do cond <- $(eval p)
              if cond
              then $(haijiASTs env parentBlock children ts)
              else $(maybe [e| return "" |] (haijiASTs env parentBlock children) fs)
         |]
haijiAST  Environment
env  Maybe [AST 'Fully]
parentBlock  [AST 'Fully]
children (Foreach Identifier
k Expression
xs [AST 'Fully]
loopBody Maybe [AST 'Fully]
elseBody) =
  forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| do dicts <- $(eval xs)
              p <- ask
              let len = toInteger $ 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 Environment
_env Maybe [AST 'Fully]
_parentBlock [AST 'Fully]
_children (Raw String
raw) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return raw |]
haijiAST Environment
_env Maybe [AST 'Fully]
_parentBlock [AST 'Fully]
_children (Base [AST 'Fully]
_asts) = forall a. HasCallStack => a
undefined
haijiAST  Environment
env  Maybe [AST 'Fully]
parentBlock  [AST 'Fully]
children (Block Bool
_base Identifier
name Bool
_scoped [AST 'Fully]
body) =
  case forall a. [a] -> Maybe a
listToMaybe [ [AST 'Fully]
b | Block Bool
_ Identifier
n Bool
_ [AST 'Fully]
b <- [AST 'Fully]
children, Identifier
n forall a. Eq a => a -> a -> Bool
== Identifier
name ] of
    Maybe [AST 'Fully]
Nothing    -> forall (q :: * -> *).
Quasi q =>
Environment
-> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp
haijiASTs Environment
env Maybe [AST 'Fully]
parentBlock [AST 'Fully]
children [AST 'Fully]
body
    Just [AST 'Fully]
child -> forall (q :: * -> *).
Quasi q =>
Environment
-> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp
haijiASTs Environment
env (forall a. a -> Maybe a
Just [AST 'Fully]
body) [AST 'Fully]
children [AST 'Fully]
child
haijiAST  Environment
env  Maybe [AST 'Fully]
parentBlock  [AST 'Fully]
children AST 'Fully
Super = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"invalid super()") (forall (q :: * -> *).
Quasi q =>
Environment
-> Maybe [AST 'Fully] -> [AST 'Fully] -> [AST 'Fully] -> q Exp
haijiASTs Environment
env forall a. Maybe a
Nothing [AST 'Fully]
children) Maybe [AST 'Fully]
parentBlock
haijiAST Environment
_env Maybe [AST 'Fully]
_parentBlock [AST 'Fully]
_children (Comment String
_) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return "" |]
haijiAST  Environment
env  Maybe [AST 'Fully]
parentBlock  [AST 'Fully]
children (Set Identifier
lhs Expression
rhs [AST 'Fully]
scopes) =
  forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| do val <- $(eval rhs)
              p <- ask
              return $ runReader $(haijiASTs env parentBlock children scopes)
                (p `merge` singleton val (Key :: Key $(litT . strTyLit $ show lhs)))
         |]

loopVariables :: Integer -> Integer -> Dict '["first" :-> Bool, "index" :-> Integer, "index0" :-> Integer, "last" :-> Bool, "length" :-> Integer, "revindex" :-> Integer, "revindex0" :-> Integer]
loopVariables :: Integer
-> Integer
-> Dict
     '["first" :-> Bool, "index" :-> Integer, "index0" :-> Integer,
       "last" :-> Bool, "length" :-> Integer, "revindex" :-> Integer,
       "revindex0" :-> Integer]
loopVariables Integer
len Integer
ix = forall (kv :: [*]). HashMap String Dynamic -> Dict kv
Dict forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
M.fromList [ (String
"first", forall a. Typeable a => a -> Dynamic
toDyn (Integer
ix forall a. Eq a => a -> a -> Bool
== Integer
0))
                                         , (String
"index", forall a. Typeable a => a -> Dynamic
toDyn (Integer
ix forall a. Num a => a -> a -> a
+ Integer
1))
                                         , (String
"index0", forall a. Typeable a => a -> Dynamic
toDyn Integer
ix)
                                         , (String
"last", forall a. Typeable a => a -> Dynamic
toDyn (Integer
ix forall a. Eq a => a -> a -> Bool
== Integer
len forall a. Num a => a -> a -> a
- Integer
1))
                                         , (String
"length", forall a. Typeable a => a -> Dynamic
toDyn Integer
len)
                                         , (String
"revindex", forall a. Typeable a => a -> Dynamic
toDyn (Integer
len forall a. Num a => a -> a -> a
- Integer
ix))
                                         , (String
"revindex0", forall a. Typeable a => a -> Dynamic
toDyn (Integer
len forall a. Num a => a -> a -> a
- Integer
ix forall a. Num a => a -> a -> a
- Integer
1))
                                         ]

eval :: Quasi q => Expression -> q Exp
eval :: forall (q :: * -> *). Quasi q => Expression -> q Exp
eval (Expression Expr External LevelMax
expression) = forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go Expr External LevelMax
expression where
  go :: Quasi q => Expr External level -> q Exp
  go :: forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go (ExprLift Expr External lv
e) = forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go Expr External lv
e
  go (ExprIntegerLiteral Integer
n) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return (n :: Integer) |]
  go (ExprStringLiteral StringLiteral
s) = let x :: String
x = StringLiteral -> String
unwrap StringLiteral
s in forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return (x :: T.Text) |]
  go (ExprBooleanLiteral Bool
b) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| return b |]
  go (ExprVariable Identifier
v) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| retrieve <$> ask <*> return (Key :: Key $(litT . strTyLit $ show v)) |]
  go (ExprParen Expr External LevelMax
e) = forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go Expr External LevelMax
e
  go (ExprRange [Expr External LevelMax
stop]) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (\b -> [0..b-1]) <$> $(go stop) |]
  go (ExprRange [Expr External LevelMax
start, Expr External LevelMax
stop]) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (\a b -> [a..b-1]) <$> $(go start) <*> $(go stop) |]
  go (ExprRange [Expr External LevelMax
start, Expr External LevelMax
stop, Expr External LevelMax
step]) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (\a b c -> [a,a+c..b-1]) <$> $(go start) <*> $(go stop) <*> $(go step) |]
  go (ExprRange [Expr External LevelMax]
_) = forall a. HasCallStack => String -> a
error String
"unreachable"
  go (ExprAttributed Expr External Z
e []) = forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go Expr External Z
e
  go (ExprAttributed Expr External Z
e [Identifier]
attrs) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| retrieve <$> $(go $ ExprAttributed e $ init attrs) <*> return (Key :: Key $(litT . strTyLit $ show $ last attrs)) |]
  go (ExprFiltered Expr External (S Z)
e []) = forall (q :: * -> *) level. Quasi q => Expr External level -> q Exp
go Expr External (S Z)
e
  go (ExprFiltered Expr External (S Z)
e [Filter]
filters) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| $(applyFilter (last filters) $ ExprFiltered e $ init filters) |] where
    applyFilter :: Filter -> Expr External level -> m Exp
applyFilter Filter
FilterAbs Expr External level
e' = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| abs <$> $(go e') |]
    applyFilter Filter
FilterLength Expr External level
e' = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| toInteger . length <$> $(go e') |]
  go (ExprPow Expr External (S (S (S Z)))
e1 Expr External (S (S Z))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (^) <$> $(go e1) <*> $(go e2) |]
  go (ExprMul Expr External (S (S (S (S Z))))
e1 Expr External (S (S (S Z)))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (*) <$> $(go e1) <*> $(go e2) |]
  go (ExprDivF Expr External (S (S (S (S Z))))
e1 Expr External (S (S (S Z)))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (/) <$> $(go e1) <*> $(go e2) |]
  go (ExprDivI Expr External (S (S (S (S Z))))
e1 Expr External (S (S (S Z)))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| div <$> $(go e1) <*> $(go e2) |]
  go (ExprMod Expr External (S (S (S (S Z))))
e1 Expr External (S (S (S Z)))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| mod <$> $(go e1) <*> $(go e2) |]
  go (ExprAdd Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S Z))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (+) <$> $(go e1) <*> $(go e2) |]
  go (ExprSub Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S Z))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (-) <$> $(go e1) <*> $(go e2) |]
  go (ExprEQ Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (==) <$> $(go e1) <*> $(go e2) |]
  go (ExprNEQ Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (/=) <$> $(go e1) <*> $(go e2) |]
  go (ExprGT Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (>) <$> $(go e1) <*> $(go e2) |]
  go (ExprGE Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (>=) <$> $(go e1) <*> $(go e2) |]
  go (ExprLT Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (<) <$> $(go e1) <*> $(go e2) |]
  go (ExprLE Expr External (S (S (S (S (S Z)))))
e1 Expr External (S (S (S (S (S Z)))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (<=) <$> $(go e1) <*> $(go e2) |]
  go (ExprAnd Expr External (S (S (S (S (S (S (S Z)))))))
e1 Expr External (S (S (S (S (S (S Z))))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (&&) <$> $(go e1) <*> $(go e2) |]
  go (ExprOr Expr External LevelMax
e1 Expr External (S (S (S (S (S (S (S Z)))))))
e2) = forall (m :: * -> *) a. Quasi m => Q a -> m a
runQ [e| (||) <$> $(go e1) <*> $(go e2) |]