{-# 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 qualified Data.HashMap.Strict                     as Map
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, KeyMap Int
mapping) <- Database -> IO ([ProfileEntry], KeyMap Int)
toReport Database
db
    Maybe [Int]
dirtyKeysMapped <- do
        KeySet
dirtyIds <- [Key] -> KeySet
fromListKeySet 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 a. Key -> KeyMap a -> Maybe a
`lookupKeyMap` KeyMap Int
mapping) forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> [Key]
toListKeySet forall a b. (a -> b) -> a -> b
$ KeySet
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)] -> KeyMap Result
resultsOnly :: [(Key, Status)] -> KeyMap Result
resultsOnly [(Key, Status)]
mp = forall a b. (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap (\Result
r ->
      Result
r{resultDeps :: ResultDeps
resultDeps = (KeySet -> KeySet) -> ResultDeps -> ResultDeps
mapResultDeps ((Key -> Bool) -> KeySet -> KeySet
filterKeySet (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 a. Key -> KeyMap a -> Maybe a
lookupKeyMap KeyMap Result
keep)) forall a b. (a -> b) -> a -> b
$ Result -> ResultDeps
resultDeps Result
r}
    ) KeyMap Result
keep
    where
        keep :: KeyMap Result
keep = forall a. [(Key, a)] -> KeyMap a
fromListKeyMap 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 :: (Key -> String) -> [(Key, [Key])] -> [Key]
dependencyOrder Key -> String
shw [(Key, [Key])]
status =
  [Key] -> KeyMap (Maybe [(Key, [Key])]) -> [Key]
f (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Key, [Key])]
noDeps) forall a b. (a -> b) -> a -> b
$
    forall a b. (a -> b) -> KeyMap a -> KeyMap b
mapKeyMap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
      forall a. (a -> a -> a) -> [(Key, a)] -> KeyMap a
fromListWithKeyMap forall a. [a] -> [a] -> [a]
(++)
        [(Key
d, [(Key
k,[Key]
ds)]) | (Key
k,Key
d:[Key]
ds) <- [(Key, [Key])]
hasDeps]
    where
        ([(Key, [Key])]
noDeps, [(Key, [Key])]
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) [(Key, [Key])]
status

        f :: [Key] -> KeyMap (Maybe [(Key, [Key])]) -> [Key]
f [] KeyMap (Maybe [(Key, [Key])])
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 [Key -> String
shw Key
i | (Key
i, Just [(Key, [Key])]
_) <- forall a. KeyMap a -> [(Key, a)]
toListKeyMap KeyMap (Maybe [(Key, [Key])])
mp]

        f (Key
x:[Key]
xs) KeyMap (Maybe [(Key, [Key])])
mp = Key
x forall a. a -> [a] -> [a]
: [Key] -> KeyMap (Maybe [(Key, [Key])]) -> [Key]
f ([Key]
nowforall a. [a] -> [a] -> [a]
++[Key]
xs) KeyMap (Maybe [(Key, [Key])])
later
            where Just [(Key, [Key])]
free = forall a. a -> Key -> KeyMap a -> a
lookupDefaultKeyMap (forall a. a -> Maybe a
Just []) Key
x KeyMap (Maybe [(Key, [Key])])
mp
                  ([Key]
now,KeyMap (Maybe [(Key, [Key])])
later) = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall {a}.
([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([], forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap Key
x forall a. Maybe a
Nothing KeyMap (Maybe [(Key, [Key])])
mp) [(Key, [Key])]
free

        g :: ([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, []) = (a
kforall a. a -> [a] -> [a]
:[a]
free, KeyMap (Maybe [(a, [Key])])
mp)
        g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, Key
d:[Key]
ds) = case forall a. a -> Key -> KeyMap a -> a
lookupDefaultKeyMap (forall a. a -> Maybe a
Just []) Key
d KeyMap (Maybe [(a, [Key])])
mp of
            Maybe [(a, [Key])]
Nothing   -> ([a], KeyMap (Maybe [(a, [Key])]))
-> (a, [Key]) -> ([a], KeyMap (Maybe [(a, [Key])]))
g ([a]
free, KeyMap (Maybe [(a, [Key])])
mp) (a
k, [Key]
ds)
            Just [(a, [Key])]
todo -> ([a]
free, forall a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap Key
d (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (a
k,[Key]
ds) forall a. a -> [a] -> [a]
: [(a, [Key])]
todo) KeyMap (Maybe [(a, [Key])])
mp)

prepareForDependencyOrder :: Database -> IO (KeyMap Result)
prepareForDependencyOrder :: Database -> IO (KeyMap 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 a. Key -> a -> KeyMap a -> KeyMap a
insertKeyMap (forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey String
"alwaysRerun") (Step -> Result
alwaysRerunResult Step
current) forall b c a. (b -> c) -> (a -> b) -> a -> c
.  [(Key, Status)] -> KeyMap 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], KeyMap Int)
toReport :: Database -> IO ([ProfileEntry], KeyMap Int)
toReport Database
db = do
    KeyMap Result
status <- Database -> IO (KeyMap Result)
prepareForDependencyOrder Database
db
    let order :: [Key]
order = (Key -> String) -> [(Key, [Key])] -> [Key]
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 (KeySet -> [Key]
toListKeySet forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeySet -> ResultDeps -> KeySet
getResultDepsDefault (Key -> KeySet
singletonKeySet forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey String
"alwaysRerun") forall b c a. (b -> c) -> (a -> b) -> a -> c
. Result -> ResultDeps
resultDeps))
                forall a b. (a -> b) -> a -> b
$ forall a. KeyMap a -> [(Key, a)]
toListKeyMap KeyMap Result
status
        ids :: KeyMap Int
ids = forall a. [(Key, a)] -> KeyMap a
fromListKeyMap 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 a. KeyMap a -> [a]
elemsKeyMap KeyMap 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. KeyMap a -> [a]
elemsKeyMap forall a b. (a -> b) -> a -> b
$ forall a. KeyMap a -> KeySet -> KeyMap a
restrictKeysKeyMap KeyMap Int
ids forall a b. (a -> b) -> a -> b
$ KeySet -> ResultDeps -> KeySet
getResultDepsDefault (Key -> KeySet
singletonKeySet forall a b. (a -> b) -> a -> b
$ forall a. (Eq a, Typeable a, Hashable a, Show a) => a -> Key
newKey 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 a. Key -> KeyMap a -> Maybe a
lookupKeyMap Key
i KeyMap Result
status | Key
i <- [Key]
order], KeyMap 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 (KeySet -> ResultDeps
ResultDeps forall a. Monoid a => a
mempty) 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