{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}

{- |
Module      :  Text.Heterocephalus

Copyright   :  Kadzuya Okamoto 2016
License     :  MIT

Stability   :  experimental
Portability :  unknown

This module exports functions for working with frontend templates from Haskell.
-}

module Text.Heterocephalus
  (
  -- * Core functions
    compileTextFile
  , compileTextFileWith
  , compileTextFileWithDefault
  , compileHtmlFile
  , compileHtmlFileWith
  , compileHtmlFileWithDefault

  -- * QuasiQuoters
  , compileText
  , compileHtml

  -- * ScopeM
  , ScopeM
  , setDefault
  , overwrite

  -- * low-level
  , HeterocephalusSetting(..)
  , textSetting
  , htmlSetting
  , ParseOptions(..)
  , defaultParseOptions
  , createParseOptions
  , DefaultScope
  , compile
  , compileWith
  , compileWithDefault
  , compileFile
  , compileFileWith
  , compileFileWithDefault
  , compileFromString
  , compileFromStringWithDefault
  ) where

#if MIN_VERSION_base(4,9,0)
#else
import Control.Applicative ((<$>), (<*>), Applicative(..))
import Data.Monoid (Monoid, mempty, mappend)
#endif
import Control.Monad (forM)
import Data.Char (isDigit)
import Data.DList (DList)
import qualified Data.DList as DList
import qualified Data.Foldable as F
import Data.List (intercalate)
import qualified Data.Semigroup as Sem
import Data.String (IsString(..))
import Data.Text (Text, pack)
import qualified Data.Text.Lazy as TL
import Language.Haskell.TH.Lib (ExpQ, varE)
import Language.Haskell.TH.Quote
       (QuasiQuoter(QuasiQuoter), quoteExp, quoteDec, quotePat, quoteType)
#if MIN_VERSION_template_haskell(2,9,0)
import Language.Haskell.TH.Syntax
       (Body(..), Con(..), Dec(..), Exp(..), Info(..), Lit(..), Match(..),
        Name(..), Pat(..), Q, Stmt(..), lookupValueName, mkName, nameBase,
        newName, qAddDependentFile, qRunIO, reify)
#else
import Language.Haskell.TH.Syntax
#endif
import TemplateHaskell.Compat.V0208
import Text.Blaze (preEscapedToMarkup)
import Text.Blaze.Html (toHtml)
import Text.Blaze.Internal (preEscapedText)
import Text.Hamlet (Html, HtmlUrl, HtmlUrlI18n, condH)
import Text.Hamlet.Parse
       (Binding(..), DataConstr(..), Module(Module), specialOrIdent)
import Text.Shakespeare.Base
       (Deref, Ident(..), Scope, derefToExp, readUtf8File)

import Text.Heterocephalus.Parse
       (Doc(..), Content(..), ParseOptions(..), createParseOptions,
        defaultParseOptions, docFromString)

{- $setup
  >>> :set -XTemplateHaskell -XQuasiQuotes
  >>> import Text.Blaze.Renderer.String
-}

{-| A function to compile template file.
  This function __DOES NOT__ escape template variables.
  To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.

  >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileTextFile "templates/sample.txt"))
  sample
  key: <a>,
  key: b,
 -}
compileTextFile :: FilePath -> Q Exp
compileTextFile :: String -> Q Exp
compileTextFile = HeterocephalusSetting -> String -> Q Exp
compileFile HeterocephalusSetting
textSetting

{-| Same as 'compileText' but allows the user to specify extra values for template parameters.
  Values declared by 'overwrite' overwrites same name variables.
  Values declared by 'setDefault' are overwritten by same name variables.

>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileTextFileWith "templates/sample.txt" $ do
    setDefault "as" [| ["foo", "bar"] |]
  )
)
:}
sample
key: <a>,
key: b,

>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileTextFileWith "templates/sample.txt" $ do
    overwrite "as" [| ["foo", "bar"] |]
  )
)
:}
sample
key: foo,
key: bar,

>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileTextFileWith "templates/sample.txt" $ do
    overwrite "as" [| ["bazbaz", "barbar"] |]
    setDefault "as" [| ["foo", "bar"] |]
    overwrite "as" [| ["baz", "foobar"] |]
  )
)
:}
sample
key: baz,
key: foobar,
 -}
compileTextFileWith :: FilePath -> ScopeM () -> Q Exp
compileTextFileWith :: String -> ScopeM () -> Q Exp
compileTextFileWith String
fp ScopeM ()
scopeM = ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFileWith ScopeM ()
scopeM HeterocephalusSetting
textSetting String
fp

{-| Same as 'compileText' but allows the user to specify default values for template parameters.

>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileTextFileWithDefault "templates/sample.txt"
    [("as", [| ["foo", "bar"] |])]
  )
)
:}
sample
key: <a>,
key: b,

>>> :{
putStr $ renderMarkup (
  $(compileTextFileWithDefault "templates/sample.txt"
    [("as", [| ["foo", "bar"] |])]
  )
)
:}
sample
key: foo,
key: bar,
 -}
compileTextFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileTextFileWithDefault :: String -> DefaultScope -> Q Exp
compileTextFileWithDefault String
fp DefaultScope
scope = DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFileWithDefault DefaultScope
scope HeterocephalusSetting
textSetting String
fp

{-| Same as 'compileTextFile' but escapes template variables in HTML.

  >>> putStr $ renderMarkup (let as = ["<a>", "b"] in $(compileHtmlFile "templates/sample.txt"))
  sample
  key: &lt;a&gt;,
  key: b,
 -}
compileHtmlFile :: FilePath -> Q Exp
compileHtmlFile :: String -> Q Exp
compileHtmlFile String
fp = String -> DefaultScope -> Q Exp
compileHtmlFileWithDefault String
fp []

{-| Same as 'compileHtmlFile' but allows the user to specify extra values for template parameters.
  Values declared by 'overwrite' overwrites same name variables.
  Values declared by 'setDefault' are overwritten by same name variables.

>>> :set -XOverloadedStrings
>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileHtmlFileWith "templates/sample.txt" $ do
    setDefault "as" [| ["foo", "bar"] |]
  )
)
:}
sample
key: &lt;a&gt;,
key: b,

>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileHtmlFileWith "templates/sample.txt" $ do
    overwrite "as" [| ["foo", "bar"] |]
  )
)
:}
sample
key: foo,
key: bar,

>>> :{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileHtmlFileWith "templates/sample.txt" $ do
    overwrite "as" [| ["bazbaz", "barbar"] |]
    setDefault "as" [| ["foo", "bar"] |]
    overwrite "as" [| ["baz", "foobar"] |]
  )
)
:}
sample
key: baz,
key: foobar,
 -}
compileHtmlFileWith :: FilePath -> ScopeM () -> Q Exp
compileHtmlFileWith :: String -> ScopeM () -> Q Exp
compileHtmlFileWith String
fp ScopeM ()
scopeM = ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFileWith ScopeM ()
scopeM HeterocephalusSetting
htmlSetting String
fp

{-| Same as 'compileHtmlFile' but allows the user to specify default values for template parameters.

>>> :set -XOverloadedStrings
:{
putStr $ renderMarkup (
  let as = ["<a>", "b"]
  in $(compileHtmlFileWithDefault "templates/sample.txt"
    [("as", [| ["foo", "bar"] |])]
  )
)
:}
sample
key: &lt;a&gt;,
key: b,

>>> :{
putStr $ renderMarkup (
  $(compileHtmlFileWithDefault "templates/sample.txt"
    [("as", [| ["foo", "bar"] |])]
  )
)
:}
sample
key: foo,
key: bar,
 -}
compileHtmlFileWithDefault :: FilePath -> DefaultScope -> Q Exp
compileHtmlFileWithDefault :: String -> DefaultScope -> Q Exp
compileHtmlFileWithDefault String
fp DefaultScope
scope = DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFileWithDefault DefaultScope
scope HeterocephalusSetting
htmlSetting String
fp

{-| Heterocephalus quasi-quoter.
  This function __DOES NOT__ escape template variables.
  To render the compiled file, use @'Text.Blaze.Renderer'.*.renderMarkup@.

  >>> renderMarkup (let as = ["<a>", "b"] in [compileText|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
  "sample key: <a>, key: b, "

  >>> renderMarkup (let num=2 in [compileText|#{num} is %{ if even num }an even number.%{ elseif (num > 100) }big.%{ else }an odd number.%{ endif }|])
  "2 is an even number."
 -}
compileText :: QuasiQuoter
compileText :: QuasiQuoter
compileText = HeterocephalusSetting -> QuasiQuoter
compile HeterocephalusSetting
textSetting

{-| Heterocephalus quasi-quoter for HTML.
  Same as 'compileText' but this function does escape template variables in HTML.

  >>> renderMarkup (let as = ["<a>", "b"] in [compileHtml|sample %{ forall a <- as }key: #{a}, %{ endforall }|])
  "sample key: &lt;a&gt;, key: b, "
 -}
compileHtml :: QuasiQuoter
compileHtml :: QuasiQuoter
compileHtml = HeterocephalusSetting -> QuasiQuoter
compile HeterocephalusSetting
htmlSetting

compile :: HeterocephalusSetting -> QuasiQuoter
compile :: HeterocephalusSetting -> QuasiQuoter
compile = DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault []

{-| QuasiQuoter.
 -}
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith :: ScopeM () -> HeterocephalusSetting -> QuasiQuoter
compileWith ScopeM ()
scopeM HeterocephalusSetting
set =
  QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith ScopeM ()
scopeM HeterocephalusSetting
set
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not used"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not used"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"not used"
  }

{-| QuasiQuoter.
 -}
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault :: DefaultScope -> HeterocephalusSetting -> QuasiQuoter
compileWithDefault DefaultScope
scope HeterocephalusSetting
set =
  QuasiQuoter
  { quoteExp :: String -> Q Exp
quoteExp = DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault DefaultScope
scope HeterocephalusSetting
set
  , quotePat :: String -> Q Pat
quotePat = String -> String -> Q Pat
forall a. HasCallStack => String -> a
error String
"not used"
  , quoteType :: String -> Q Type
quoteType = String -> String -> Q Type
forall a. HasCallStack => String -> a
error String
"not used"
  , quoteDec :: String -> Q [Dec]
quoteDec = String -> String -> Q [Dec]
forall a. HasCallStack => String -> a
error String
"not used"
  }

{-| Compile a template file.
-}
compileFile :: HeterocephalusSetting -> FilePath -> Q Exp
compileFile :: HeterocephalusSetting -> String -> Q Exp
compileFile = DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFileWithDefault []

{-| Same as 'compileFile' but we can specify default scope.
-}
compileFileWith :: ScopeM () -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFileWith ScopeM ()
scopeM HeterocephalusSetting
set String
fp = do
  String -> Q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile String
fp
  String
contents <- (Text -> String) -> Q Text -> Q String
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
TL.unpack (Q Text -> Q String) -> Q Text -> Q String
forall a b. (a -> b) -> a -> b
$ IO Text -> Q Text
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readUtf8File String
fp
  ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith ScopeM ()
scopeM HeterocephalusSetting
set String
contents

{-| Same as 'compileFile' but we can specify default scope.
-}
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> FilePath -> Q Exp
compileFileWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFileWithDefault DefaultScope
scope' HeterocephalusSetting
set String
fp = do
  String -> Q ()
forall (m :: * -> *). Quasi m => String -> m ()
qAddDependentFile String
fp
  String
contents <- (Text -> String) -> Q Text -> Q String
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Text -> String
TL.unpack (Q Text -> Q String) -> Q Text -> Q String
forall a b. (a -> b) -> a -> b
$ IO Text -> Q Text
forall a. IO a -> Q a
forall (m :: * -> *) a. Quasi m => IO a -> m a
qRunIO (IO Text -> Q Text) -> IO Text -> Q Text
forall a b. (a -> b) -> a -> b
$ String -> IO Text
readUtf8File String
fp
  DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault DefaultScope
scope' HeterocephalusSetting
set String
contents

{-| Same as 'compileFile', but just compile the 'String' given.

  >>> let as = ["<a>", "b"]
  >>> let template = "sample %{ forall a <- as }key: #{a}, %{ endforall }"
  >>> renderMarkup $(compileFromString textSetting template)
  "sample key: <a>, key: b, "

  >>> let as = ["<a>", "b"]
  >>> let options = createParseOptions '|' '?'
  >>> let setting = textSetting { parseOptions = options }
  >>> let template = "sample |{ forall a <- as }key: ?{a}, |{ endforall }"
  >>> renderMarkup $(compileFromString setting template)
  "sample key: <a>, key: b, "
-}
compileFromString :: HeterocephalusSetting -> String -> Q Exp
compileFromString :: HeterocephalusSetting -> String -> Q Exp
compileFromString = DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault []

compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith :: ScopeM () -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWith ScopeM ()
scopeM HeterocephalusSetting
set String
s = do
  [(Ident, Exp)]
defScope' <-
    DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
defScope (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Q Exp -> Q Exp
overwriteScope Ident
ident Q Exp
qexp
  [(Ident, Exp)]
owScope' <-
    DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
owScope (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Exp
qexp
  HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set ([(Ident, Exp)]
owScope' [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
defScope') ([Doc] -> Q Exp) -> [Doc] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseOptions -> String -> [Doc]
docFromString (HeterocephalusSetting -> ParseOptions
parseOptions HeterocephalusSetting
set) String
s
 where
  (DefaultDList
defDList, DefaultDList
owDList) = ScopeM () -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM ()
scopeM
  defScope :: DefaultScope
defScope = DefaultDList -> DefaultScope
forall a. DList a -> [a]
DList.toList DefaultDList
defDList
  owScope :: DefaultScope
owScope = DefaultDList -> DefaultScope
forall a. DList a -> [a]
DList.toList DefaultDList
owDList

compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault :: DefaultScope -> HeterocephalusSetting -> String -> Q Exp
compileFromStringWithDefault DefaultScope
scope' HeterocephalusSetting
set String
s = do
  [(Ident, Exp)]
scope <-
    DefaultScope
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM DefaultScope
scope' (((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)])
-> ((Ident, Q Exp) -> Q (Ident, Exp)) -> Q [(Ident, Exp)]
forall a b. (a -> b) -> a -> b
$ \(Ident
ident, Q Exp
qexp) -> (Ident
ident, ) (Exp -> (Ident, Exp)) -> Q Exp -> Q (Ident, Exp)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Ident -> Q Exp -> Q Exp
overwriteScope Ident
ident Q Exp
qexp
  HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope ([Doc] -> Q Exp) -> [Doc] -> Q Exp
forall a b. (a -> b) -> a -> b
$ ParseOptions -> String -> [Doc]
docFromString (HeterocephalusSetting -> ParseOptions
parseOptions HeterocephalusSetting
set) String
s

overwriteScope :: Ident -> Q Exp -> Q Exp
overwriteScope :: Ident -> Q Exp -> Q Exp
overwriteScope (Ident String
str) Q Exp
qexp = do
  Maybe Name
mName <- String -> Q (Maybe Name)
lookupValueName String
str
  case Maybe Name
mName of
    Just Name
x -> Name -> Q Exp
forall (m :: * -> *). Quote m => Name -> m Exp
varE Name
x
    Maybe Name
Nothing -> Q Exp
qexp

{-| Settings that are used when processing heterocephalus templates.
 -}
data HeterocephalusSetting = HeterocephalusSetting
  { HeterocephalusSetting -> Q Exp
escapeExp :: Q Exp
  -- ^ Template variables are passed to 'escapeExp' in the output.  This allows
  -- things like escaping HTML entities.  (See 'htmlSetting'.)
  , HeterocephalusSetting -> ParseOptions
parseOptions :: ParseOptions
  }

{-| A setting that escapes template variables for Html

This sets 'escapeExp' to 'toHtml'.
 -}
htmlSetting :: HeterocephalusSetting
htmlSetting :: HeterocephalusSetting
htmlSetting = HeterocephalusSetting
  { escapeExp :: Q Exp
escapeExp = [|toHtml|]
  , parseOptions :: ParseOptions
parseOptions = ParseOptions
defaultParseOptions
  }

{-| A setting that DOES NOT escape template variables.

This sets 'escapeExp' to 'preEscapedToMarkup'.
 -}
textSetting :: HeterocephalusSetting
textSetting :: HeterocephalusSetting
textSetting = HeterocephalusSetting
  { escapeExp :: Q Exp
escapeExp = [|preEscapedToMarkup|]
  , parseOptions :: ParseOptions
parseOptions = ParseOptions
defaultParseOptions
  }

type DefaultScope = [(Ident, Q Exp)]

type DefaultDList = DList (Ident, Q Exp)
type OverwriteDList = DList (Ident, Q Exp)

{- | A type to handle extra scopes.
   This is opaque type, so use 'setDefault' and 'overwrite'
   to construct new 'ScopeM'.
 -}
data ScopeM a
  = SetDefault Ident ExpQ (ScopeM a)
  | Overwrite Ident ExpQ (ScopeM a)
  | PureScopeM a

{- | Get default values and values to overwrite from 'ScopeM'.
 -}
runScopeM :: ScopeM a -> (DefaultDList, OverwriteDList)
runScopeM :: forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM (SetDefault Ident
ident Q Exp
qexp ScopeM a
next) =
  let (DefaultDList
defaults, DefaultDList
overwrites) = ScopeM a -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM a
next
  in (DefaultDList -> (Ident, Q Exp) -> DefaultDList
forall a. DList a -> a -> DList a
DList.snoc DefaultDList
defaults (Ident
ident, Q Exp
qexp), DefaultDList
overwrites)
runScopeM (Overwrite Ident
ident Q Exp
qexp ScopeM a
next) =
  let (DefaultDList
defaults, DefaultDList
overwrites) = ScopeM a -> (DefaultDList, DefaultDList)
forall a. ScopeM a -> (DefaultDList, DefaultDList)
runScopeM ScopeM a
next
  in (DefaultDList
defaults, DefaultDList -> (Ident, Q Exp) -> DefaultDList
forall a. DList a -> a -> DList a
DList.snoc DefaultDList
overwrites (Ident
ident, Q Exp
qexp))
runScopeM (PureScopeM a
_) =
  (DefaultDList
forall a. Monoid a => a
mempty, DefaultDList
forall a. Monoid a => a
mempty)

instance Sem.Semigroup (ScopeM ()) where
  ScopeM ()
a <> :: ScopeM () -> ScopeM () -> ScopeM ()
<> ScopeM ()
b  = ScopeM ()
a ScopeM () -> ScopeM () -> ScopeM ()
forall a b. ScopeM a -> ScopeM b -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ScopeM ()
b

instance Monoid (ScopeM ()) where
  mempty :: ScopeM ()
mempty = () -> ScopeM ()
forall a. a -> ScopeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
#if !(MIN_VERSION_base(4,11,0))
  mappend = (Sem.<>)
#endif

instance Functor ScopeM where
  fmap :: forall a b. (a -> b) -> ScopeM a -> ScopeM b
fmap a -> b
f (SetDefault Ident
ident Q Exp
qexp ScopeM a
next) =
    Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ScopeM a -> ScopeM b
forall a b. (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ScopeM a
next
  fmap a -> b
f (Overwrite Ident
ident Q Exp
qexp ScopeM a
next) =
    Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ (a -> b) -> ScopeM a -> ScopeM b
forall a b. (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap a -> b
f ScopeM a
next
  fmap a -> b
f (PureScopeM a
x) =
    b -> ScopeM b
forall a. a -> ScopeM a
PureScopeM (b -> ScopeM b) -> b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ a -> b
f a
x

instance Applicative ScopeM where
  pure :: forall a. a -> ScopeM a
pure = a -> ScopeM a
forall a. a -> ScopeM a
PureScopeM
  SetDefault Ident
ident Q Exp
qexp ScopeM (a -> b)
next <*> :: forall a b. ScopeM (a -> b) -> ScopeM a -> ScopeM b
<*> ScopeM a
f =
    Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM (a -> b)
next ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall a b. ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScopeM a
f
  Overwrite Ident
ident Q Exp
qexp ScopeM (a -> b)
next <*> ScopeM a
f =
    Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM (a -> b)
next ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall a b. ScopeM (a -> b) -> ScopeM a -> ScopeM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ScopeM a
f
  PureScopeM a -> b
g <*> ScopeM a
f = ScopeM a
f ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall a b. ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= (b -> ScopeM b
forall a. a -> ScopeM a
PureScopeM (b -> ScopeM b) -> (a -> b) -> a -> ScopeM b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
g)

instance Monad ScopeM where
#if MIN_VERSION_base(4,9,0)
#else
  return = PureScopeM
#endif
  SetDefault Ident
ident Q Exp
qexp ScopeM a
next >>= :: forall a b. ScopeM a -> (a -> ScopeM b) -> ScopeM b
>>= a -> ScopeM b
f = Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM a
next ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall a b. ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ScopeM b
f
  Overwrite Ident
ident Q Exp
qexp ScopeM a
next >>= a -> ScopeM b
f = Ident -> Q Exp -> ScopeM b -> ScopeM b
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM b -> ScopeM b) -> ScopeM b -> ScopeM b
forall a b. (a -> b) -> a -> b
$ ScopeM a
next ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall a b. ScopeM a -> (a -> ScopeM b) -> ScopeM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= a -> ScopeM b
f
  PureScopeM a
a >>= a -> ScopeM b
f = a -> ScopeM b
f a
a

{-| Constructor for 'ScopeM'.
  Values declared by this function are overwritten
  by same name variables exits in scope of render function.
 -}
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault :: Ident -> Q Exp -> ScopeM ()
setDefault Ident
ident Q Exp
qexp = Ident -> Q Exp -> ScopeM () -> ScopeM ()
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
SetDefault Ident
ident Q Exp
qexp (ScopeM () -> ScopeM ()) -> ScopeM () -> ScopeM ()
forall a b. (a -> b) -> a -> b
$ () -> ScopeM ()
forall a. a -> ScopeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-| Constructor for 'ScopeM'.
  Values declared by this function overwrites
  same name variables exits in scope of render function.
 -}
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite :: Ident -> Q Exp -> ScopeM ()
overwrite Ident
ident Q Exp
qexp = Ident -> Q Exp -> ScopeM () -> ScopeM ()
forall a. Ident -> Q Exp -> ScopeM a -> ScopeM a
Overwrite Ident
ident Q Exp
qexp (ScopeM () -> ScopeM ()) -> ScopeM () -> ScopeM ()
forall a b. (a -> b) -> a -> b
$ () -> ScopeM ()
forall a. a -> ScopeM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance IsString Ident where
  fromString :: String -> Ident
fromString = String -> Ident
Ident

-- ==============================================
--  Helper functions
-- ==============================================

docsToExp :: HeterocephalusSetting -> Scope -> [Doc] -> Q Exp
docsToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope [Doc]
docs = do
  [Exp]
exps <- (Doc -> Q Exp) -> [Doc] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (HeterocephalusSetting -> [(Ident, Exp)] -> Doc -> Q Exp
docToExp HeterocephalusSetting
set [(Ident, Exp)]
scope) [Doc]
docs
  case [Exp]
exps of
    [] -> [|return ()|]
    [Exp
x] -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return Exp
x
    [Exp]
_ -> Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Stmt] -> Exp
doE ([Stmt] -> Exp) -> [Stmt] -> Exp
forall a b. (a -> b) -> a -> b
$ (Exp -> Stmt) -> [Exp] -> [Stmt]
forall a b. (a -> b) -> [a] -> [b]
map Exp -> Stmt
NoBindS [Exp]
exps

docToExp :: HeterocephalusSetting -> Scope -> Doc -> Q Exp
docToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> Doc -> Q Exp
docToExp HeterocephalusSetting
set [(Ident, Exp)]
scope (DocForall Deref
list Binding
idents [Doc]
inside) = do
  let list' :: Exp
list' = [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
list
  (Pat
pat, [(Ident, Exp)]
extraScope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
idents
  let scope' :: [(Ident, Exp)]
scope' = [(Ident, Exp)]
extraScope [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scope
  Exp
mh <- [|F.mapM_|]
  Exp
inside' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope' [Doc]
inside
  let lam :: Exp
lam = [Pat] -> Exp -> Exp
LamE [Pat
pat] Exp
inside'
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
mh Exp -> Exp -> Exp
`AppE` Exp
lam Exp -> Exp -> Exp
`AppE` Exp
list'
docToExp HeterocephalusSetting
set [(Ident, Exp)]
scope (DocCond [(Deref, [Doc])]
conds Maybe [Doc]
final) = do
  [Exp]
conds' <- ((Deref, [Doc]) -> Q Exp) -> [(Deref, [Doc])] -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Deref, [Doc]) -> Q Exp
go [(Deref, [Doc])]
conds
  Exp
final' <-
    case Maybe [Doc]
final of
      Maybe [Doc]
Nothing -> [|Nothing|]
      Just [Doc]
f -> do
        Exp
f' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope [Doc]
f
        Exp
j <- [|Just|]
        Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
j Exp -> Exp -> Exp
`AppE` Exp
f'
  Exp
ch <- [|condH|]
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
ch Exp -> Exp -> Exp
`AppE` [Exp] -> Exp
ListE [Exp]
conds' Exp -> Exp -> Exp
`AppE` Exp
final'
  where
    go :: (Deref, [Doc]) -> Q Exp
    go :: (Deref, [Doc]) -> Q Exp
go (Deref
d, [Doc]
docs) = do
      let d' :: Exp
d' = [(Ident, Exp)] -> Deref -> Exp
derefToExp ((Ident
specialOrIdent, Name -> Exp
VarE 'or) (Ident, Exp) -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. a -> [a] -> [a]
: [(Ident, Exp)]
scope) Deref
d
      Exp
docs' <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope [Doc]
docs
      Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ [Exp] -> Exp
nonUnaryTupE [Exp
d', Exp
docs']
      where
        nonUnaryTupE :: [Exp] -> Exp
        nonUnaryTupE :: [Exp] -> Exp
nonUnaryTupE [Exp]
es  = [Exp] -> Exp
tupE [Exp]
es
docToExp HeterocephalusSetting
set [(Ident, Exp)]
scope (DocCase Deref
deref [(Binding, [Doc])]
cases) = do
    let exp_ :: Exp
exp_ = [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
deref
    [Match]
matches <- ((Binding, [Doc]) -> Q Match) -> [(Binding, [Doc])] -> Q [Match]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Binding, [Doc]) -> Q Match
toMatch [(Binding, [Doc])]
cases
    Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp -> [Match] -> Exp
CaseE Exp
exp_ [Match]
matches
  where
    toMatch :: (Binding, [Doc]) -> Q Match
    toMatch :: (Binding, [Doc]) -> Q Match
toMatch (Binding
idents, [Doc]
inside) = do
        (Pat
pat, [(Ident, Exp)]
extraScope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
idents
        let scope' :: [(Ident, Exp)]
scope' = [(Ident, Exp)]
extraScope [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scope
        Exp
insideExp <- HeterocephalusSetting -> [(Ident, Exp)] -> [Doc] -> Q Exp
docsToExp HeterocephalusSetting
set [(Ident, Exp)]
scope' [Doc]
inside
        Match -> Q Match
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Match -> Q Match) -> Match -> Q Match
forall a b. (a -> b) -> a -> b
$ Pat -> Body -> [Dec] -> Match
Match Pat
pat (Exp -> Body
NormalB Exp
insideExp) []
docToExp HeterocephalusSetting
set [(Ident, Exp)]
v (DocContent Content
c) = HeterocephalusSetting -> [(Ident, Exp)] -> Content -> Q Exp
contentToExp HeterocephalusSetting
set [(Ident, Exp)]
v Content
c

contentToExp :: HeterocephalusSetting -> Scope -> Content -> Q Exp
contentToExp :: HeterocephalusSetting -> [(Ident, Exp)] -> Content -> Q Exp
contentToExp HeterocephalusSetting
_ [(Ident, Exp)]
_ (ContentRaw String
s) = do
  Exp
os <- [|preEscapedText . pack|]
  let s' :: Exp
s' = Lit -> Exp
LitE (Lit -> Exp) -> Lit -> Exp
forall a b. (a -> b) -> a -> b
$ String -> Lit
StringL String
s
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
os Exp -> Exp -> Exp
`AppE` Exp
s'
contentToExp HeterocephalusSetting
set [(Ident, Exp)]
scope (ContentVar Deref
d) = do
  Exp
str <- HeterocephalusSetting -> Q Exp
escapeExp HeterocephalusSetting
set
  Exp -> Q Exp
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
$ Exp
str Exp -> Exp -> Exp
`AppE` [(Ident, Exp)] -> Deref -> Exp
derefToExp [(Ident, Exp)]
scope Deref
d

-- ==============================================
-- Codes from Text.Hamlet that is not exposed
-- ==============================================

unIdent :: Ident -> String
unIdent :: Ident -> String
unIdent (Ident String
s) = String
s

bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern :: Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern (BindAs i :: Ident
i@(Ident String
s) Binding
b) = do
  Name
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
  (Pat
pattern, [(Ident, Exp)]
scope) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
b
  (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat -> Pat
AsP Name
name Pat
pattern, (Ident
i, Name -> Exp
VarE Name
name) (Ident, Exp) -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. a -> [a] -> [a]
: [(Ident, Exp)]
scope)
bindingPattern (BindVar i :: Ident
i@(Ident String
s))
  | String
s String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
"_" = (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pat
WildP, [])
  | (Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Char -> Bool
isDigit String
s = do (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Lit -> Pat
LitP (Lit -> Pat) -> Lit -> Pat
forall a b. (a -> b) -> a -> b
$ Integer -> Lit
IntegerL (Integer -> Lit) -> Integer -> Lit
forall a b. (a -> b) -> a -> b
$ String -> Integer
forall a. Read a => String -> a
read String
s, [])
  | Bool
otherwise = do
    Name
name <- String -> Q Name
forall (m :: * -> *). Quote m => String -> m Name
newName String
s
    (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Pat
VarP Name
name, [(Ident
i, Name -> Exp
VarE Name
name)])
bindingPattern (BindTuple [Binding]
is) = do
  ([Pat]
patterns, [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
  (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
TupP [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
bindingPattern (BindList [Binding]
is) = do
  ([Pat]
patterns, [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
  (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Pat] -> Pat
ListP [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
bindingPattern (BindConstr DataConstr
con [Binding]
is) = do
  ([Pat]
patterns, [[(Ident, Exp)]]
scopes) <- ([(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(Pat, [(Ident, Exp)])] -> ([Pat], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]]))
-> Q [(Pat, [(Ident, Exp)])] -> Q ([Pat], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ (Binding -> Q (Pat, [(Ident, Exp)]))
-> [Binding] -> Q [(Pat, [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern [Binding]
is
#if MIN_VERSION_template_haskell_compat_v0208(0,1,8)
  {- 
  Todo: Note, the use of conP below (note lowercase 'c') is from the package 'template-haskell-compat-v0208'.
  This allows Heterocephalus to compile with GHC 9.2, as the ConP constructor takes an additional argument in GHC 9.2
  Note however this _probably_ means there was some new extension or new syntax extension that GHC now allows post GHC 9.2
  that we are not able to handle. As I (clintonmead@gmail.com) am just writing a PR to the library and don't fully understand it
  (I'm making this PR just to make our current project build under GHC 9.2) there's probably some more work to be done here.

  The github issue relating to this is at https://github.com/arowM/heterocephalus/issues/32
  -}
  (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> [Pat] -> Pat
conP (DataConstr -> Name
mkConName DataConstr
con) [Pat]
patterns, [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes)
#else
  return (ConP (mkConName con) patterns, concat scopes)
#endif
bindingPattern (BindRecord DataConstr
con [(Ident, Binding)]
fields Bool
wild) = do
  let f :: (Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)])
f (Ident String
field, Binding
b) = do
        (Pat
p, [(Ident, Exp)]
s) <- Binding -> Q (Pat, [(Ident, Exp)])
bindingPattern Binding
b
        ((Name, Pat), [(Ident, Exp)]) -> Q ((Name, Pat), [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ((String -> Name
mkName String
field, Pat
p), [(Ident, Exp)]
s)
  ([(Name, Pat)]
patterns, [[(Ident, Exp)]]
scopes) <- ([((Name, Pat), [(Ident, Exp)])]
 -> ([(Name, Pat)], [[(Ident, Exp)]]))
-> Q [((Name, Pat), [(Ident, Exp)])]
-> Q ([(Name, Pat)], [[(Ident, Exp)]])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), [(Ident, Exp)])]
-> ([(Name, Pat)], [[(Ident, Exp)]])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), [(Ident, Exp)])]
 -> Q ([(Name, Pat)], [[(Ident, Exp)]]))
-> Q [((Name, Pat), [(Ident, Exp)])]
-> Q ([(Name, Pat)], [[(Ident, Exp)]])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)]))
-> [(Ident, Binding)] -> Q [((Name, Pat), [(Ident, Exp)])]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ident, Binding) -> Q ((Name, Pat), [(Ident, Exp)])
f [(Ident, Binding)]
fields
  ([(Name, Pat)]
patterns1, [(Ident, Exp)]
scopes1) <-
    if Bool
wild
      then DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields DataConstr
con ([Ident] -> Q ([(Name, Pat)], [(Ident, Exp)]))
-> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
forall a b. (a -> b) -> a -> b
$ ((Ident, Binding) -> Ident) -> [(Ident, Binding)] -> [Ident]
forall a b. (a -> b) -> [a] -> [b]
map (Ident, Binding) -> Ident
forall a b. (a, b) -> a
fst [(Ident, Binding)]
fields
      else ([(Name, Pat)], [(Ident, Exp)])
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return ([], [])
  (Pat, [(Ident, Exp)]) -> Q (Pat, [(Ident, Exp)])
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return
    (Name -> [(Name, Pat)] -> Pat
RecP (DataConstr -> Name
mkConName DataConstr
con) ([(Name, Pat)]
patterns [(Name, Pat)] -> [(Name, Pat)] -> [(Name, Pat)]
forall a. [a] -> [a] -> [a]
++ [(Name, Pat)]
patterns1), [[(Ident, Exp)]] -> [(Ident, Exp)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Ident, Exp)]]
scopes [(Ident, Exp)] -> [(Ident, Exp)] -> [(Ident, Exp)]
forall a. [a] -> [a] -> [a]
++ [(Ident, Exp)]
scopes1)

mkConName :: DataConstr -> Name
mkConName :: DataConstr -> Name
mkConName = String -> Name
mkName (String -> Name) -> (DataConstr -> String) -> DataConstr -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DataConstr -> String
conToStr

conToStr :: DataConstr -> String
conToStr :: DataConstr -> String
conToStr (DCUnqualified (Ident String
x)) = String
x
conToStr (DCQualified (Module [String]
xs) (Ident String
x)) = String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
intercalate String
"." ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$ [String]
xs [String] -> [String] -> [String]
forall a. [a] -> [a] -> [a]
++ [String
x]

-- Wildcards bind all of the unbound fields to variables whose name
-- matches the field name.
--
-- For example: data R = C { f1, f2 :: Int }
-- C {..}           is equivalent to   C {f1=f1, f2=f2}
-- C {f1 = a, ..}   is equivalent to   C {f1=a,  f2=f2}
-- C {f2 = a, ..}   is equivalent to   C {f1=f1, f2=a}
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields :: DataConstr -> [Ident] -> Q ([(Name, Pat)], [(Ident, Exp)])
bindWildFields DataConstr
conName [Ident]
fields = do
  [Name]
fieldNames <- DataConstr -> Q [Name]
recordToFieldNames DataConstr
conName
  let available :: Name -> Bool
available Name
n = Name -> String
nameBase Name
n String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` (Ident -> String) -> [Ident] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Ident -> String
unIdent [Ident]
fields
  let remainingFields :: [Name]
remainingFields = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter Name -> Bool
available [Name]
fieldNames
  let mkPat :: Name -> m ((Name, Pat), (Ident, Exp))
mkPat Name
n = do
        Name
e <- String -> m Name
forall (m :: * -> *). Quote m => String -> m Name
newName (Name -> String
nameBase Name
n)
        ((Name, Pat), (Ident, Exp)) -> m ((Name, Pat), (Ident, Exp))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, Name -> Pat
VarP Name
e), (String -> Ident
Ident (Name -> String
nameBase Name
n), Name -> Exp
VarE Name
e))
  ([((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], [(Ident, Exp)]))
-> Q [((Name, Pat), (Ident, Exp))]
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall a b. (a -> b) -> Q a -> Q b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [((Name, Pat), (Ident, Exp))] -> ([(Name, Pat)], [(Ident, Exp)])
forall a b. [(a, b)] -> ([a], [b])
unzip (Q [((Name, Pat), (Ident, Exp))]
 -> Q ([(Name, Pat)], [(Ident, Exp)]))
-> Q [((Name, Pat), (Ident, Exp))]
-> Q ([(Name, Pat)], [(Ident, Exp)])
forall a b. (a -> b) -> a -> b
$ (Name -> Q ((Name, Pat), (Ident, Exp)))
-> [Name] -> Q [((Name, Pat), (Ident, Exp))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Name -> Q ((Name, Pat), (Ident, Exp))
forall {m :: * -> *}.
Quote m =>
Name -> m ((Name, Pat), (Ident, Exp))
mkPat [Name]
remainingFields

-- Important note! reify will fail if the record type is defined in the
-- same module as the reify is used. This means quasi-quoted Hamlet
-- literals will not be able to use wildcards to match record types
-- defined in the same module.
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames :: DataConstr -> Q [Name]
recordToFieldNames DataConstr
conStr
  -- use 'lookupValueName' instead of just using 'mkName' so we reify the
  -- data constructor and not the type constructor if their names match.
 = do
  Just Name
conName <- String -> Q (Maybe Name)
lookupValueName (String -> Q (Maybe Name)) -> String -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ DataConstr -> String
conToStr DataConstr
conStr
#if MIN_VERSION_template_haskell(2,11,0)
  DataConI Name
_ Type
_ Name
typeName         <- Name -> Q Info
reify Name
conName
  TyConI (DataD Cxt
_ Name
_ [TyVarBndr ()]
_ Maybe Type
_ [Con]
cons [DerivClause]
_) <- Name -> Q Info
reify Name
typeName
#else
  DataConI _ _ typeName _     <- reify conName
  TyConI (DataD _ _ _ cons _) <- reify typeName
#endif
  [[VarBangType]
fields] <- [[VarBangType]] -> Q [[VarBangType]]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [[VarBangType]
fields | RecC Name
name [VarBangType]
fields <- [Con]
cons, Name
name Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
conName]
  [Name] -> Q [Name]
forall a. a -> Q a
forall (m :: * -> *) a. Monad m => a -> m a
return [Name
fieldName | (Name
fieldName, Bang
_, Type
_) <- [VarBangType]
fields]

type QueryParameters = [(Text, Text)]

data VarExp msg url
  = EPlain Html
  | EUrl url
  | EUrlParam (url, QueryParameters)
  | EMixin (HtmlUrl url)
  | EMixinI18n (HtmlUrlI18n msg url)
  | EMsg msg

instance Show (VarExp msg url) where
  show :: VarExp msg url -> String
show (EPlain Html
_) = String
"EPlain"
  show (EUrl url
_) = String
"EUrl"
  show (EUrlParam (url, QueryParameters)
_) = String
"EUrlParam"
  show (EMixin HtmlUrl url
_) = String
"EMixin"
  show (EMixinI18n HtmlUrlI18n msg url
_) = String
"EMixinI18n"
  show (EMsg msg
_) = String
"EMsg"