{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
-- | A Shakespearean module for Javascript templates, introducing type-safe,
-- compile-time variable and url interpolation.--
--
-- You might consider trying 'Text.Typescript' or 'Text.Coffee' which compile down to Javascript.
--
-- Further reading: <http://www.yesodweb.com/book/shakespearean-templates>
module Text.Julius
    ( -- * Functions
      -- ** Template-Reading Functions
      -- | These QuasiQuoter and Template Haskell methods return values of
      -- type @'JavascriptUrl' url@. See the Yesod book for details.
      js
    , julius
    , juliusFile
    , jsFile
    , juliusFileDebug
    , jsFileDebug
    , juliusFileReload
    , jsFileReload

      -- * Datatypes
    , JavascriptUrl
    , Javascript (..)
    , RawJavascript (..)

      -- * Typeclass for interpolated variables
    , ToJavascript (..)
    , RawJS (..)

      -- ** Rendering Functions
    , renderJavascript
    , renderJavascriptUrl

      -- ** internal, used by 'Text.Coffee'
    , javascriptSettings
      -- ** internal
    , juliusUsedIdentifiers
    , asJavascriptUrl
    ) where

import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH.Syntax
import Data.Text.Lazy.Builder (Builder, fromText, toLazyText, fromLazyText)
import Data.Monoid (Monoid(..))
import Data.Semigroup (Semigroup(..))
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
import Text.Shakespeare
import Data.Aeson (Value, toJSON)
#if MIN_VERSION_aeson(2,0,0)
import qualified Data.Aeson.KeyMap as KeyMap
#endif
import Data.Aeson.Types (Value(..))
import Numeric (showHex)
import qualified Data.HashMap.Strict as H
import qualified Data.Vector as V
import Data.Text.Lazy.Builder (singleton, fromString)
import qualified Data.Text as T
import Data.Scientific (FPFormat(..), Scientific, base10Exponent)
import Data.Text.Lazy.Builder.Scientific (formatScientificBuilder)

renderJavascript :: Javascript -> TL.Text
renderJavascript :: Javascript -> Text
renderJavascript (Javascript Builder
b) = Builder -> Text
toLazyText Builder
b

-- | render with route interpolation. If using this module standalone, apart
-- from type-safe routes, a dummy renderer can be used:
-- 
-- > renderJavascriptUrl (\_ _ -> undefined) javascriptUrl
--
-- When using Yesod, a renderer is generated for you, which can be accessed
-- within the GHandler monad: 'Yesod.Core.Handler.getUrlRenderParams'.
renderJavascriptUrl :: (url -> [(TS.Text, TS.Text)] -> TS.Text) -> JavascriptUrl url -> TL.Text
renderJavascriptUrl :: (url -> [(Text, Text)] -> Text) -> JavascriptUrl url -> Text
renderJavascriptUrl url -> [(Text, Text)] -> Text
r JavascriptUrl url
s = Javascript -> Text
renderJavascript (Javascript -> Text) -> Javascript -> Text
forall a b. (a -> b) -> a -> b
$ JavascriptUrl url
s url -> [(Text, Text)] -> Text
r

-- | Newtype wrapper of 'Builder'.
newtype Javascript = Javascript { Javascript -> Builder
unJavascript :: Builder }
    deriving (b -> Javascript -> Javascript
NonEmpty Javascript -> Javascript
Javascript -> Javascript -> Javascript
(Javascript -> Javascript -> Javascript)
-> (NonEmpty Javascript -> Javascript)
-> (forall b. Integral b => b -> Javascript -> Javascript)
-> Semigroup Javascript
forall b. Integral b => b -> Javascript -> Javascript
forall a.
(a -> a -> a)
-> (NonEmpty a -> a)
-> (forall b. Integral b => b -> a -> a)
-> Semigroup a
stimes :: b -> Javascript -> Javascript
$cstimes :: forall b. Integral b => b -> Javascript -> Javascript
sconcat :: NonEmpty Javascript -> Javascript
$csconcat :: NonEmpty Javascript -> Javascript
<> :: Javascript -> Javascript -> Javascript
$c<> :: Javascript -> Javascript -> Javascript
Semigroup, Semigroup Javascript
Javascript
Semigroup Javascript
-> Javascript
-> (Javascript -> Javascript -> Javascript)
-> ([Javascript] -> Javascript)
-> Monoid Javascript
[Javascript] -> Javascript
Javascript -> Javascript -> Javascript
forall a.
Semigroup a -> a -> (a -> a -> a) -> ([a] -> a) -> Monoid a
mconcat :: [Javascript] -> Javascript
$cmconcat :: [Javascript] -> Javascript
mappend :: Javascript -> Javascript -> Javascript
$cmappend :: Javascript -> Javascript -> Javascript
mempty :: Javascript
$cmempty :: Javascript
$cp1Monoid :: Semigroup Javascript
Monoid)

-- | Return type of template-reading functions.
type JavascriptUrl url = (url -> [(TS.Text, TS.Text)] -> TS.Text) -> Javascript

asJavascriptUrl :: JavascriptUrl url -> JavascriptUrl url
asJavascriptUrl :: JavascriptUrl url -> JavascriptUrl url
asJavascriptUrl = JavascriptUrl url -> JavascriptUrl url
forall a. a -> a
id

-- | A typeclass for types that can be interpolated in CoffeeScript templates.
class ToJavascript a where
    toJavascript :: a -> Javascript

instance ToJavascript Bool where toJavascript :: Bool -> Javascript
toJavascript = Builder -> Javascript
Javascript (Builder -> Javascript) -> (Bool -> Builder) -> Bool -> Javascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
fromText (Text -> Builder) -> (Bool -> Text) -> Bool -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Text
TS.toLower (Text -> Text) -> (Bool -> Text) -> Bool -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TS.pack (String -> Text) -> (Bool -> String) -> Bool -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show
instance ToJavascript Value where toJavascript :: Value -> Javascript
toJavascript = Builder -> Javascript
Javascript (Builder -> Javascript)
-> (Value -> Builder) -> Value -> Javascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> Builder
encodeToTextBuilder
instance ToJavascript String where toJavascript :: String -> Javascript
toJavascript = Value -> Javascript
forall a. ToJavascript a => a -> Javascript
toJavascript (Value -> Javascript) -> (String -> Value) -> String -> Javascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Value
forall a. ToJSON a => a -> Value
toJSON
instance ToJavascript TS.Text where toJavascript :: Text -> Javascript
toJavascript = Value -> Javascript
forall a. ToJavascript a => a -> Javascript
toJavascript (Value -> Javascript) -> (Text -> Value) -> Text -> Javascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
toJSON
instance ToJavascript TL.Text where toJavascript :: Text -> Javascript
toJavascript = Value -> Javascript
forall a. ToJavascript a => a -> Javascript
toJavascript (Value -> Javascript) -> (Text -> Value) -> Text -> Javascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Value
forall a. ToJSON a => a -> Value
toJSON

-- | Encode a JSON 'Value' to a "Data.Text" 'Builder', which can be
-- embedded efficiently in a text-based protocol.
--
-- If you are going to immediately encode straight to a
-- 'L.ByteString', it is more efficient to use 'encodeToBuilder'
-- instead.
encodeToTextBuilder :: Value -> Builder
encodeToTextBuilder :: Value -> Builder
encodeToTextBuilder =
    Value -> Builder
go
  where
    go :: Value -> Builder
go Value
Null       = {-# SCC "go/Null" #-} Builder
"null"
    go (Bool Bool
b)   = {-# SCC "go/Bool" #-} if Bool
b then Builder
"true" else Builder
"false"
    go (Number Scientific
s) = {-# SCC "go/Number" #-} Scientific -> Builder
fromScientific Scientific
s
    go (String Text
s) = {-# SCC "go/String" #-} Text -> Builder
string Text
s
    go (Array Array
v)
        | Array -> Bool
forall a. Vector a -> Bool
V.null Array
v = {-# SCC "go/Array" #-} Builder
"[]"
        | Bool
otherwise = {-# SCC "go/Array" #-}
                      Char -> Builder
singleton Char
'[' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                      Value -> Builder
go (Array -> Value
forall a. Vector a -> a
V.unsafeHead Array
v) Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<>
                      (Value -> Builder -> Builder) -> Builder -> Array -> Builder
forall a b. (a -> b -> b) -> b -> Vector a -> b
V.foldr Value -> Builder -> Builder
f (Char -> Builder
singleton Char
']') (Array -> Array
forall a. Vector a -> Vector a
V.unsafeTail Array
v)
      where f :: Value -> Builder -> Builder
f Value
a Builder
z = Char -> Builder
singleton Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value -> Builder
go Value
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z
    go (Object Object
m) = {-# SCC "go/Object" #-}
        case Object -> [(Text, Value)]
forall v. KeyMap v -> [(Text, v)]
fromObject Object
m of
          ((Text, Value)
x:[(Text, Value)]
xs) -> Char -> Builder
singleton Char
'{' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text, Value) -> Builder
one (Text, Value)
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Text, Value) -> Builder -> Builder)
-> Builder -> [(Text, Value)] -> Builder
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Text, Value) -> Builder -> Builder
f (Char -> Builder
singleton Char
'}') [(Text, Value)]
xs
          [(Text, Value)]
_      -> Builder
"{}"
      where f :: (Text, Value) -> Builder -> Builder
f (Text, Value)
a Builder
z     = Char -> Builder
singleton Char
',' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> (Text, Value) -> Builder
one (Text, Value)
a Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
z
            one :: (Text, Value) -> Builder
one (Text
k,Value
v) = Text -> Builder
string Text
k Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
':' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Value -> Builder
go Value
v

#if MIN_VERSION_aeson(2,0,0)
    fromObject :: KeyMap v -> [(Text, v)]
fromObject = HashMap Text v -> [(Text, v)]
forall k v. HashMap k v -> [(k, v)]
H.toList (HashMap Text v -> [(Text, v)])
-> (KeyMap v -> HashMap Text v) -> KeyMap v -> [(Text, v)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyMap v -> HashMap Text v
forall v. KeyMap v -> HashMap Text v
KeyMap.toHashMapText
#else
    fromObject = H.toList
#endif

string :: T.Text -> Builder
string :: Text -> Builder
string Text
s = {-# SCC "string" #-} Char -> Builder
singleton Char
'"' Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
quote Text
s Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
singleton Char
'"'
  where
    quote :: Text -> Builder
quote Text
q = case Text -> Maybe (Char, Text)
T.uncons Text
t of
                Maybe (Char, Text)
Nothing      -> Text -> Builder
fromText Text
h
                Just (!Char
c,Text
t') -> Text -> Builder
fromText Text
h Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
escape Char
c Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Text -> Builder
quote Text
t'
        where (Text
h,Text
t) = {-# SCC "break" #-} (Char -> Bool) -> Text -> (Text, Text)
T.break Char -> Bool
isEscape Text
q
    isEscape :: Char -> Bool
isEscape Char
c = Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\"' Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\'' Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'\\' Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'<'  Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'>'  Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'&'  Bool -> Bool -> Bool
||
                 Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20'
    escape :: Char -> Builder
escape Char
'\"' = Builder
"\\\""
    escape Char
'\'' = Builder
"\\\'"
    escape Char
'\\' = Builder
"\\\\"
    escape Char
'\n' = Builder
"\\n"
    escape Char
'\r' = Builder
"\\r"
    escape Char
'\t' = Builder
"\\t"
    escape Char
'<' = Builder
"\\u003c"
    escape Char
'>' = Builder
"\\u003e"
    escape Char
'&' = Builder
"\\u0026"

    escape Char
c
        | Char
c Char -> Char -> Bool
forall a. Ord a => a -> a -> Bool
< Char
'\x20' = String -> Builder
fromString (String -> Builder) -> String -> Builder
forall a b. (a -> b) -> a -> b
$ String
"\\u" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> Char -> String
forall a. Int -> a -> [a]
replicate (Int
4 Int -> Int -> Int
forall a. Num a => a -> a -> a
- String -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length String
h) Char
'0' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
h
        | Bool
otherwise  = Char -> Builder
singleton Char
c
        where h :: String
h = Int -> String -> String
forall a. (Integral a, Show a) => a -> String -> String
showHex (Char -> Int
forall a. Enum a => a -> Int
fromEnum Char
c) String
""

fromScientific :: Scientific -> Builder
fromScientific :: Scientific -> Builder
fromScientific Scientific
s = FPFormat -> Maybe Int -> Scientific -> Builder
formatScientificBuilder FPFormat
format Maybe Int
prec Scientific
s
  where
    (FPFormat
format, Maybe Int
prec)
      | Scientific -> Int
base10Exponent Scientific
s Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 = (FPFormat
Generic, Maybe Int
forall a. Maybe a
Nothing)
      | Bool
otherwise            = (FPFormat
Fixed,   Int -> Maybe Int
forall a. a -> Maybe a
Just Int
0)

newtype RawJavascript = RawJavascript Builder
instance ToJavascript RawJavascript where
    toJavascript :: RawJavascript -> Javascript
toJavascript (RawJavascript Builder
a) = Builder -> Javascript
Javascript Builder
a

class RawJS a where
    rawJS :: a -> RawJavascript

instance RawJS [Char] where rawJS :: String -> RawJavascript
rawJS = Builder -> RawJavascript
RawJavascript (Builder -> RawJavascript)
-> (String -> Builder) -> String -> RawJavascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
fromLazyText (Text -> Builder) -> (String -> Text) -> String -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Text
TL.pack
instance RawJS TS.Text where rawJS :: Text -> RawJavascript
rawJS = Builder -> RawJavascript
RawJavascript (Builder -> RawJavascript)
-> (Text -> Builder) -> Text -> RawJavascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
fromText
instance RawJS TL.Text where rawJS :: Text -> RawJavascript
rawJS = Builder -> RawJavascript
RawJavascript (Builder -> RawJavascript)
-> (Text -> Builder) -> Text -> RawJavascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Builder
fromLazyText
instance RawJS Builder where rawJS :: Builder -> RawJavascript
rawJS = Builder -> RawJavascript
RawJavascript
instance RawJS Bool where rawJS :: Bool -> RawJavascript
rawJS = Builder -> RawJavascript
RawJavascript (Builder -> RawJavascript)
-> (Bool -> Builder) -> Bool -> RawJavascript
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Javascript -> Builder
unJavascript (Javascript -> Builder) -> (Bool -> Javascript) -> Bool -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Javascript
forall a. ToJavascript a => a -> Javascript
toJavascript

javascriptSettings :: Q ShakespeareSettings
javascriptSettings :: Q ShakespeareSettings
javascriptSettings = do
  Exp
toJExp <- [|toJavascript|]
  Exp
wrapExp <- [|Javascript|]
  Exp
unWrapExp <- [|unJavascript|]
  Exp
asJavascriptUrl' <- [|asJavascriptUrl|]
  ShakespeareSettings -> Q ShakespeareSettings
forall (m :: * -> *) a. Monad m => a -> m a
return (ShakespeareSettings -> Q ShakespeareSettings)
-> ShakespeareSettings -> Q ShakespeareSettings
forall a b. (a -> b) -> a -> b
$ ShakespeareSettings
defaultShakespeareSettings { toBuilder :: Exp
toBuilder = Exp
toJExp
  , wrap :: Exp
wrap = Exp
wrapExp
  , unwrap :: Exp
unwrap = Exp
unWrapExp
  , modifyFinalValue :: Maybe Exp
modifyFinalValue = Exp -> Maybe Exp
forall a. a -> Maybe a
Just Exp
asJavascriptUrl'
  }

js, julius :: QuasiQuoter
js :: QuasiQuoter
js = QuasiQuoter :: (String -> Q Exp)
-> (String -> Q Pat)
-> (String -> Q Type)
-> (String -> Q [Dec])
-> QuasiQuoter
QuasiQuoter { quoteExp :: String -> Q Exp
quoteExp = \String
s -> do
    ShakespeareSettings
rs <- Q ShakespeareSettings
javascriptSettings
    QuasiQuoter -> String -> Q Exp
quoteExp (ShakespeareSettings -> QuasiQuoter
shakespeare ShakespeareSettings
rs) String
s
    }

julius :: QuasiQuoter
julius = QuasiQuoter
js

jsFile, juliusFile :: FilePath -> Q Exp
jsFile :: String -> Q Exp
jsFile String
fp = do
    ShakespeareSettings
rs <- Q ShakespeareSettings
javascriptSettings
    ShakespeareSettings -> String -> Q Exp
shakespeareFile ShakespeareSettings
rs String
fp

juliusFile :: String -> Q Exp
juliusFile = String -> Q Exp
jsFile


jsFileReload, juliusFileReload :: FilePath -> Q Exp
jsFileReload :: String -> Q Exp
jsFileReload String
fp = do
    ShakespeareSettings
rs <- Q ShakespeareSettings
javascriptSettings
    ShakespeareSettings -> String -> Q Exp
shakespeareFileReload ShakespeareSettings
rs String
fp

juliusFileReload :: String -> Q Exp
juliusFileReload = String -> Q Exp
jsFileReload

jsFileDebug, juliusFileDebug :: FilePath -> Q Exp
juliusFileDebug :: String -> Q Exp
juliusFileDebug = String -> Q Exp
jsFileReload
{-# DEPRECATED juliusFileDebug "Please use juliusFileReload instead." #-}
jsFileDebug :: String -> Q Exp
jsFileDebug = String -> Q Exp
jsFileReload
{-# DEPRECATED jsFileDebug "Please use jsFileReload instead." #-}

-- | Determine which identifiers are used by the given template, useful for
-- creating systems like yesod devel.
juliusUsedIdentifiers :: String -> [(Deref, VarType)]
juliusUsedIdentifiers :: String -> [(Deref, VarType)]
juliusUsedIdentifiers = ShakespeareSettings -> String -> [(Deref, VarType)]
shakespeareUsedIdentifiers ShakespeareSettings
defaultShakespeareSettings