{-# LANGUAGE CPP #-}
{-# LANGUAGE ViewPatterns #-}

#ifdef FILE_EMBED
{-# LANGUAGE TemplateHaskell #-}
#endif

module General.Template(runTemplate) where

import System.FilePath.Posix
import Control.Exception.Extra
import Data.Char
import Data.Time
import System.IO.Unsafe
import Development.Shake.Internal.Paths
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Language.Javascript.DGTable as DGTable
import qualified Language.Javascript.Flot as Flot
import qualified Language.Javascript.JQuery as JQuery

#ifdef FILE_EMBED
import Data.FileEmbed
import Language.Haskell.TH.Syntax ( runIO )
#endif

{- HLINT ignore "Redundant bracket" -} -- a result of CPP expansion

-- Very hard to abstract over TH, so we do it with CPP
#ifdef FILE_EMBED
#define FILE(x) (pure (LBS.fromStrict $(embedFile =<< runIO (x))))
#else
#define FILE(x) (LBS.readFile =<< (x))
#endif

libraries :: [(String, IO LBS.ByteString)]
libraries :: [(String, IO ByteString)]
libraries =
    [(String
"jquery.js",            FILE(JQuery.file))
    ,(String
"jquery.dgtable.js",    FILE(DGTable.file))
    ,(String
"jquery.flot.js",       FILE(Flot.file Flot.Flot))
    ,(String
"jquery.flot.stack.js", FILE(Flot.file Flot.FlotStack))
    ]


-- | Template Engine. Perform the following replacements on a line basis:
--
-- * <script src="foo"></script> ==> <script>[[foo]]</script>
--
-- * <link href="foo" rel="stylesheet" type="text/css" /> ==> <style type="text/css">[[foo]]</style>
runTemplate :: (FilePath -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
runTemplate :: (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate String -> IO ByteString
ask = (ByteString -> IO ByteString) -> ByteString -> IO ByteString
lbsMapLinesIO ByteString -> IO ByteString
f
    where
        link :: ByteString
link = String -> ByteString
LBS.pack String
"<link href=\""
        script :: ByteString
script = String -> ByteString
LBS.pack String
"<script src=\""

        f :: ByteString -> IO ByteString
f ByteString
x | Just ByteString
file <- ByteString -> ByteString -> Maybe ByteString
lbsStripPrefix ByteString
script ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack String
"<script>\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` String -> ByteString
LBS.pack String
"\n</script>"
            | Just ByteString
file <- ByteString -> ByteString -> Maybe ByteString
lbsStripPrefix ByteString
link ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack String
"<style type=\"text/css\">\n" ByteString -> ByteString -> ByteString
`LBS.append` ByteString
res ByteString -> ByteString -> ByteString
`LBS.append` String -> ByteString
LBS.pack String
"\n</style>"
            | Bool
otherwise = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure ByteString
x
            where
                y :: ByteString
y = (Char -> Bool) -> ByteString -> ByteString
LBS.dropWhile Char -> Bool
isSpace ByteString
x
                grab :: ByteString -> IO ByteString
grab = String -> IO ByteString
asker (String -> IO ByteString)
-> (ByteString -> String) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> String -> String
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'\"') (String -> String)
-> (ByteString -> String) -> ByteString -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
LBS.unpack

        asker :: String -> IO ByteString
asker o :: String
o@(String -> (String, String)
splitFileName -> (String
"lib/",String
x)) =
            case String -> [(String, IO ByteString)] -> Maybe (IO ByteString)
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, IO ByteString)]
libraries of
                Maybe (IO ByteString)
Nothing -> String -> IO ByteString
forall a. Partial => String -> IO a
errorIO (String -> IO ByteString) -> String -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String
"Template library, unknown library: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
o
                Just IO ByteString
act -> IO ByteString
act

        asker String
"shake.js" = String -> IO ByteString
readDataFileHTML String
"shake.js"
        asker String
"data/metadata.js" = do
            UTCTime
time <- IO UTCTime
getCurrentTime
            ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString) -> ByteString -> IO ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$
                String
"var version = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show String
shakeVersionString String -> String -> String
forall a. [a] -> [a] -> [a]
++
                String
"\nvar generated = " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String -> String
forall a. Show a => a -> String
show (TimeLocale -> String -> UTCTime -> String
forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat (String -> Maybe String
forall a. a -> Maybe a
Just String
"%H:%M:%S")) UTCTime
time)
        asker String
x = String -> IO ByteString
ask String
x

-- Perform a mapM on each line and put the result back together again
lbsMapLinesIO :: (LBS.ByteString -> IO LBS.ByteString) -> LBS.ByteString -> IO LBS.ByteString
-- If we do the obvious @fmap LBS.unlines . mapM f@ then all the monadic actions are run on all the lines
-- before it starts producing the lazy result, killing streaming and having more stack usage.
-- The real solution (albeit with too many dependencies for something small) is a streaming library,
-- but a little bit of unsafePerformIO does the trick too.
lbsMapLinesIO :: (ByteString -> IO ByteString) -> ByteString -> IO ByteString
lbsMapLinesIO ByteString -> IO ByteString
f = ByteString -> IO ByteString
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ByteString -> IO ByteString)
-> (ByteString -> ByteString) -> ByteString -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.unlines ([ByteString] -> ByteString)
-> (ByteString -> [ByteString]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> ByteString) -> [ByteString] -> [ByteString]
forall a b. (a -> b) -> [a] -> [b]
map (IO ByteString -> ByteString
forall a. IO a -> a
unsafePerformIO (IO ByteString -> ByteString)
-> (ByteString -> IO ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ByteString
f) ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.lines


---------------------------------------------------------------------
-- COMPATIBILITY

-- available in bytestring-0.10.8.0, GHC 8.0 and above
-- alternative implementation below
lbsStripPrefix :: LBS.ByteString -> LBS.ByteString -> Maybe LBS.ByteString
lbsStripPrefix :: ByteString -> ByteString -> Maybe ByteString
lbsStripPrefix ByteString
prefix ByteString
text = if ByteString
a ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
prefix then ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just ByteString
b else Maybe ByteString
forall a. Maybe a
Nothing
    where (ByteString
a,ByteString
b) = Int64 -> ByteString -> (ByteString, ByteString)
LBS.splitAt (ByteString -> Int64
LBS.length ByteString
prefix) ByteString
text