{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE ViewPatterns    #-}

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

module Development.IDE.Graph.Internal.Profile (writeProfile) where

import           Control.Concurrent.STM.Stats            (readTVarIO)
import           Data.Bifunctor
import qualified Data.ByteString.Lazy.Char8              as LBS
import           Data.Char
import           Data.Dynamic                            (toDyn)
import           Data.HashMap.Strict                     (HashMap)
import qualified Data.HashMap.Strict                     as Map
import qualified Data.HashSet                            as Set
import           Data.List                               (dropWhileEnd, foldl',
                                                          intercalate,
                                                          partition, sort,
                                                          sortBy)
import           Data.List.Extra                         (nubOrd)
import           Data.Maybe
import           Data.Time                               (defaultTimeLocale,
                                                          formatTime,
                                                          getCurrentTime,
                                                          iso8601DateFormat)
import           Development.IDE.Graph.Classes
import           Development.IDE.Graph.Internal.Database (getDirtySet)
import           Development.IDE.Graph.Internal.Paths
import           Development.IDE.Graph.Internal.Types
import qualified Language.Javascript.DGTable             as DGTable
import qualified Language.Javascript.Flot                as Flot
import qualified Language.Javascript.JQuery              as JQuery
import           Numeric.Extra                           (showDP)
import           System.FilePath
import           System.IO.Unsafe                        (unsafePerformIO)
import           System.Time.Extra                       (Seconds)

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

-- | Generates an report given some build system profiling data.
writeProfile :: FilePath -> Database -> IO ()
writeProfile :: String -> Database -> IO ()
writeProfile String
out Database
db = do
    ([ProfileEntry]
report, HashMap Key Int
mapping) <- Database -> IO ([ProfileEntry], HashMap Key Int)
toReport Database
db
    Maybe [Int]
dirtyKeysMapped <- do
        HashSet Key
dirtyIds <- forall a. (Eq a, Hashable a) => [a] -> HashSet a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> IO [(Key, Int)]
getDirtySet Database
db
        let dirtyKeysMapped :: [Int]
dirtyKeysMapped = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Key Int
mapping) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. HashSet a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ HashSet Key
dirtyIds
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Ord a => [a] -> [a]
sort [Int]
dirtyKeysMapped
    ByteString
rpt <- Maybe [Int] -> [ProfileEntry] -> IO ByteString
generateHTML Maybe [Int]
dirtyKeysMapped [ProfileEntry]
report
    String -> ByteString -> IO ()
LBS.writeFile String
out ByteString
rpt

data ProfileEntry = ProfileEntry
    {ProfileEntry -> String
prfName :: !String, ProfileEntry -> Int
prfBuilt :: !Int, ProfileEntry -> Int
prfChanged :: !Int, ProfileEntry -> Int
prfVisited :: !Int, ProfileEntry -> [[Int]]
prfDepends :: [[Int]], ProfileEntry -> Seconds
prfExecution :: !Seconds}

-- | Eliminate all errors from the database, pretending they don't exist
-- resultsOnly :: Map.HashMap Id (Key, Status) -> Map.HashMap Id (Key, Result (Either BS.ByteString Value))
resultsOnly :: [(Key, Status)] -> Map.HashMap Key Result
resultsOnly :: [(Key, Status)] -> HashMap Key Result
resultsOnly [(Key, Status)]
mp = forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map (\Result
r ->
      Result
r{resultDeps :: ResultDeps
resultDeps = ([Key] -> [Key]) -> ResultDeps -> ResultDeps
mapResultDeps (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Maybe a -> Bool
isJust forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a -> b -> c) -> b -> a -> c
flip forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup HashMap Key Result
keep)) forall a b. (a -> b) -> a -> b
$ Result -> ResultDeps
resultDeps Result
r}
    ) HashMap Key Result
keep
    where
        keep :: HashMap Key Result
keep = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Status -> Maybe Result
getResult) [(Key, Status)]
mp

-- | Given a map of representing a dependency order (with a show for error messages), find an ordering for the items such
--   that no item points to an item before itself.
--   Raise an error if you end up with a cycle.
dependencyOrder :: (Eq a, Hashable a) => (a -> String) -> [(a,[a])] -> [a]
-- Algorithm:
--    Divide everyone up into those who have no dependencies [Id]
--    And those who depend on a particular Id, Dep :-> Maybe [(Key,[Dep])]
--    Where d :-> Just (k, ds), k depends on firstly d, then remaining on ds
--    For each with no dependencies, add to list, then take its dep hole and
--    promote them either to Nothing (if ds == []) or into a new slot.
--    k :-> Nothing means the key has already been freed
dependencyOrder :: forall a. (Eq a, Hashable a) => (a -> String) -> [(a, [a])] -> [a]
dependencyOrder a -> String
shw [(a, [a])]
status =
  [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(a, [a])]
noDeps) forall a b. (a -> b) -> a -> b
$
    forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
Map.map forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
      forall k v.
(Eq k, Hashable k) =>
(v -> v -> v) -> [(k, v)] -> HashMap k v
Map.fromListWith forall a. [a] -> [a] -> [a]
(++)
        [(a
d, [(a
k,[a]
ds)]) | (a
k,a
d:[a]
ds) <- [(a, [a])]
hasDeps]
    where
        ([(a, [a])]
noDeps, [(a, [a])]
hasDeps) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd) [(a, [a])]
status

        f :: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f [] HashMap a (Maybe [(a, [a])])
mp | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
bad = []
                | Bool
otherwise = forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines forall a b. (a -> b) -> a -> b
$
                    String
"Internal invariant broken, database seems to be cyclic" forall a. a -> [a] -> [a]
:
                    forall a b. (a -> b) -> [a] -> [b]
map (String
"    " forall a. [a] -> [a] -> [a]
++) [String]
bad forall a. [a] -> [a] -> [a]
++
                    [String
"... plus " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall (t :: * -> *) a. Foldable t => t a -> Int
length [String]
badOverflow) forall a. [a] -> [a] -> [a]
++ String
" more ..." | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [String]
badOverflow]
            where ([String]
bad,[String]
badOverflow) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
10 [a -> String
shw a
i | (a
i, Just [(a, [a])]
_) <- forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap a (Maybe [(a, [a])])
mp]

        f (a
x:[a]
xs) HashMap a (Maybe [(a, [a])])
mp = a
x forall a. a -> [a] -> [a]
: [a] -> HashMap a (Maybe [(a, [a])]) -> [a]
f ([a]
nowforall a. [a] -> [a] -> [a]
++[a]
xs) HashMap a (Maybe [(a, [a])])
later
            where Just [(a, [a])]
free = forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault (forall a. a -> Maybe a
Just []) a
x HashMap a (Maybe [(a, [a])])
mp
                  ([a]
now,HashMap a (Maybe [(a, [a])])
later) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {k} {a}.
Hashable k =>
([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([], forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert a
x forall a. Maybe a
Nothing HashMap a (Maybe [(a, [a])])
mp) [(a, [a])]
free

        g :: ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, []) = (a
kforall a. a -> [a] -> [a]
:[a]
free, HashMap k (Maybe [(a, [k])])
mp)
        g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, k
d:[k]
ds) = case forall k v. (Eq k, Hashable k) => v -> k -> HashMap k v -> v
Map.lookupDefault (forall a. a -> Maybe a
Just []) k
d HashMap k (Maybe [(a, [k])])
mp of
            Maybe [(a, [k])]
Nothing   -> ([a], HashMap k (Maybe [(a, [k])]))
-> (a, [k]) -> ([a], HashMap k (Maybe [(a, [k])]))
g ([a]
free, HashMap k (Maybe [(a, [k])])
mp) (a
k, [k]
ds)
            Just [(a, [k])]
todo -> ([a]
free, forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert k
d (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (a
k,[k]
ds) forall a. a -> [a] -> [a]
: [(a, [k])]
todo) HashMap k (Maybe [(a, [k])])
mp)

prepareForDependencyOrder :: Database -> IO (HashMap Key Result)
prepareForDependencyOrder :: Database -> IO (HashMap Key Result)
prepareForDependencyOrder Database
db = do
    Step
current <- forall a. TVar a -> IO a
readTVarIO forall a b. (a -> b) -> a -> b
$ Database -> TVar Step
databaseStep Database
db
    forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
Map.insert (forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key String
"alwaysRerun") (Step -> Result
alwaysRerunResult Step
current) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [(Key, Status)] -> HashMap Key Result
resultsOnly
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Database -> IO [(Key, Status)]
getDatabaseValues Database
db

-- | Returns a list of profile entries, and a mapping linking a non-error Id to its profile entry
toReport :: Database -> IO ([ProfileEntry], HashMap Key Int)
toReport :: Database -> IO ([ProfileEntry], HashMap Key Int)
toReport Database
db = do
    HashMap Key Result
status <- Database -> IO (HashMap Key Result)
prepareForDependencyOrder Database
db
    let order :: [Key]
order = forall a. (Eq a, Hashable a) => (a -> String) -> [(a, [a])] -> [a]
dependencyOrder forall a. Show a => a -> String
show
                forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ([Key] -> ResultDeps -> [Key]
getResultDepsDefault [forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key String
"alwaysRerun"] forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> ResultDeps
resultDeps))
                forall a b. (a -> b) -> a -> b
$ forall k v. HashMap k v -> [(k, v)]
Map.toList HashMap Key Result
status
        ids :: HashMap Key Int
ids = forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Key]
order [Int
0..]

        steps :: HashMap Step Int
steps = let xs :: [Step]
xs = forall a. Ord a => [a] -> [a]
nubOrd forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Step
resultChanged, Step
resultBuilt, Step
resultVisited] | Result{Seconds
ByteString
ResultDeps
Value
Step
resultData :: Result -> ByteString
resultExecution :: Result -> Seconds
resultVisited :: Result -> Step
resultChanged :: Result -> Step
resultBuilt :: Result -> Step
resultValue :: Result -> Value
resultData :: ByteString
resultExecution :: Seconds
resultDeps :: ResultDeps
resultValue :: Value
resultVisited :: Step
resultBuilt :: Step
resultChanged :: Step
resultDeps :: Result -> ResultDeps
..} <- forall k v. HashMap k v -> [v]
Map.elems HashMap Key Result
status]

                in forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
Map.fromList forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a. Ord a => a -> a -> Ordering
compare) [Step]
xs) [Int
0..]

        f :: a -> Result -> ProfileEntry
f a
k Result{Seconds
ByteString
ResultDeps
Value
Step
resultData :: ByteString
resultExecution :: Seconds
resultDeps :: ResultDeps
resultVisited :: Step
resultChanged :: Step
resultBuilt :: Step
resultValue :: Value
resultData :: Result -> ByteString
resultExecution :: Result -> Seconds
resultVisited :: Result -> Step
resultChanged :: Result -> Step
resultBuilt :: Result -> Step
resultValue :: Result -> Value
resultDeps :: Result -> ResultDeps
..} = ProfileEntry
            {prfName :: String
prfName = forall a. Show a => a -> String
show a
k
            ,prfBuilt :: Int
prfBuilt = Step -> Int
fromStep Step
resultBuilt
            ,prfVisited :: Int
prfVisited = Step -> Int
fromStep Step
resultVisited
            ,prfChanged :: Int
prfChanged = Step -> Int
fromStep Step
resultChanged
            ,prfDepends :: [[Int]]
prfDepends = forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`Map.lookup` HashMap Key Int
ids) forall a b. (a -> b) -> a -> b
$ [Key] -> ResultDeps -> [Key]
getResultDepsDefault [forall a. (Typeable a, Eq a, Hashable a, Show a) => a -> Key
Key String
"alwaysRerun"] ResultDeps
resultDeps
            ,prfExecution :: Seconds
prfExecution = Seconds
resultExecution
            }
            where fromStep :: Step -> Int
fromStep Step
i = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Step
i HashMap Step Int
steps
    forall (f :: * -> *) a. Applicative f => a -> f a
pure ([forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a. HasCallStack => String -> a
error String
"toReport") (forall {a}. Show a => a -> Result -> ProfileEntry
f Key
i) forall a b. (a -> b) -> a -> b
$ forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
Map.lookup Key
i HashMap Key Result
status | Key
i <- [Key]
order], HashMap Key Int
ids)

alwaysRerunResult :: Step -> Result
alwaysRerunResult :: Step -> Result
alwaysRerunResult Step
current = Value
-> Step
-> Step
-> Step
-> ResultDeps
-> Seconds
-> ByteString
-> Result
Result (Dynamic -> Value
Value forall a b. (a -> b) -> a -> b
$ forall a. Typeable a => a -> Dynamic
toDyn String
"<alwaysRerun>") (Int -> Step
Step Int
0) (Int -> Step
Step Int
0) Step
current ([Key] -> ResultDeps
ResultDeps []) Seconds
0 forall a. Monoid a => a
mempty

generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO LBS.ByteString
generateHTML :: Maybe [Int] -> [ProfileEntry] -> IO ByteString
generateHTML Maybe [Int]
dirtyKeys [ProfileEntry]
xs = do
    ByteString
report <- String -> IO ByteString
readDataFileHTML String
"profile.html"
    let f :: String -> f ByteString
f String
"data/profile-data.js" = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$ String
"var profile =\n" forall a. [a] -> [a] -> [a]
++ [ProfileEntry] -> String
generateJSONProfile [ProfileEntry]
xs
        f String
"data/build-data.js" = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$ String
"var build =\n" forall a. [a] -> [a] -> [a]
++ Maybe [Int] -> String
generateJSONBuild Maybe [Int]
dirtyKeys
        f String
other = forall a. HasCallStack => String -> a
error String
other
    (String -> IO ByteString) -> ByteString -> IO ByteString
runTemplate forall {f :: * -> *}. Applicative f => String -> f ByteString
f ByteString
report

generateJSONBuild :: Maybe [Int] -> String
generateJSONBuild :: Maybe [Int] -> String
generateJSONBuild (Just [Int]
dirtyKeys) = [String] -> String
jsonList [[String] -> String
jsonList (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Int]
dirtyKeys)]
generateJSONBuild Maybe [Int]
Nothing          = [String] -> String
jsonList []

generateJSONProfile :: [ProfileEntry] -> String
generateJSONProfile :: [ProfileEntry] -> String
generateJSONProfile = [String] -> String
jsonListLines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ProfileEntry -> String
showEntry
    where
        showEntry :: ProfileEntry -> String
showEntry ProfileEntry{Seconds
Int
String
[[Int]]
prfExecution :: Seconds
prfDepends :: [[Int]]
prfVisited :: Int
prfChanged :: Int
prfBuilt :: Int
prfName :: String
prfExecution :: ProfileEntry -> Seconds
prfDepends :: ProfileEntry -> [[Int]]
prfVisited :: ProfileEntry -> Int
prfChanged :: ProfileEntry -> Int
prfBuilt :: ProfileEntry -> Int
prfName :: ProfileEntry -> String
..} = [String] -> String
jsonList forall a b. (a -> b) -> a -> b
$
            [forall a. Show a => a -> String
show String
prfName
            ,forall {p}. RealFloat p => p -> String
showTime Seconds
prfExecution
            ,forall a. Show a => a -> String
show Int
prfBuilt
            ,forall a. Show a => a -> String
show Int
prfChanged
            ,forall a. Show a => a -> String
show Int
prfVisited
            ] forall a. [a] -> [a] -> [a]
++
            [forall a. Show a => a -> String
show [[Int]]
prfDepends | Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Int]]
prfDepends)]
        showTime :: p -> String
showTime p
x = if Char
'.' forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` String
y then forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'.') forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'0') String
y else String
y
            where y :: String
y = forall a. RealFloat a => Int -> a -> String
showDP Int
4 p
x

jsonListLines :: [String] -> String
jsonListLines :: [String] -> String
jsonListLines [String]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"\n," [String]
xs forall a. [a] -> [a] -> [a]
++ String
"\n]"

jsonList :: [String] -> String
jsonList :: [String] -> String
jsonList [String]
xs = String
"[" forall a. [a] -> [a] -> [a]
++ forall a. [a] -> [[a]] -> [a]
intercalate String
"," [String]
xs forall a. [a] -> [a] -> [a]
++ String
"]"

-- 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
LBS.stripPrefix ByteString
script ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; forall (f :: * -> *) a. Applicative f => a -> f a
pure 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
LBS.stripPrefix ByteString
link ByteString
y = do ByteString
res <- ByteString -> IO ByteString
grab ByteString
file; forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'\"') 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 forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
x [(String, IO ByteString)]
libraries of
                Maybe (IO ByteString)
Nothing  -> forall a. HasCallStack => String -> a
error forall a b. (a -> b) -> a -> b
$ String
"Template library, unknown library: " 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
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ String -> ByteString
LBS.pack forall a b. (a -> b) -> a -> b
$
                String
"var version = \"0\"" forall a. [a] -> [a] -> [a]
++
                String
"\nvar generated = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (forall t. FormatTime t => TimeLocale -> String -> t -> String
formatTime TimeLocale
defaultTimeLocale (Maybe String -> String
iso8601DateFormat (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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
LBS.unlines forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. IO a -> a
unsafePerformIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> IO ByteString
f) forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> [ByteString]
LBS.lines