    {-# LANGUAGE Trustworthy #-}
    {-# LANGUAGE OverloadedStrings, MultiParamTypeClasses #-}
    {-# LANGUAGE DefaultSignatures #-}
    module Web.Simple.Templates
      ( HasTemplates(..), render, renderPlain, renderLayout, renderLayoutTmpl
      , defaultGetTemplate, defaultFunctionMap, defaultLayoutObject
      , H.fromList
      , Function(..), ToFunction(..), FunctionMap
      ) where

    import Control.Monad.IO.Class
    import Data.Aeson
    import qualified Data.ByteString as S
    import qualified Data.ByteString.Lazy as L
    import qualified Data.HashMap.Strict as H
    import qualified Data.Text as T
    import Data.Text.Encoding
    import qualified Data.Vector as V
    import Network.Mime
    import System.FilePath
    import Web.Simple.Controller.Trans (ControllerT, respond)
    import Web.Simple.Responses (ok)
    import Web.Simple.Templates.Language

    class Monad m => HasTemplates m hs where
      -- | The layout to use by default. Layouts are just templates that embed
      -- views. They are rendered with the a global object containing the rendered
      -- view in the \"yield\" field, and the object the view was rendered with in
      -- the \"page\" field. By default, no template is used.
      defaultLayout :: ControllerT hs m (Maybe Template)
      defaultLayout = Maybe Template -> ControllerT hs m (Maybe Template)
    forall (m :: * -> *) a. Monad m => a -> m a
    return Maybe Template
    forall a. Maybe a
    Nothing

      -- | The directory to look for views passed to 'render'. This defaults to
      -- \"views\", so
      --
      -- @
      -- render \"index.html.tmpl\" ...
      -- @
      --
      -- will look for a view template in \"views/index.html.tmpl\".
      viewDirectory :: ControllerT hs m FilePath
      viewDirectory = FilePath -> ControllerT hs m FilePath
    forall (m :: * -> *) a. Monad m => a -> m a
    return "views"

      -- | A map of pure functions that can be called from within a template. See
      -- 'FunctionMap' and 'Function' for details.
      functionMap :: ControllerT hs m FunctionMap
      functionMap = FunctionMap -> ControllerT hs m FunctionMap
    forall (m :: * -> *) a. Monad m => a -> m a
    return FunctionMap
    defaultFunctionMap

      -- | Function to use to get a template. By default, it looks in the
      -- 'viewDirectory' for the given file name and compiles the file into a
      -- template. This can be overriden to, for example, cache compiled templates
      -- in memory.
      getTemplate :: FilePath -> ControllerT hs m Template
      default getTemplate :: MonadIO m => FilePath -> ControllerT hs m Template
      getTemplate = FilePath -> ControllerT hs m Template
    forall (m :: * -> *) hs.
    (HasTemplates m hs, MonadIO m) =>
    FilePath -> ControllerT hs m Template
    defaultGetTemplate

      -- | The `Value` passed to a layout given the rendered view template and the
      -- value originally passed to the view template. By default, produces an
      -- `Object` with "yield", containing the rendered view, and "page", containing
      -- the value originally passed to the view.
      layoutObject :: (ToJSON pageContent, ToJSON pageVal)
                   => pageContent -> pageVal -> ControllerT hs m Value
      layoutObject = pageContent -> pageVal -> ControllerT hs m Value
    forall (m :: * -> *) hs pageContent pageVal.
    (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
    pageContent -> pageVal -> ControllerT hs m Value
    defaultLayoutObject

    defaultLayoutObject :: (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal)
                        => pageContent -> pageVal -> ControllerT hs m Value
    defaultLayoutObject :: pageContent -> pageVal -> ControllerT hs m Value
    defaultLayoutObject pageContent :: pageContent
    pageContent pageVal :: pageVal
    pageVal = Value -> ControllerT hs m Value
    forall (m :: * -> *) a. Monad m => a -> m a
    return (Value -> ControllerT hs m Value)
    -> Value -> ControllerT hs m Value
    forall a b. (a -> b) -> a -> b
    $
        [Pair] -> Value
    object ["yield" Text -> pageContent -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= pageContent
    pageContent, "page" Text -> pageVal -> Pair
    forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
    .= pageVal
    pageVal]

    -- | Render a view using the layout named by the first argument.
    renderLayout :: (HasTemplates m hs, ToJSON a)
                 => FilePath -> FilePath -> a -> ControllerT hs m ()
    renderLayout :: FilePath -> FilePath -> a -> ControllerT hs m ()
    renderLayout lfp :: FilePath
    lfp fp :: FilePath
    fp val :: a
    val  = do
      Template
    layout <- FilePath -> ControllerT hs m Template
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    FilePath -> ControllerT hs m Template
    getTemplate FilePath
    lfp
      FilePath
    viewDir <- ControllerT hs m FilePath
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m FilePath
    viewDirectory
      Template
    view <- FilePath -> ControllerT hs m Template
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    FilePath -> ControllerT hs m Template
    getTemplate (FilePath
    viewDir FilePath -> FilePath -> FilePath
    </> FilePath
    fp)
      let mime :: MimeType
    mime = Text -> MimeType
    defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack (FilePath -> Text) -> FilePath -> Text
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    takeFileName FilePath
    fp
      Template -> Template -> a -> MimeType -> ControllerT hs m ()
    forall (m :: * -> *) hs a.
    (HasTemplates m hs, ToJSON a) =>
    Template -> Template -> a -> MimeType -> ControllerT hs m ()
    renderLayoutTmpl Template
    layout Template
    view a
    val MimeType
    mime

    -- | Same as 'renderLayout' but uses already compiled layouts.
    renderLayoutTmpl :: (HasTemplates m hs, ToJSON a)
                     => Template -> Template -> a
                     -> S.ByteString -> ControllerT hs m ()
    renderLayoutTmpl :: Template -> Template -> a -> MimeType -> ControllerT hs m ()
    renderLayoutTmpl layout :: Template
    layout view :: Template
    view val :: a
    val mime :: MimeType
    mime = do
      FunctionMap
    fm <- ControllerT hs m FunctionMap
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m FunctionMap
    functionMap
      let pageContent :: Text
    pageContent = Template -> FunctionMap -> Value -> Text
    renderTemplate Template
    view FunctionMap
    fm (Value -> Text) -> Value -> Text
    forall a b. (a -> b) -> a -> b
    $ a -> Value
    forall a. ToJSON a => a -> Value
    toJSON a
    val
      Value
    value <- Text -> a -> ControllerT hs m Value
    forall (m :: * -> *) hs pageContent pageVal.
    (HasTemplates m hs, ToJSON pageContent, ToJSON pageVal) =>
    pageContent -> pageVal -> ControllerT hs m Value
    layoutObject Text
    pageContent a
    val
      let result :: Text
    result = Template -> FunctionMap -> Value -> Text
    renderTemplate Template
    layout FunctionMap
    fm Value
    value
      Response -> ControllerT hs m ()
    forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
    respond (Response -> ControllerT hs m ())
    -> Response -> ControllerT hs m ()
    forall a b. (a -> b) -> a -> b
    $ MimeType -> ByteString -> Response
    ok MimeType
    mime (ByteString -> Response) -> ByteString -> Response
    forall a b. (a -> b) -> a -> b
    $ [MimeType] -> ByteString
    L.fromChunks ([MimeType] -> ByteString)
    -> (Text -> [MimeType]) -> Text -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MimeType -> [MimeType] -> [MimeType]
    forall a. a -> [a] -> [a]
    :[]) (MimeType -> [MimeType])
    -> (Text -> MimeType) -> Text -> [MimeType]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> MimeType
    encodeUtf8 (Text -> ByteString) -> Text -> ByteString
    forall a b. (a -> b) -> a -> b
    $ Text
    result

    -- | Renders a view template with the default layout and a global used to
    -- evaluate variables in the template.
    render :: (HasTemplates m hs , Monad m, ToJSON a)
           => FilePath -- ^ Template to render
           -> a -- ^ Aeson `Value` to pass to the template
           -> ControllerT hs m ()
    render :: FilePath -> a -> ControllerT hs m ()
    render fp :: FilePath
    fp val :: a
    val = do
      Maybe Template
    mlayout <- ControllerT hs m (Maybe Template)
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m (Maybe Template)
    defaultLayout
      case Maybe Template
    mlayout of
        Nothing -> FilePath -> a -> ControllerT hs m ()
    forall (m :: * -> *) hs a.
    (HasTemplates m hs, ToJSON a) =>
    FilePath -> a -> ControllerT hs m ()
    renderPlain FilePath
    fp a
    val
        Just layout :: Template
    layout -> do
          FilePath
    viewDir <- ControllerT hs m FilePath
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m FilePath
    viewDirectory
          Template
    view <- FilePath -> ControllerT hs m Template
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    FilePath -> ControllerT hs m Template
    getTemplate (FilePath
    viewDir FilePath -> FilePath -> FilePath
    </> FilePath
    fp)
          let mime :: MimeType
    mime = Text -> MimeType
    defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack (FilePath -> Text) -> FilePath -> Text
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    takeFileName FilePath
    fp
          Template -> Template -> a -> MimeType -> ControllerT hs m ()
    forall (m :: * -> *) hs a.
    (HasTemplates m hs, ToJSON a) =>
    Template -> Template -> a -> MimeType -> ControllerT hs m ()
    renderLayoutTmpl Template
    layout Template
    view a
    val MimeType
    mime

    -- | Same as 'render' but without a template.
    renderPlain :: (HasTemplates m hs, ToJSON a)
                => FilePath -- ^ Template to render
                -> a -- ^ Aeson `Value` to pass to the template
                -> ControllerT hs m ()
    renderPlain :: FilePath -> a -> ControllerT hs m ()
    renderPlain fp :: FilePath
    fp val :: a
    val = do
      FunctionMap
    fm <- ControllerT hs m FunctionMap
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m FunctionMap
    functionMap
      FilePath
    dir <- ControllerT hs m FilePath
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    ControllerT hs m FilePath
    viewDirectory
      Template
    tmpl <- FilePath -> ControllerT hs m Template
    forall (m :: * -> *) hs.
    HasTemplates m hs =>
    FilePath -> ControllerT hs m Template
    getTemplate (FilePath
    dir FilePath -> FilePath -> FilePath
    </> FilePath
    fp)
      let pageContent :: ByteString
    pageContent =
            [MimeType] -> ByteString
    L.fromChunks ([MimeType] -> ByteString)
    -> (Text -> [MimeType]) -> Text -> ByteString
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (MimeType -> [MimeType] -> [MimeType]
    forall a. a -> [a] -> [a]
    :[]) (MimeType -> [MimeType])
    -> (Text -> MimeType) -> Text -> [MimeType]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Text -> MimeType
    encodeUtf8 (Text -> ByteString) -> Text -> ByteString
    forall a b. (a -> b) -> a -> b
    $
              Template -> FunctionMap -> Value -> Text
    renderTemplate Template
    tmpl FunctionMap
    fm (Value -> Text) -> Value -> Text
    forall a b. (a -> b) -> a -> b
    $ a -> Value
    forall a. ToJSON a => a -> Value
    toJSON a
    val
      let mime :: MimeType
    mime = Text -> MimeType
    defaultMimeLookup (Text -> MimeType) -> Text -> MimeType
    forall a b. (a -> b) -> a -> b
    $ FilePath -> Text
    T.pack (FilePath -> Text) -> FilePath -> Text
    forall a b. (a -> b) -> a -> b
    $ FilePath -> FilePath
    takeFileName FilePath
    fp
      Response -> ControllerT hs m ()
    forall (m :: * -> *) s a. Monad m => Response -> ControllerT s m a
    respond (Response -> ControllerT hs m ())
    -> Response -> ControllerT hs m ()
    forall a b. (a -> b) -> a -> b
    $ MimeType -> ByteString -> Response
    ok MimeType
    mime ByteString
    pageContent

    defaultGetTemplate :: (HasTemplates m hs, MonadIO m)
                       => FilePath -> ControllerT hs m Template
    defaultGetTemplate :: FilePath -> ControllerT hs m Template
    defaultGetTemplate fp :: FilePath
    fp = do
      MimeType
    contents <- IO MimeType -> ControllerT hs m MimeType
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
    liftIO (IO MimeType -> ControllerT hs m MimeType)
    -> IO MimeType -> ControllerT hs m MimeType
    forall a b. (a -> b) -> a -> b
    $ FilePath -> IO MimeType
    S.readFile FilePath
    fp
      case Text -> Either FilePath Template
    compileTemplate (Text -> Either FilePath Template)
    -> (MimeType -> Text) -> MimeType -> Either FilePath Template
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . MimeType -> Text
    decodeUtf8 (MimeType -> Either FilePath Template)
    -> MimeType -> Either FilePath Template
    forall a b. (a -> b) -> a -> b
    $ MimeType
    contents of
        Left str :: FilePath
    str -> FilePath -> ControllerT hs m Template
    forall (m :: * -> *) a. MonadFail m => FilePath -> m a
    fail FilePath
    str
        Right tmpl :: Template
    tmpl -> Template -> ControllerT hs m Template
    forall (m :: * -> *) a. Monad m => a -> m a
    return Template
    tmpl

    defaultFunctionMap :: FunctionMap
    defaultFunctionMap :: FunctionMap
    defaultFunctionMap = [(Text, Function)] -> FunctionMap
    forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
    H.fromList
      [ ("length", (Value -> Value) -> Function
    forall a. ToFunction a => a -> Function
    toFunction Value -> Value
    valueLength)
      , ("null", (Value -> Value) -> Function
    forall a. ToFunction a => a -> Function
    toFunction Value -> Value
    valueNull)]

    valueLength :: Value -> Value
    valueLength :: Value -> Value
    valueLength (Array arr :: Array
    arr) = Int -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ Array -> Int
    forall a. Vector a -> Int
    V.length Array
    arr
    valueLength (Object obj :: Object
    obj) = Int -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ Object -> Int
    forall k v. HashMap k v -> Int
    H.size Object
    obj
    valueLength (String str :: Text
    str) = Int -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Int -> Value) -> Int -> Value
    forall a b. (a -> b) -> a -> b
    $ Text -> Int
    T.length Text
    str
    valueLength Null = Int -> Value
    forall a. ToJSON a => a -> Value
    toJSON (0 :: Int)
    valueLength _ = FilePath -> Value
    forall a. HasCallStack => FilePath -> a
    error "length only valid for arrays, objects and strings"

    valueNull :: Value -> Value
    valueNull :: Value -> Value
    valueNull (Array arr :: Array
    arr) = Bool -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Bool -> Value) -> Bool -> Value
    forall a b. (a -> b) -> a -> b
    $ Array -> Bool
    forall a. Vector a -> Bool
    V.null Array
    arr
    valueNull (Object obj :: Object
    obj) = Bool -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Bool -> Value) -> Bool -> Value
    forall a b. (a -> b) -> a -> b
    $ Object -> Bool
    forall k v. HashMap k v -> Bool
    H.null Object
    obj
    valueNull (String str :: Text
    str) = Bool -> Value
    forall a. ToJSON a => a -> Value
    toJSON (Bool -> Value) -> Bool -> Value
    forall a b. (a -> b) -> a -> b
    $ Text -> Bool
    T.null Text
    str
    valueNull Null = Bool -> Value
    forall a. ToJSON a => a -> Value
    toJSON Bool
    True
    valueNull _ = FilePath -> Value
    forall a. HasCallStack => FilePath -> a
    error "null only valid for arrays, objects and strings"