shakespeare-2.2.0: Text/Shakespeare.hs

{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveLift #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-- | NOTE: This module should be considered internal, and will be hidden in
-- future releases.
module Text.Shakespeare
    ( ShakespeareSettings (..)
    , PreConvert (..)
    , WrapInsertion (..)
    , PreConversion (..)
    , defaultShakespeareSettings
    , shakespeare
    , shakespeareFile
    , shakespeareFileReload
    -- * low-level
    , shakespeareFromString
    , shakespeareUsedIdentifiers
    , RenderUrl
    , VarType (..)
    , Deref
    , Parser

    , preFilter
      -- * Internal
      -- can we remove this?
    , shakespeareRuntime
    , pack'
    ) where

import Data.List (intersperse)
import Data.Char (isAlphaNum, isSpace)
import Text.ParserCombinators.Parsec hiding (Line, parse, Parser)
import Text.Parsec.Prim (modifyState, Parsec)
import Language.Haskell.TH.Quote (QuasiQuoter (..))
import Language.Haskell.TH (appE)
import Language.Haskell.TH.Lift () -- Import orphan Lift Name instance
import Language.Haskell.TH.Syntax
import Data.Text.Lazy.Builder (Builder, fromText)
#if !MIN_VERSION_base(4,11,0)
import Data.Monoid
#endif
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as TS
import Text.Shakespeare.Base

import System.Directory (getModificationTime)
import Data.Time (UTCTime)
import Data.IORef
import qualified Data.Map as M
import GHC.Generics (Generic)
import Data.Typeable (Typeable)
import Data.Data (Data)

-- for pre conversion
import System.Process (readProcessWithExitCode)
import System.Exit (ExitCode(..))

-- | A parser with a user state of [String]
type Parser = Parsec String [String]
-- | run a parser with a user state of [String]
parse ::  GenParser tok [a1] a -> SourceName -> [tok] -> Either ParseError a
parse p = runParser p []

-- | Coffeescript, TypeScript, and other languages compiles down to Javascript.
-- Previously we waited until the very end, at the rendering stage to perform this compilation.
-- Lets call is a post-conversion
-- This had the advantage that all Haskell values were inserted first:
-- for example a value could be inserted that Coffeescript would compile into Javascript.
-- While that is perhaps a safer approach, the advantage is not used in practice:
-- it was that way mainly for ease of implementation.
-- The down-side is the template must be compiled down to Javascript during every request.
-- If instead we do a pre-conversion to compile down to Javascript,
-- we only need to perform the compilation once.
--
-- The problem then is the insertion of Haskell values: we need a hole for
-- them. This can be done with variables known to the language.
-- During the pre-conversion we first modify all Haskell insertions
-- So #{a} is change to shakespeare_var_a
-- Then we can place the Haskell values in a function wrapper that exposes
-- those variables: (function(shakespeare_var_a){ ... shakespeare_var_a ...})
-- TypeScript can compile that, and then we tack an application of the
-- Haskell values onto the result: (#{a})
--
-- preEscapeIgnoreBalanced is used to not insert backtacks for variable already inside strings or backticks.
-- coffeescript will happily ignore the interpolations, and backticks would not be treated as escaping in that context.
-- preEscapeIgnoreLine was added to ignore comments (which in Coffeescript begin with a '#')

data PreConvert = PreConvert
    { preConvert :: PreConversion
    , preEscapeIgnoreBalanced :: [Char]
    , preEscapeIgnoreLine :: [Char]
    , wrapInsertion :: Maybe WrapInsertion
    }
    deriving Lift

data WrapInsertion = WrapInsertion {
      wrapInsertionIndent     :: Maybe String
    , wrapInsertionStartBegin :: String
    , wrapInsertionSeparator  :: String
    , wrapInsertionStartClose :: String
    , wrapInsertionEnd :: String
    , wrapInsertionAddParens :: Bool
    }
    deriving Lift

data PreConversion = ReadProcess String [String]
                   | Id
    deriving Lift


data ShakespeareSettings = ShakespeareSettings
    { varChar :: Char
    , urlChar :: Char
    , intChar :: Char
    , toBuilder :: Exp
    , wrap :: Exp
    , unwrap :: Exp
    , justVarInterpolation :: Bool
    , preConversion :: Maybe PreConvert
    , modifyFinalValue :: Maybe Exp
    -- ^ A transformation applied to the final expression. Most often, this
    -- would be used to force the type of the expression to help make more
    -- meaningful error messages.
    }

defaultShakespeareSettings :: ShakespeareSettings
defaultShakespeareSettings = ShakespeareSettings {
    varChar = '#'
  , urlChar = '@'
  , intChar = '^'
  , justVarInterpolation = False
  , preConversion = Nothing
  , modifyFinalValue = Nothing
}

instance Lift ShakespeareSettings where
    lift (ShakespeareSettings x1 x2 x3 x4 x5 x6 x7 x8 x9) =
        [|ShakespeareSettings
            $(lift x1) $(lift x2) $(lift x3)
            $(liftExp x4) $(liftExp x5) $(liftExp x6) $(lift x7) $(lift x8) $(liftMExp x9)|]
      where
        liftExp (VarE n) = [|VarE $(lift n)|]
        liftExp (ConE n) = [|ConE $(lift n)|]
        liftExp _ = error "liftExp only supports VarE and ConE"
        liftMExp Nothing = [|Nothing|]
        liftMExp (Just e) = [|Just|] `appE` liftExp e
#if MIN_VERSION_template_haskell(2,17,0)
    liftTyped = unsafeCodeCoerce . lift
#elif MIN_VERSION_template_haskell(2,16,0)
    liftTyped = unsafeTExpCoerce . lift
#endif

type QueryParameters = [(TS.Text, TS.Text)]
type RenderUrl url = (url -> QueryParameters -> TS.Text)
type Shakespeare url = RenderUrl url -> Builder

data Content = ContentRaw String
             | ContentVar Deref
             | ContentUrl Deref
             | ContentUrlParam Deref
             | ContentMix Deref
    deriving (Show, Eq)
type Contents = [Content]

eShowErrors :: Either ParseError c -> c
eShowErrors = either (error . show) id

contentFromString :: ShakespeareSettings -> String -> [Content]
contentFromString _ "" = []
contentFromString rs s =
    compressContents $ eShowErrors $ parse (parseContents rs) s s
  where
    compressContents :: Contents -> Contents
    compressContents [] = []
    compressContents (ContentRaw x:ContentRaw y:z) =
        compressContents $ ContentRaw (x ++ y) : z
    compressContents (x:y) = x : compressContents y

parseContents :: ShakespeareSettings -> Parser Contents
parseContents = many1 . parseContent
  where
    parseContent :: ShakespeareSettings -> Parser Content
    parseContent ShakespeareSettings {..} =
        parseVar' <|> parseUrl' <|> parseInt' <|> parseChar'
      where
        parseVar' = either ContentRaw ContentVar `fmap` parseVar varChar
        parseUrl' = either ContentRaw contentUrl `fmap` parseUrl urlChar '?'
          where
            contentUrl (d, False) = ContentUrl d
            contentUrl (d, True) = ContentUrlParam d

        parseInt' = either ContentRaw ContentMix `fmap` parseInt intChar
        parseChar' = ContentRaw `fmap` many1 (noneOf [varChar, urlChar, intChar])


-- | calls 'error' when there is stderr or exit code failure
readProcessError :: FilePath -> [String] -> String
                 -> Maybe FilePath -- ^ for error reporting
                 -> IO String
readProcessError cmd args input mfp = do
  (ex, output, err) <- readProcessWithExitCode cmd args input
  case ex of
   ExitSuccess   ->
     case err of
       [] -> return output
       msg -> error $ "stderr received during readProcess:" ++ displayCmd ++ "\n\n" ++ msg
   ExitFailure r ->
    error $ "exit code " ++ show r ++ " from readProcess: " ++ displayCmd ++ "\n\n"
      ++ "stderr:\n" ++ err
  where
    displayCmd = cmd ++ ' ':unwords (map show args) ++
        case mfp of
          Nothing -> ""
          Just fp -> ' ':fp

preFilter :: Maybe FilePath -- ^ for error reporting
          -> ShakespeareSettings
          -> String
          -> IO String
preFilter mfp ShakespeareSettings {..} template =
    case preConversion of
      Nothing -> return template
      Just pre@(PreConvert convert _ _ mWrapI) ->
        if all isSpace template then return template else
          let (groups, rvars) = eShowErrors $ parse
                                  (parseConvertWrapInsertion mWrapI pre)
                                  template
                                  template
              vars = reverse rvars
              parsed = mconcat groups
              withVars = (addVars mWrapI vars parsed)
          in  applyVars mWrapI vars `fmap` case convert of
                  Id -> return withVars
                  ReadProcess command args ->
                    readProcessError command args withVars mfp
  where
    addIndent :: Maybe String -> String -> String
    addIndent Nothing str = str
    addIndent (Just indent) str = mapLines (\line -> indent <> line) str
      where
        mapLines f = unlines . map f . lines

    shakespeare_prefix = "shakespeare_var_"
    shakespeare_var_conversion ('@':'?':'{':str) = shakespeare_var_conversion ('@':'{':str)
    shakespeare_var_conversion (_:'{':str) = shakespeare_prefix <> filter isAlphaNum (init str)
    shakespeare_var_conversion err = error $ "did not expect: " <> err

    applyVars _      [] str = str
    applyVars Nothing _ str = str
    applyVars (Just WrapInsertion {..}) vars str =
         (if wrapInsertionAddParens then "(" else "")
      <> removeTrailingSemiColon
      <> (if wrapInsertionAddParens then ")" else "")
      <> "("
      <> mconcat (intersperse ", " vars)
      <> ");\n"
        where
          removeTrailingSemiColon = reverse $
             dropWhile (\c -> c == ';' || isSpace c) (reverse str)

    addVars _      [] str = str
    addVars Nothing _ str = str
    addVars (Just WrapInsertion {..}) vars str =
         wrapInsertionStartBegin
      <> mconcat (intersperse wrapInsertionSeparator $ map shakespeare_var_conversion vars)
      <> wrapInsertionStartClose
      <> addIndent wrapInsertionIndent str
      <> wrapInsertionEnd

    parseConvertWrapInsertion Nothing = parseConvert id
    parseConvertWrapInsertion (Just _) = parseConvert shakespeare_var_conversion

    parseConvert varConvert PreConvert {..} = do
        str <- many1 $ choice $
          map (try . escapedParse) preEscapeIgnoreBalanced ++ [mainParser]
        st <- getState
        return (str, st)

      where
        escapedParse ignoreC = do
            _<- char ignoreC
            inside <- many $ noneOf [ignoreC]
            _<- char ignoreC
            return $ ignoreC:inside ++ [ignoreC]

        mainParser =
            parseVar' <|>
            parseUrl' <|>
            parseInt' <|>
            parseCommentLine preEscapeIgnoreLine <|>
            parseChar' preEscapeIgnoreLine preEscapeIgnoreBalanced

        recordRight (Left str)  = return str
        recordRight (Right str) = modifyState (\vars -> str:vars) >> return (varConvert str)

        newLine = "\r\n"
        parseCommentLine cs = do
          begin <- oneOf cs
          comment <- many $ noneOf newLine
          return $ begin : comment

        parseVar' :: (Parsec String [String]) String
        parseVar' = recordRight =<< parseVarString varChar
        parseUrl' = recordRight =<< parseUrlString urlChar '?'
        parseInt' = recordRight =<< parseIntString intChar
        parseChar' comments ignores =
            many1 (noneOf ([varChar, urlChar, intChar] ++ comments ++ ignores))

pack' :: String -> TS.Text
pack' = TS.pack

contentsToShakespeare :: ShakespeareSettings -> [Content] -> Q Exp
contentsToShakespeare rs a = do
    r <- newName "_render"
    c <- mapM (contentToBuilder r) a
    compiledTemplate <- case c of
        -- Make sure we convert this mempty using toBuilder to pin down the
        -- type appropriately
        []  -> fmap (AppE $ wrap rs) [|mempty|]
        [x] -> return x
        _   -> do
              mc <- [|mconcat|]
              return $ mc `AppE` ListE c
    fmap (maybe id AppE $ modifyFinalValue rs) $ return $
        if justVarInterpolation rs
            then compiledTemplate
            else LamE [VarP r] compiledTemplate
      where
        contentToBuilder :: Name -> Content -> Q Exp
        contentToBuilder _ (ContentRaw s') = do
            ts <- [|fromText . pack'|]
            return $ wrap rs `AppE` (ts `AppE` LitE (StringL s'))
        contentToBuilder _ (ContentVar d) =
            return (toBuilder rs `AppE` derefToExp [] d)
        contentToBuilder r (ContentUrl d) = do
            ts <- [|fromText|]
            return $ wrap rs `AppE` (ts `AppE` (VarE r `AppE` derefToExp [] d `AppE` ListE []))
        contentToBuilder r (ContentUrlParam d) = do
            ts <- [|fromText|]
            up <- [|\r' (u, p) -> r' u p|]
            return $ wrap rs `AppE` (ts `AppE` (up `AppE` VarE r `AppE` derefToExp [] d))
        contentToBuilder r (ContentMix d) =
            return $
              if justVarInterpolation rs
                then derefToExp [] d
                else derefToExp [] d `AppE` VarE r

shakespeare :: ShakespeareSettings -> QuasiQuoter
shakespeare r = QuasiQuoter { quoteExp = shakespeareFromString r }

shakespeareFromString :: ShakespeareSettings -> String -> Q Exp
shakespeareFromString r str = do
    s <- qRunIO $ preFilter Nothing r $
#ifdef WINDOWS
          filter (/='\r')
#endif
          str
    contentsToShakespeare r $ contentFromString r s

shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
shakespeareFile r fp = readFileRecompileQ fp >>= shakespeareFromString r

data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin
    deriving (Show, Eq, Ord, Enum, Bounded, Typeable, Data, Generic)

getVars :: Content -> [(Deref, VarType)]
getVars ContentRaw{} = []
getVars (ContentVar d) = [(d, VTPlain)]
getVars (ContentUrl d) = [(d, VTUrl)]
getVars (ContentUrlParam d) = [(d, VTUrlParam)]
getVars (ContentMix d) = [(d, VTMixin)]

data VarExp url = EPlain Builder
                | EUrl url
                | EUrlParam (url, QueryParameters)
                | EMixin (Shakespeare url)

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

type MTime = UTCTime

{-# NOINLINE reloadMapRef #-}
reloadMapRef :: IORef (M.Map FilePath (MTime, [Content]))
reloadMapRef = unsafePerformIO $ newIORef M.empty

lookupReloadMap :: FilePath -> IO (Maybe (MTime, [Content]))
lookupReloadMap fp = do
  reloads <- readIORef reloadMapRef
  return $ M.lookup fp reloads

insertReloadMap :: FilePath -> (MTime, [Content]) -> IO [Content]
insertReloadMap fp (mt, content) = atomicModifyIORef reloadMapRef
  (\reloadMap -> (M.insert fp (mt, content) reloadMap, content))

shakespeareFileReload :: ShakespeareSettings -> FilePath -> Q Exp
shakespeareFileReload settings fp = do
    str <- readFileQ fp
    s <- qRunIO $ preFilter (Just fp) settings str
    let b = shakespeareUsedIdentifiers settings s
    c <- mapM vtToExp b
    rt <- [|shakespeareRuntime settings fp|]
    wrap' <- [|\x -> $(return $ wrap settings) . x|]
    return $ wrap' `AppE` (rt `AppE` ListE c)
  where
    vtToExp :: (Deref, VarType) -> Q Exp
    vtToExp (d, vt) = do
        d' <- lift d
        c' <- c vt
        return $ TupE
#if MIN_VERSION_template_haskell(2,16,0)
          $ map Just
#endif
          [d', c' `AppE` derefToExp [] d]
      where
        c :: VarType -> Q Exp
        c VTPlain = [|EPlain . $(return $
          InfixE (Just $ unwrap settings) (VarE '(.)) (Just $ toBuilder settings))|]
        c VTUrl = [|EUrl|]
        c VTUrlParam = [|EUrlParam|]
        c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap settings) $ x r|]



nothingError :: Show a => String -> a -> b
nothingError expected d = error $ "expected " ++ expected ++ " but got Nothing for: " ++ show d

shakespeareRuntime :: ShakespeareSettings -> FilePath -> [(Deref, VarExp url)] -> Shakespeare url
shakespeareRuntime settings fp cd render' = unsafePerformIO $ do
    mtime <- qRunIO $ getModificationTime fp
    mdata <- lookupReloadMap fp
    case mdata of
      Just (lastMtime, lastContents) ->
        if mtime == lastMtime then return $ go' lastContents
          else fmap go' $ newContent mtime
      Nothing -> fmap go' $ newContent mtime
  where
    newContent mtime = do
        str <- readUtf8FileString fp
        s <- preFilter (Just fp) settings str
        insertReloadMap fp (mtime, contentFromString settings s)

    go' = mconcat . map go

    go :: Content -> Builder
    go (ContentRaw s) = fromText $ TS.pack s
    go (ContentVar d) =
        case lookup d cd of
            Just (EPlain s) -> s
            _ -> nothingError "EPlain" d
    go (ContentUrl d) =
        case lookup d cd of
            Just (EUrl u) -> fromText $ render' u []
            _ -> nothingError "EUrl" d
    go (ContentUrlParam d) =
        case lookup d cd of
            Just (EUrlParam (u, p)) ->
                fromText $ render' u p
            _ -> nothingError "EUrlParam" d
    go (ContentMix d) =
        case lookup d cd of
            Just (EMixin m) -> m render'
            _ -> nothingError "EMixin" d