{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-missing-fields #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-- | For lack of a better name... a parameterized version of Julius.
module Text.Shakespeare
    ( ShakespeareSettings (..)
    , PreConvert (..)
    , WrapInsertion (..)
    , PreConversion (..)
    , defaultShakespeareSettings
    , shakespeare
    , shakespeareFile
    , shakespeareFileReload
    -- * low-level
    , shakespeareFromString
    , shakespeareUsedIdentifiers
    , RenderUrl
    , VarType
    , Deref
    , Parser

#ifdef TEST_EXPORT
    , preFilter
#endif
    ) 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.Syntax
#if !MIN_VERSION_template_haskell(2,8,0)
import Language.Haskell.TH.Syntax.Internals
#endif
import Data.Text.Lazy.Builder (Builder, fromText)
import Data.Monoid
import System.IO.Unsafe (unsafePerformIO)
import qualified Data.Text as TS
import qualified Data.Text.Lazy as TL
import Text.Shakespeare.Base

import Filesystem (getModified)
import Filesystem.Path.CurrentOS (decodeString)
import Data.Time (UTCTime)
import Data.IORef
import qualified Data.Map as M

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

#if !MIN_VERSION_base(4,5,0)
(<>) :: Monoid m => m -> m -> m
(<>) = mappend
{-# INLINE (<>) #-}
#endif

-- | 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 []

-- move to Shakespeare.Base?
readFileQ :: FilePath -> Q String
readFileQ fp = qRunIO $ readFileUtf8 fp

-- move to Shakespeare.Base?
readFileUtf8 :: FilePath -> IO String
readFileUtf8 fp = fmap TL.unpack $ readUtf8File fp

-- | 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
    }

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

data PreConversion = ReadProcess String [String]
                   | Id
  


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 PreConvert where
    lift (PreConvert convert ignore comment wrapInsertion) =
        [|PreConvert $(lift convert) $(lift ignore) $(lift comment) $(lift wrapInsertion)|]

instance Lift WrapInsertion where
    lift (WrapInsertion indent sb sep sc e wp) =
        [|WrapInsertion $(lift indent) $(lift sb) $(lift sep) $(lift sc) $(lift e) $(lift wp)|]

instance Lift PreConversion where
    lift (ReadProcess command args) =
        [|ReadProcess $(lift command) $(lift args)|]
    lift Id = [|Id|]

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 $(liftName n)|]
        liftExp (ConE n) = [|ConE $(liftName n)|]
        liftExp _ = error "liftExp only supports VarE and ConE"
        liftMExp Nothing = [|Nothing|]
        liftMExp (Just e) = [|Just|] `appE` liftExp e
        liftName (Name (OccName a) b) = [|Name (OccName $(lift a)) $(liftFlavour b)|]
        liftFlavour NameS = [|NameS|]
        liftFlavour (NameQ (ModName a)) = [|NameQ (ModName $(lift a))|]
        liftFlavour (NameU _) = error "liftFlavour NameU" -- [|NameU $(lift $ fromIntegral a)|]
        liftFlavour (NameL _) = error "liftFlavour NameL" -- [|NameU $(lift $ fromIntegral a)|]
        liftFlavour (NameG ns (PkgName p) (ModName m)) = [|NameG $(liftNS ns) (PkgName $(lift p)) (ModName $(lift m))|]
        liftNS VarName = [|VarName|]
        liftNS DataName = [|DataName|]

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
#if !MIN_VERSION_text(0, 11, 2)
{-# NOINLINE pack' #-}
#endif

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) $
        if justVarInterpolation rs
            then return compiledTemplate
            else return $ 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 $ wrap rs `AppE` (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 $ 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 str
    contentsToShakespeare r $ contentFromString r s

shakespeareFile :: ShakespeareSettings -> FilePath -> Q Exp
shakespeareFile r fp = do
#ifdef GHC_7_4
    qAddDependentFile fp
#endif
    readFileQ fp >>= shakespeareFromString r

data VarType = VTPlain | VTUrl | VTUrlParam | VTMixin

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, [(TS.Text, TS.Text)])
                | 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, Builder))
reloadMapRef = unsafePerformIO $ newIORef M.empty

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

insertReloadMap :: FilePath -> (MTime, Builder) -> IO Builder
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 [d', c' `AppE` derefToExp [] d]
      where
        c :: VarType -> Q Exp
        c VTPlain = [|EPlain . $(return $ toBuilder settings)|]
        c VTUrl = [|EUrl|]
        c VTUrlParam = [|EUrlParam|]
        c VTMixin = [|\x -> EMixin $ \r -> $(return $ unwrap settings) $ x r|]




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

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