{-# LANGUAGE ViewPatterns, TupleSections, RecordWildCards, ScopedTypeVariables, PatternGuards #-}
{-# LANGUAGE OverloadedStrings #-}

module Action.Server(actionServer, actionReplay, action_server_test_, action_server_test) where

import Data.List.Extra
import System.FilePath
import Control.Exception
import Control.Exception.Extra
import Control.DeepSeq
import System.Directory
import Text.Blaze
import Text.Blaze.Renderer.Utf8
import qualified Text.Blaze.XHtml5 as H
import qualified Text.Blaze.XHtml5.Attributes as H
import Data.Tuple.Extra
import qualified Language.Javascript.JQuery as JQuery
import qualified Language.Javascript.Flot as Flot
import Data.Version
import Paths_hoogle
import Data.Maybe
import Control.Monad.Extra
import Text.Read
import System.IO.Extra
import General.Str
import qualified Data.ByteString.Char8 as BS
import qualified Data.ByteString.Lazy.Char8 as LBS
import qualified Data.Map as Map
import System.Time.Extra
import Data.Time.Clock
import Data.Time.Calendar
import System.IO.Unsafe
import Numeric.Extra
import System.Info.Extra

import Output.Tags
import Query
import Input.Item
import General.Util
import General.Web
import General.Store
import General.Template
import General.Log
import Action.Search
import Action.CmdLine
import Control.Applicative
import Data.Monoid
import Prelude

import qualified Data.Aeson as JSON

actionServer :: CmdLine -> IO ()
actionServer :: CmdLine -> IO ()
actionServer cmd :: CmdLine
cmd@Server{Bool
Int
FilePath
Maybe FilePath
Language
no_security_headers :: CmdLine -> Bool
datadir :: CmdLine -> Maybe FilePath
key :: CmdLine -> FilePath
cert :: CmdLine -> FilePath
https :: CmdLine -> Bool
host :: CmdLine -> FilePath
home :: CmdLine -> FilePath
scope :: CmdLine -> FilePath
links :: CmdLine -> Bool
local :: CmdLine -> Bool
logs :: CmdLine -> FilePath
cdn :: CmdLine -> FilePath
port :: CmdLine -> Int
haddock :: CmdLine -> Maybe FilePath
language :: CmdLine -> Language
database :: CmdLine -> FilePath
no_security_headers :: Bool
datadir :: Maybe FilePath
key :: FilePath
cert :: FilePath
https :: Bool
host :: FilePath
home :: FilePath
scope :: FilePath
language :: Language
links :: Bool
haddock :: Maybe FilePath
local :: Bool
logs :: FilePath
cdn :: FilePath
database :: FilePath
port :: Int
..} = do
    -- so I can get good error messages
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
    Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Server started on port " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
port
    FilePath -> IO ()
putStr FilePath
"Reading log..." IO () -> IO () -> IO ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Handle -> IO ()
hFlush Handle
stdout
    IO Seconds
time <- IO (IO Seconds)
offsetTime
    Log
log <- Either Handle FilePath -> (ByteString -> Bool) -> IO Log
logCreate (if FilePath
logs FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"" then Handle -> Either Handle FilePath
forall a b. a -> Either a b
Left Handle
stdout else FilePath -> Either Handle FilePath
forall a b. b -> Either a b
Right FilePath
logs) ((ByteString -> Bool) -> IO Log) -> (ByteString -> Bool) -> IO Log
forall a b. (a -> b) -> a -> b
$
        \ByteString
x -> FilePath -> ByteString
BS.pack FilePath
"hoogle=" ByteString -> ByteString -> Bool
`BS.isInfixOf` ByteString
x Bool -> Bool -> Bool
&& Bool -> Bool
not (FilePath -> ByteString
BS.pack FilePath
"is:ping" ByteString -> ByteString -> Bool
`BS.isInfixOf` ByteString
x)
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> (Seconds -> FilePath) -> Seconds -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Seconds -> FilePath
showDuration (Seconds -> IO ()) -> IO Seconds -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO Seconds
time
    UTCTime -> IO UTCTime
forall a. a -> IO a
evaluate UTCTime
spawned
    FilePath
dataDir <- IO FilePath
-> (FilePath -> IO FilePath) -> Maybe FilePath -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
getDataDir FilePath -> IO FilePath
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
datadir
    Maybe FilePath
haddock <- IO (Maybe FilePath)
-> (FilePath -> IO (Maybe FilePath))
-> Maybe FilePath
-> IO (Maybe FilePath)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe FilePath
forall a. Maybe a
Nothing) ((FilePath -> Maybe FilePath) -> IO FilePath -> IO (Maybe FilePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (IO FilePath -> IO (Maybe FilePath))
-> (FilePath -> IO FilePath) -> FilePath -> IO (Maybe FilePath)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> IO FilePath
canonicalizePath) Maybe FilePath
haddock
    FilePath -> (StoreRead -> IO ()) -> IO ()
forall a. NFData a => FilePath -> (StoreRead -> IO a) -> IO a
withSearch FilePath
database ((StoreRead -> IO ()) -> IO ()) -> (StoreRead -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StoreRead
store ->
        Log -> CmdLine -> (Input -> IO Output) -> IO ()
server Log
log CmdLine
cmd ((Input -> IO Output) -> IO ()) -> (Input -> IO Output) -> IO ()
forall a b. (a -> b) -> a -> b
$ Log
-> Bool
-> Bool
-> Maybe FilePath
-> StoreRead
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Input
-> IO Output
replyServer Log
log Bool
local Bool
links Maybe FilePath
haddock StoreRead
store FilePath
cdn FilePath
home (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
"html") FilePath
scope

actionReplay :: CmdLine -> IO ()
actionReplay :: CmdLine -> IO ()
actionReplay Replay{Int
FilePath
Language
repeat_ :: CmdLine -> Int
scope :: FilePath
language :: Language
repeat_ :: Int
database :: FilePath
logs :: FilePath
scope :: CmdLine -> FilePath
logs :: CmdLine -> FilePath
language :: CmdLine -> Language
database :: CmdLine -> FilePath
..} = Handle -> BufferMode -> IO () -> IO ()
forall a. Handle -> BufferMode -> IO a -> IO a
withBuffering Handle
stdout BufferMode
NoBuffering (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
    FilePath
src <- FilePath -> IO FilePath
readFile FilePath
logs
    let qs :: [Input]
qs = [Maybe Input] -> [Input]
forall a. [Maybe a] -> [a]
catMaybes [FilePath -> Maybe Input
readInput FilePath
url | FilePath
_:FilePath
ip:FilePath
_:FilePath
url:[FilePath]
_ <- (FilePath -> [FilePath]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map FilePath -> [FilePath]
words ([FilePath] -> [[FilePath]]) -> [FilePath] -> [[FilePath]]
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath]
lines FilePath
src, FilePath
ip FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"-"]
    (Seconds
t,()
_) <- IO () -> IO (Seconds, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Seconds, a)
duration (IO () -> IO (Seconds, ())) -> IO () -> IO (Seconds, ())
forall a b. (a -> b) -> a -> b
$ FilePath -> (StoreRead -> IO ()) -> IO ()
forall a. NFData a => FilePath -> (StoreRead -> IO a) -> IO a
withSearch FilePath
database ((StoreRead -> IO ()) -> IO ()) -> (StoreRead -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StoreRead
store -> do
        Log
log <- IO Log
logNone
        FilePath
dataDir <- IO FilePath
getDataDir
        let op :: Input -> IO Output
op = Log
-> Bool
-> Bool
-> Maybe FilePath
-> StoreRead
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Input
-> IO Output
replyServer Log
log Bool
False Bool
False Maybe FilePath
forall a. Maybe a
Nothing StoreRead
store FilePath
"" FilePath
"" (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
"html") FilePath
scope
        Int -> IO () -> IO ()
forall (m :: * -> *) a. Applicative m => Int -> m a -> m ()
replicateM_ Int
repeat_ (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ [Input] -> (Input -> IO ()) -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Input]
qs ((Input -> IO ()) -> IO ()) -> (Input -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Input
x -> do
            Output
res <- Input -> IO Output
op Input
x
            () -> IO ()
forall a. a -> IO a
evaluate (() -> IO ()) -> () -> IO ()
forall a b. (a -> b) -> a -> b
$ Output -> ()
forall a. NFData a => a -> ()
rnf Output
res
            Char -> IO ()
putChar Char
'.'
    FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"\nTook " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Seconds -> FilePath
showDuration Seconds
t FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" (" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Seconds -> FilePath
showDuration (Seconds
t Seconds -> Seconds -> Seconds
forall a. Fractional a => a -> a -> a
/ Int -> Seconds
intToDouble (Int
repeat_ Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Input] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Input]
qs)) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
")"

{-# NOINLINE spawned #-}
spawned :: UTCTime
spawned :: UTCTime
spawned = IO UTCTime -> UTCTime
forall a. IO a -> a
unsafePerformIO IO UTCTime
getCurrentTime

replyServer :: Log -> Bool -> Bool -> Maybe FilePath -> StoreRead -> String -> String -> FilePath -> String -> Input -> IO Output
replyServer :: Log
-> Bool
-> Bool
-> Maybe FilePath
-> StoreRead
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Input
-> IO Output
replyServer Log
log Bool
local Bool
links Maybe FilePath
haddock StoreRead
store FilePath
cdn FilePath
home FilePath
htmlDir FilePath
scope Input{[FilePath]
[(FilePath, FilePath)]
inputArgs :: Input -> [(FilePath, FilePath)]
inputURL :: Input -> [FilePath]
inputArgs :: [(FilePath, FilePath)]
inputURL :: [FilePath]
..} = case [FilePath]
inputURL of
    -- without -fno-state-hack things can get folded under this lambda
    [] -> do
        let grabBy :: (FilePath -> Bool) -> [FilePath]
grabBy FilePath -> Bool
name = [FilePath
x | (FilePath
a,FilePath
x) <- [(FilePath, FilePath)]
inputArgs, FilePath -> Bool
name FilePath
a, FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
""]
            grab :: FilePath -> [FilePath]
grab FilePath
name = (FilePath -> Bool) -> [FilePath]
grabBy (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
name)
            grabInt :: FilePath -> Int -> Int
grabInt FilePath
name Int
def = Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
def (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Maybe Int
forall a. Read a => FilePath -> Maybe a
readMaybe (FilePath -> Maybe Int) -> Maybe FilePath -> Maybe Int
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [FilePath] -> Maybe FilePath
forall a. [a] -> Maybe a
listToMaybe (FilePath -> [FilePath]
grab FilePath
name) :: Int

        let qScope :: [FilePath]
qScope = let xs :: [FilePath]
xs = FilePath -> [FilePath]
grab FilePath
"scope" in [FilePath
scope | [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
xs Bool -> Bool -> Bool
&& FilePath
scope FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
""] [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ [FilePath]
xs
        let qSearch :: [FilePath]
qSearch = (FilePath -> Bool) -> [FilePath]
grabBy (FilePath -> [FilePath] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [FilePath
"hoogle",FilePath
"q"])
        let qSource :: [FilePath]
qSource = [FilePath]
qSearch [FilePath] -> [FilePath] -> [FilePath]
forall a. [a] -> [a] -> [a]
++ (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"set:stackage") [FilePath]
qScope
        let q :: [Query]
q = (FilePath -> [Query]) -> [FilePath] -> [Query]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap FilePath -> [Query]
parseQuery [FilePath]
qSource
        let ([Query]
q2, [Target]
results) = StoreRead -> [Query] -> ([Query], [Target])
search StoreRead
store [Query]
q
        let body :: Markup
body = Bool
-> Bool
-> Maybe FilePath
-> [(FilePath, FilePath)]
-> [Query]
-> [[Target]]
-> Markup
showResults Bool
local Bool
links Maybe FilePath
haddock (((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
"mode") (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
inputArgs) [Query]
q2 ([[Target]] -> Markup) -> [[Target]] -> Markup
forall a b. (a -> b) -> a -> b
$
                Int -> (Target -> Target) -> [Target] -> [[Target]]
forall k v. Ord k => Int -> (v -> k) -> [v] -> [[v]]
dedupeTake Int
25 (\Target
t -> Target
t{targetURL :: FilePath
targetURL=FilePath
"",targetPackage :: Maybe (FilePath, FilePath)
targetPackage=Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing, targetModule :: Maybe (FilePath, FilePath)
targetModule=Maybe (FilePath, FilePath)
forall a. Maybe a
Nothing}) [Target]
results
        case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"mode" [(FilePath, FilePath)]
inputArgs of
            Maybe FilePath
Nothing | [FilePath]
qSource [FilePath] -> [FilePath] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] -> (ByteString -> Output) -> IO ByteString -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Output
OutputHTML (IO ByteString -> IO Output) -> IO ByteString -> IO Output
forall a b. (a -> b) -> a -> b
$ Template -> [(FilePath, Template)] -> IO ByteString
templateRender Template
templateIndex
                        [(FilePath
"tags", Markup -> Template
html (Markup -> Template) -> Markup -> Template
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Markup
forall (t :: * -> *). Foldable t => t FilePath -> Markup
tagOptions [FilePath]
qScope)
                        ,(FilePath
"body", Markup -> Template
html Markup
body)
                        ,(FilePath
"title", FilePath -> Template
text (FilePath -> Template) -> FilePath -> Template
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath]
qSource FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" - Hoogle")
                        ,(FilePath
"search", FilePath -> Template
text (FilePath -> Template) -> FilePath -> Template
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
unwords [FilePath]
qSearch)
                        ,(FilePath
"robots", FilePath -> Template
text (FilePath -> Template) -> FilePath -> Template
forall a b. (a -> b) -> a -> b
$ if (Query -> Bool) -> [Query] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any Query -> Bool
isQueryScope [Query]
q then FilePath
"none" else FilePath
"index")]
                    | Bool
otherwise -> ByteString -> Output
OutputHTML (ByteString -> Output) -> IO ByteString -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [(FilePath, Template)] -> IO ByteString
templateRender Template
templateHome []
            Just FilePath
"body" -> ByteString -> Output
OutputHTML (ByteString -> Output) -> IO ByteString -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if [FilePath] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
qSource then Template -> [(FilePath, Template)] -> IO ByteString
templateRender Template
templateEmpty [] else Template -> [(FilePath, Template)] -> IO ByteString
templateRender (Markup -> Template
html Markup
body) []
            Just FilePath
"json" ->
              let -- 1 means don't drop anything, if it's less than 1 ignore it
                  start :: Int
                  start :: Int
start = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> Int
grabInt FilePath
"start" Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
                  -- by default it returns 100 entries
                  count :: Int
                  count :: Int
count = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min Int
500 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ FilePath -> Int -> Int
grabInt FilePath
"count" Int
100
                  filteredResults :: [Target]
filteredResults = Int -> [Target] -> [Target]
forall a. Int -> [a] -> [a]
take Int
count ([Target] -> [Target]) -> [Target] -> [Target]
forall a b. (a -> b) -> a -> b
$ Int -> [Target] -> [Target]
forall a. Int -> [a] -> [a]
drop Int
start [Target]
results
              in case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"format" [(FilePath, FilePath)]
inputArgs of
                Just FilePath
"text" -> Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ Encoding -> Output
OutputJSON (Encoding -> Output) -> Encoding -> Output
forall a b. (a -> b) -> a -> b
$ [Target] -> Encoding
forall a. ToJSON a => a -> Encoding
JSON.toEncoding ([Target] -> Encoding) -> [Target] -> Encoding
forall a b. (a -> b) -> a -> b
$ (Target -> Target) -> [Target] -> [Target]
forall a b. (a -> b) -> [a] -> [b]
map Target -> Target
unHTMLTarget [Target]
filteredResults
                Just FilePath
f -> Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ ByteString -> Output
OutputFail (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Format mode " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
f FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not (currently) supported"
                Maybe FilePath
Nothing -> Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ Encoding -> Output
OutputJSON (Encoding -> Output) -> Encoding -> Output
forall a b. (a -> b) -> a -> b
$ [Target] -> Encoding
forall a. ToJSON a => a -> Encoding
JSON.toEncoding [Target]
filteredResults
            Just FilePath
m -> Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ ByteString -> Output
OutputFail (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath
"Mode " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
m FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" not (currently) supported"
    [FilePath
"plugin",FilePath
"jquery.js"] -> FilePath -> Output
OutputFile (FilePath -> Output) -> IO FilePath -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
JQuery.file
    [FilePath
"plugin",FilePath
"jquery.flot.js"] -> FilePath -> Output
OutputFile (FilePath -> Output) -> IO FilePath -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flot -> IO FilePath
Flot.file Flot
Flot.Flot
    [FilePath
"plugin",FilePath
"jquery.flot.time.js"] -> FilePath -> Output
OutputFile (FilePath -> Output) -> IO FilePath -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flot -> IO FilePath
Flot.file Flot
Flot.FlotTime

    [FilePath
"canary"] -> do
        UTCTime
now <- IO UTCTime
getCurrentTime
        [Summary]
summ <- Log -> IO [Summary]
logSummary Log
log
        let errs :: Int
errs = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
summaryErrors | Summary{Seconds
Int
Day
Average Seconds
summaryErrors :: Summary -> Int
summaryAverage :: Summary -> Average Seconds
summarySlowest :: Summary -> Seconds
summaryUses :: Summary -> Int
summaryUsers :: Summary -> Int
summaryDate :: Summary -> Day
summaryAverage :: Average Seconds
summarySlowest :: Seconds
summaryUses :: Int
summaryUsers :: Int
summaryDate :: Day
summaryErrors :: Int
..} <- [Summary]
summ, Day
summaryDate Day -> Day -> Bool
forall a. Ord a => a -> a -> Bool
>= Day -> Day
forall a. Enum a => a -> a
pred (UTCTime -> Day
utctDay UTCTime
now)]
        let alive :: Seconds
alive = Rational -> Seconds
forall a. Fractional a => Rational -> a
fromRational (Rational -> Seconds) -> Rational -> Seconds
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Rational
forall a. Real a => a -> Rational
toRational (NominalDiffTime -> Rational) -> NominalDiffTime -> Rational
forall a b. (a -> b) -> a -> b
$ (UTCTime
now UTCTime -> UTCTime -> NominalDiffTime
`diffUTCTime` UTCTime
spawned) NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Fractional a => a -> a -> a
/ (NominalDiffTime
24 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60 NominalDiffTime -> NominalDiffTime -> NominalDiffTime
forall a. Num a => a -> a -> a
* NominalDiffTime
60)
        Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ (if Int
errs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 Bool -> Bool -> Bool
&& Seconds
alive Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds
1.5 then ByteString -> Output
OutputText else ByteString -> Output
OutputFail) (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$
            FilePath
"Errors " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if Int
errs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then FilePath
"good" else FilePath
"bad") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
errs FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" in the last 24 hours.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
            FilePath
"Updates " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if Seconds
alive Seconds -> Seconds -> Bool
forall a. Ord a => a -> a -> Bool
< Seconds
1.5 then FilePath
"good" else FilePath
"bad") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": Last updated " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> Seconds -> FilePath
forall a. RealFloat a => Int -> a -> FilePath
showDP Int
2 Seconds
alive FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" days ago.\n"

    [FilePath
"log"] -> do
        ByteString -> Output
OutputHTML (ByteString -> Output) -> IO ByteString -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [(FilePath, Template)] -> IO ByteString
templateRender Template
templateLog []
    [FilePath
"log.js"] -> do
        FilePath
log <- [Summary] -> FilePath
displayLog ([Summary] -> FilePath) -> IO [Summary] -> IO FilePath
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Log -> IO [Summary]
logSummary Log
log
        ByteString -> Output
OutputJavascript (ByteString -> Output) -> IO ByteString -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [(FilePath, Template)] -> IO ByteString
templateRender Template
templateLogJs [(FilePath
"data",Markup -> Template
html (Markup -> Template) -> Markup -> Template
forall a b. (a -> b) -> a -> b
$ FilePath -> Markup
H.preEscapedString FilePath
log)]
    [FilePath
"stats"] -> do
        Maybe FilePath
stats <- IO (Maybe FilePath)
getStatsDebug
        Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ case Maybe FilePath
stats of
            Maybe FilePath
Nothing -> ByteString -> Output
OutputFail (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack FilePath
"GHC Statistics is not enabled, restart with +RTS -T"
            Just FilePath
x -> ByteString -> Output
OutputText (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
", " FilePath
"\n" (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'}') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. [a] -> [a]
drop1 (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> FilePath -> FilePath
forall a. (a -> Bool) -> [a] -> [a]
dropWhile (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'{') (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
x
    FilePath
"haddock":[FilePath]
xs | Just FilePath
x <- Maybe FilePath
haddock -> do
        let file :: FilePath
file = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
xFilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
:[FilePath]
xs
        Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ FilePath -> Output
OutputFile (FilePath -> Output) -> FilePath -> Output
forall a b. (a -> b) -> a -> b
$ FilePath
file FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if FilePath -> Bool
hasTrailingPathSeparator FilePath
file then FilePath
"index.html" else FilePath
"")
    FilePath
"file":[FilePath]
xs | Bool
local -> do
        let x :: FilePath
x = [Char
'/' | Bool -> Bool
not Bool
isWindows] FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"/" ((FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [FilePath]
xs)
        let file :: FilePath
file = FilePath
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (if FilePath -> Bool
hasTrailingPathSeparator FilePath
x then FilePath
"index.html" else FilePath
"")
        if FilePath -> FilePath
takeExtension FilePath
file FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
".html" then
            Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ FilePath -> Output
OutputFile FilePath
file
         else do
            FilePath
src <- FilePath -> IO FilePath
readFile FilePath
file
            -- Haddock incorrectly generates file:// on Windows, when it should be file:///
            -- so replace on file:// and drop all leading empty paths above
            Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ ByteString -> Output
OutputHTML (ByteString -> Output) -> ByteString -> Output
forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
lbstrPack (FilePath -> ByteString) -> FilePath -> ByteString
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"file://" FilePath
"/file/" FilePath
src
    [FilePath]
xs ->
        Output -> IO Output
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ FilePath -> Output
OutputFile (FilePath -> Output) -> FilePath -> Output
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
joinPath ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
htmlDir FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [FilePath]
xs
    where
        html :: Markup -> Template
html = Markup -> Template
templateMarkup
        text :: FilePath -> Template
text = Markup -> Template
templateMarkup (Markup -> Template)
-> (FilePath -> Markup) -> FilePath -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> Markup
H.string

        tagOptions :: t FilePath -> Markup
tagOptions t FilePath
sel = [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat [Markup -> Markup
H.option (Markup -> Markup) -> (Bool, Attribute) -> Markup -> Markup
forall h. Attributable h => h -> (Bool, Attribute) -> h
Text.Blaze.!? (FilePath
x FilePath -> t FilePath -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t FilePath
sel, AttributeValue -> Attribute
H.selected AttributeValue
"selected") (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ FilePath -> Markup
H.string FilePath
x | FilePath
x <- StoreRead -> [FilePath]
completionTags StoreRead
store]
        params :: [(FilePath, Template)]
params =
            [(FilePath
"cdn", FilePath -> Template
text FilePath
cdn)
            ,(FilePath
"home", FilePath -> Template
text FilePath
home)
            ,(FilePath
"jquery", FilePath -> Template
text (FilePath -> Template) -> FilePath -> Template
forall a b. (a -> b) -> a -> b
$ if FilePath -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null FilePath
cdn then FilePath
"plugin/jquery.js" else FilePath
"https:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
JQuery.url)
            ,(FilePath
"version", FilePath -> Template
text (FilePath -> Template) -> FilePath -> Template
forall a b. (a -> b) -> a -> b
$ Version -> FilePath
showVersion Version
version FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> UTCTime -> FilePath
showUTCTime FilePath
"%Y-%m-%d %H:%M" UTCTime
spawned)]
        templateIndex :: Template
templateIndex = FilePath -> Template
templateFile (FilePath
htmlDir FilePath -> FilePath -> FilePath
</> FilePath
"index.html") Template -> [(FilePath, Template)] -> Template
`templateApply` [(FilePath, Template)]
params
        templateEmpty :: Template
templateEmpty = FilePath -> Template
templateFile (FilePath
htmlDir FilePath -> FilePath -> FilePath
</>  FilePath
"welcome.html")
        templateHome :: Template
templateHome = Template
templateIndex Template -> [(FilePath, Template)] -> Template
`templateApply` [(FilePath
"tags",Markup -> Template
html (Markup -> Template) -> Markup -> Template
forall a b. (a -> b) -> a -> b
$ [FilePath] -> Markup
forall (t :: * -> *). Foldable t => t FilePath -> Markup
tagOptions []),(FilePath
"body",Template
templateEmpty),(FilePath
"title",FilePath -> Template
text FilePath
"Hoogle"),(FilePath
"search",FilePath -> Template
text FilePath
""),(FilePath
"robots",FilePath -> Template
text FilePath
"index")]
        templateLog :: Template
templateLog = FilePath -> Template
templateFile (FilePath
htmlDir FilePath -> FilePath -> FilePath
</> FilePath
"log.html") Template -> [(FilePath, Template)] -> Template
`templateApply` [(FilePath, Template)]
params
        templateLogJs :: Template
templateLogJs = FilePath -> Template
templateFile (FilePath
htmlDir FilePath -> FilePath -> FilePath
</> FilePath
"log.js") Template -> [(FilePath, Template)] -> Template
`templateApply` [(FilePath, Template)]
params


dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]]
dedupeTake :: Int -> (v -> k) -> [v] -> [[v]]
dedupeTake Int
n v -> k
key = [k] -> Map k [v] -> [v] -> [[v]]
f [] Map k [v]
forall k a. Map k a
Map.empty
    where
        -- map is Map k [v]
        f :: [k] -> Map k [v] -> [v] -> [[v]]
f [k]
res Map k [v]
mp [v]
xs | Map k [v] -> Int
forall k a. Map k a -> Int
Map.size Map k [v]
mp Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
n Bool -> Bool -> Bool
|| [v] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [v]
xs = (k -> [v]) -> [k] -> [[v]]
forall a b. (a -> b) -> [a] -> [b]
map ([v] -> [v]
forall a. [a] -> [a]
reverse ([v] -> [v]) -> (k -> [v]) -> k -> [v]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k [v] -> k -> [v]
forall k a. Ord k => Map k a -> k -> a
(Map.!) Map k [v]
mp) ([k] -> [[v]]) -> [k] -> [[v]]
forall a b. (a -> b) -> a -> b
$ [k] -> [k]
forall a. [a] -> [a]
reverse [k]
res
        f [k]
res Map k [v]
mp (v
x:[v]
xs) | Just [v]
vs <- k -> Map k [v] -> Maybe [v]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup k
k Map k [v]
mp = [k] -> Map k [v] -> [v] -> [[v]]
f [k]
res (k -> [v] -> Map k [v] -> Map k [v]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k (v
xv -> [v] -> [v]
forall a. a -> [a] -> [a]
:[v]
vs) Map k [v]
mp) [v]
xs
                        | Bool
otherwise = [k] -> Map k [v] -> [v] -> [[v]]
f (k
kk -> [k] -> [k]
forall a. a -> [a] -> [a]
:[k]
res) (k -> [v] -> Map k [v] -> Map k [v]
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k [v
x] Map k [v]
mp) [v]
xs
            where k :: k
k = v -> k
key v
x


showResults :: Bool -> Bool -> Maybe FilePath -> [(String, String)] -> [Query] -> [[Target]] -> Markup
showResults :: Bool
-> Bool
-> Maybe FilePath
-> [(FilePath, FilePath)]
-> [Query]
-> [[Target]]
-> Markup
showResults Bool
local Bool
links Maybe FilePath
haddock [(FilePath, FilePath)]
args [Query]
query [[Target]]
results = do
    Markup -> Markup
H.h1 (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ [Query] -> Markup
renderQuery [Query]
query
    Markup -> Markup
H.ul (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.id AttributeValue
"left" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
        Markup -> Markup
H.li (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.b Markup
"Packages"
        [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat [Markup -> Markup
H.li (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath -> Markup
f FilePath
cat FilePath
val | (FilePath
cat,FilePath
val) <- [Target] -> [(FilePath, FilePath)]
itemCategories ([Target] -> [(FilePath, FilePath)])
-> [Target] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ [[Target]] -> [Target]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Target]]
results, Bool -> FilePath -> FilePath -> Query
QueryScope Bool
True FilePath
cat FilePath
val Query -> [Query] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Query]
query]
    Bool -> Markup -> Markup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Target]] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Target]]
results) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.p Markup
"No results found"
    [[Target]] -> ([Target] -> Markup) -> Markup
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[Target]]
results (([Target] -> Markup) -> Markup) -> ([Target] -> Markup) -> Markup
forall a b. (a -> b) -> a -> b
$ \is :: [Target]
is@(Target{FilePath
Maybe (FilePath, FilePath)
targetDocs :: Target -> FilePath
targetItem :: Target -> FilePath
targetType :: Target -> FilePath
targetDocs :: FilePath
targetItem :: FilePath
targetType :: FilePath
targetModule :: Maybe (FilePath, FilePath)
targetPackage :: Maybe (FilePath, FilePath)
targetURL :: FilePath
targetModule :: Target -> Maybe (FilePath, FilePath)
targetPackage :: Target -> Maybe (FilePath, FilePath)
targetURL :: Target -> FilePath
..}:[Target]
_) -> do
        Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"result" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
            Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"ans" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ do
                Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.href (FilePath -> AttributeValue
H.stringValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> FilePath -> FilePath
showURL Bool
local Maybe FilePath
haddock FilePath
targetURL) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
                    [Query] -> FilePath -> Markup
displayItem [Query]
query FilePath
targetItem
                Bool -> Markup -> Markup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
links (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
                    Maybe FilePath -> (FilePath -> Markup) -> Markup
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Target] -> Maybe FilePath
useLink [Target]
is) ((FilePath -> Markup) -> Markup) -> (FilePath -> Markup) -> Markup
forall a b. (a -> b) -> a -> b
$ \FilePath
link ->
                        Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"links" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.href (FilePath -> AttributeValue
H.stringValue FilePath
link) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
"Uses"
            Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"from" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> [Target] -> Markup
showFroms Bool
local Maybe FilePath
haddock [Target]
is
            Markup -> Markup
H.div (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"doc newline shut" (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ FilePath -> Markup
H.preEscapedString FilePath
targetDocs
    where
        useLink :: [Target] -> Maybe String
        useLink :: [Target] -> Maybe FilePath
useLink [Target
t] | Maybe (FilePath, FilePath) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (FilePath, FilePath) -> Bool)
-> Maybe (FilePath, FilePath) -> Bool
forall a b. (a -> b) -> a -> b
$ Target -> Maybe (FilePath, FilePath)
targetPackage Target
t =
            FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (FilePath -> Maybe FilePath) -> FilePath -> Maybe FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"https://packdeps.haskellers.com/reverse/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
extractName (Target -> FilePath
targetItem Target
t)
        useLink [Target]
_ = Maybe FilePath
forall a. Maybe a
Nothing

        add :: FilePath -> FilePath
add FilePath
x = (FilePath
"?" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++) (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"&" ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$ ((FilePath, FilePath) -> FilePath)
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (FilePath -> (FilePath, FilePath) -> FilePath
forall a. [a] -> ([a], [a]) -> [a]
joinPair FilePath
"=") ([(FilePath, FilePath)] -> [FilePath])
-> [(FilePath, FilePath)] -> [FilePath]
forall a b. (a -> b) -> a -> b
$
            case ((FilePath, FilePath) -> Bool)
-> [(FilePath, FilePath)]
-> ([(FilePath, FilePath)], [(FilePath, FilePath)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) FilePath
"hoogle" (FilePath -> Bool)
-> ((FilePath, FilePath) -> FilePath)
-> (FilePath, FilePath)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FilePath, FilePath) -> FilePath
forall a b. (a, b) -> a
fst) [(FilePath, FilePath)]
args of
                ([(FilePath, FilePath)]
a,[]) -> [(FilePath, FilePath)]
a [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"hoogle", FilePath -> FilePath
escapeURL FilePath
x)]
                ([(FilePath, FilePath)]
a,(FilePath
_,FilePath
x1):[(FilePath, FilePath)]
b) -> [(FilePath, FilePath)]
a [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath
"hoogle", FilePath -> FilePath
escapeURL (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
x1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x)] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++ [(FilePath, FilePath)]
b

        f :: FilePath -> FilePath -> Markup
f FilePath
cat FilePath
val = do
            Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_AttributeValue
" minus" (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.href (FilePath -> AttributeValue
H.stringValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
add (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
val) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ Markup
""
            Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.class_ AttributeValue
"plus"  (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.href (FilePath -> AttributeValue
H.stringValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ FilePath -> FilePath
add (FilePath -> FilePath) -> FilePath -> FilePath
forall a b. (a -> b) -> a -> b
$        FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
val) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
                FilePath -> Markup
H.string (FilePath -> Markup) -> FilePath -> Markup
forall a b. (a -> b) -> a -> b
$ (if FilePath
cat FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"package" then FilePath
"" else FilePath
cat FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":") FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
val


-- find the <span class=name>X</span> bit
extractName :: String -> String
extractName :: FilePath -> FilePath
extractName FilePath
x
    | Just (FilePath
_, FilePath
x) <- FilePath -> FilePath -> Maybe (FilePath, FilePath)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix FilePath
"<span class=name>" FilePath
x
    , Just (FilePath
x, FilePath
_) <- FilePath -> FilePath -> Maybe (FilePath, FilePath)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix FilePath
"</span>" FilePath
x
    = FilePath -> FilePath
unHTML FilePath
x
extractName FilePath
x = FilePath
x


itemCategories :: [Target] -> [(String,String)]
itemCategories :: [Target] -> [(FilePath, FilePath)]
itemCategories [Target]
xs =
    [(FilePath
"is",FilePath
"exact")] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++
    [(FilePath
"is",FilePath
"package") | (Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) FilePath
"package" (FilePath -> Bool) -> (Target -> FilePath) -> Target -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> FilePath
targetType) [Target]
xs] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++
    [(FilePath
"is",FilePath
"module")  | (Target -> Bool) -> [Target] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
(==) FilePath
"module"  (FilePath -> Bool) -> (Target -> FilePath) -> Target -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> FilePath
targetType) [Target]
xs] [(FilePath, FilePath)]
-> [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [a] -> [a] -> [a]
++
    [(FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. Ord a => [a] -> [a]
nubOrd [(FilePath
"package",FilePath
p) | Just (FilePath
p,FilePath
_) <- (Target -> Maybe (FilePath, FilePath))
-> [Target] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map Target -> Maybe (FilePath, FilePath)
targetPackage [Target]
xs]

showFroms :: Bool -> Maybe FilePath -> [Target] -> Markup
showFroms :: Bool -> Maybe FilePath -> [Target] -> Markup
showFroms Bool
local Maybe FilePath
haddock [Target]
xs = [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat ([Markup] -> Markup) -> [Markup] -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> [Markup] -> [Markup]
forall a. a -> [a] -> [a]
intersperse Markup
", " ([Markup] -> [Markup]) -> [Markup] -> [Markup]
forall a b. (a -> b) -> a -> b
$ ((Maybe (FilePath, FilePath) -> Markup)
 -> [Maybe (FilePath, FilePath)] -> [Markup])
-> [Maybe (FilePath, FilePath)]
-> (Maybe (FilePath, FilePath) -> Markup)
-> [Markup]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (Maybe (FilePath, FilePath) -> Markup)
-> [Maybe (FilePath, FilePath)] -> [Markup]
forall a b. (a -> b) -> [a] -> [b]
map [Maybe (FilePath, FilePath)]
pkgs ((Maybe (FilePath, FilePath) -> Markup) -> [Markup])
-> (Maybe (FilePath, FilePath) -> Markup) -> [Markup]
forall a b. (a -> b) -> a -> b
$ \Maybe (FilePath, FilePath)
p ->
    let ms :: [Target]
ms = (Target -> Bool) -> [Target] -> [Target]
forall a. (a -> Bool) -> [a] -> [a]
filter (Maybe (FilePath, FilePath) -> Maybe (FilePath, FilePath) -> Bool
forall a. Eq a => a -> a -> Bool
(==) Maybe (FilePath, FilePath)
p (Maybe (FilePath, FilePath) -> Bool)
-> (Target -> Maybe (FilePath, FilePath)) -> Target -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Target -> Maybe (FilePath, FilePath)
targetPackage) [Target]
xs
    in [Markup] -> Markup
forall a. Monoid a => [a] -> a
mconcat ([Markup] -> Markup) -> [Markup] -> Markup
forall a b. (a -> b) -> a -> b
$ Markup -> [Markup] -> [Markup]
forall a. a -> [a] -> [a]
intersperse Markup
" " [Markup -> Markup
H.a (Markup -> Markup) -> Attribute -> Markup -> Markup
forall h. Attributable h => h -> Attribute -> h
! AttributeValue -> Attribute
H.href (FilePath -> AttributeValue
H.stringValue (FilePath -> AttributeValue) -> FilePath -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe FilePath -> FilePath -> FilePath
showURL Bool
local Maybe FilePath
haddock FilePath
b) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$ FilePath -> Markup
H.string FilePath
a | (FilePath
a,FilePath
b) <- [Maybe (FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (FilePath, FilePath)] -> [(FilePath, FilePath)])
-> [Maybe (FilePath, FilePath)] -> [(FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ Maybe (FilePath, FilePath)
p Maybe (FilePath, FilePath)
-> [Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)]
forall a. a -> [a] -> [a]
: (Target -> Maybe (FilePath, FilePath))
-> [Target] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map Target -> Maybe (FilePath, FilePath)
remod [Target]
ms]
    where
        remod :: Target -> Maybe (FilePath, FilePath)
remod Target{FilePath
Maybe (FilePath, FilePath)
targetDocs :: FilePath
targetItem :: FilePath
targetType :: FilePath
targetModule :: Maybe (FilePath, FilePath)
targetPackage :: Maybe (FilePath, FilePath)
targetURL :: FilePath
targetDocs :: Target -> FilePath
targetItem :: Target -> FilePath
targetType :: Target -> FilePath
targetModule :: Target -> Maybe (FilePath, FilePath)
targetPackage :: Target -> Maybe (FilePath, FilePath)
targetURL :: Target -> FilePath
..} = do (FilePath
a,FilePath
_) <- Maybe (FilePath, FilePath)
targetModule; (FilePath, FilePath) -> Maybe (FilePath, FilePath)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FilePath
a,FilePath
targetURL)
        pkgs :: [Maybe (FilePath, FilePath)]
pkgs = [Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)]
forall a. Ord a => [a] -> [a]
nubOrd ([Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)])
-> [Maybe (FilePath, FilePath)] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> a -> b
$ (Target -> Maybe (FilePath, FilePath))
-> [Target] -> [Maybe (FilePath, FilePath)]
forall a b. (a -> b) -> [a] -> [b]
map Target -> Maybe (FilePath, FilePath)
targetPackage [Target]
xs

showURL :: Bool -> Maybe FilePath -> URL -> String
showURL :: Bool -> Maybe FilePath -> FilePath -> FilePath
showURL Bool
_ (Just FilePath
_) FilePath
x = FilePath
"haddock/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath -> FilePath
forall a. Eq a => [a] -> [a] -> [a]
dropPrefix FilePath
"file:///" FilePath
x
showURL Bool
True Maybe FilePath
_ (FilePath -> FilePath -> Maybe FilePath
forall a. Eq a => [a] -> [a] -> Maybe [a]
stripPrefix FilePath
"file:///" -> Just FilePath
x) = FilePath
"file/" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
x
showURL Bool
_ Maybe FilePath
_ FilePath
x = FilePath
x


-------------------------------------------------------------
-- DISPLAY AN ITEM (bold keywords etc)

highlightItem :: [Query] -> String -> Markup
highlightItem :: [Query] -> FilePath -> Markup
highlightItem [Query]
qs FilePath
x
    | Just (FilePath
pre,FilePath
x) <- FilePath -> FilePath -> Maybe (FilePath, FilePath)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix FilePath
"<s0>" FilePath
x, Just (FilePath
name,FilePath
post) <- FilePath -> FilePath -> Maybe (FilePath, FilePath)
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix FilePath
"</s0>" FilePath
x
        = FilePath -> Markup
H.preEscapedString FilePath
pre Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> FilePath -> Markup
highlight (FilePath -> FilePath
unescapeHTML FilePath
name) Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> FilePath -> Markup
H.preEscapedString FilePath
post
    | Bool
otherwise = FilePath -> Markup
H.string FilePath
x
    where
        highlight :: FilePath -> Markup
highlight = ([(Bool, Char)] -> Markup) -> [[(Bool, Char)]] -> Markup
forall b a. Monoid b => (a -> b) -> [a] -> b
mconcatMap (\xs :: [(Bool, Char)]
xs@((Bool
b,Char
_):[(Bool, Char)]
_) -> let s :: Markup
s = FilePath -> Markup
H.string (FilePath -> Markup) -> FilePath -> Markup
forall a b. (a -> b) -> a -> b
$ ((Bool, Char) -> Char) -> [(Bool, Char)] -> FilePath
forall a b. (a -> b) -> [a] -> [b]
map (Bool, Char) -> Char
forall a b. (a, b) -> b
snd [(Bool, Char)]
xs in if Bool
b then Markup -> Markup
H.b Markup
s else Markup
s) ([[(Bool, Char)]] -> Markup)
-> (FilePath -> [[(Bool, Char)]]) -> FilePath -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    ((Bool, Char) -> Bool) -> [(Bool, Char)] -> [[(Bool, Char)]]
forall b a. Eq b => (a -> b) -> [a] -> [[a]]
groupOn (Bool, Char) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, Char)] -> [[(Bool, Char)]])
-> (FilePath -> [(Bool, Char)]) -> FilePath -> [[(Bool, Char)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\FilePath
x -> [Bool] -> FilePath -> [(Bool, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip (FilePath -> [Bool]
f FilePath
x) FilePath
x)
            where
              f :: FilePath -> [Bool]
f (Char
x:FilePath
xs) | Int
m Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 = Int -> Bool -> [Bool]
forall a. Int -> a -> [a]
replicate Int
m Bool
True [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
drop (Int
m Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) (FilePath -> [Bool]
f FilePath
xs)
                  where m :: Int
m = [Int] -> Int
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum ([Int] -> Int) -> [Int] -> Int
forall a b. (a -> b) -> a -> b
$ Int
0 Int -> [Int] -> [Int]
forall a. a -> [a] -> [a]
: [FilePath -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length FilePath
y | QueryName FilePath
y <- [Query]
qs, FilePath -> FilePath
lower FilePath
y FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath -> FilePath
lower (Char
xChar -> FilePath -> FilePath
forall a. a -> [a] -> [a]
:FilePath
xs)]
              f (Char
x:FilePath
xs) = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: FilePath -> [Bool]
f FilePath
xs
              f [] = []

displayItem :: [Query] -> String -> Markup
displayItem :: [Query] -> FilePath -> Markup
displayItem = [Query] -> FilePath -> Markup
highlightItem


action_server_test_ :: IO ()
action_server_test_ :: IO ()
action_server_test_ = do
    FilePath -> IO () -> IO ()
testing FilePath
"Action.Server.displayItem" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
        let expand :: FilePath -> FilePath
expand = FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"{" FilePath
"<b>" (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"}" FilePath
"</b>" (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"<s0>" FilePath
"" (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"</s0>" FilePath
""
            contract :: FilePath -> FilePath
contract = FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"{" FilePath
"" (FilePath -> FilePath)
-> (FilePath -> FilePath) -> FilePath -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> FilePath -> FilePath
forall a. (Partial, Eq a) => [a] -> [a] -> [a] -> [a]
replace FilePath
"}" FilePath
""
        let FilePath
q === :: FilePath -> FilePath -> IO ()
=== FilePath
s | ByteString -> FilePath
LBS.unpack (Markup -> ByteString
renderMarkup (Markup -> ByteString) -> Markup -> ByteString
forall a b. (a -> b) -> a -> b
$ [Query] -> FilePath -> Markup
displayItem (FilePath -> [Query]
parseQuery FilePath
q) (FilePath -> FilePath
contract FilePath
s)) FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath -> FilePath
expand FilePath
s = Char -> IO ()
putChar Char
'.'
                    | Bool
otherwise = FilePath -> IO ()
forall a. Partial => FilePath -> IO a
errorIO (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath, FilePath, ByteString) -> FilePath
forall a. Show a => a -> FilePath
show (FilePath
q,FilePath
s,Markup -> ByteString
renderMarkup (Markup -> ByteString) -> Markup -> ByteString
forall a b. (a -> b) -> a -> b
$ [Query] -> FilePath -> Markup
displayItem (FilePath -> [Query]
parseQuery FilePath
q) (FilePath -> FilePath
contract FilePath
s))
        FilePath
"test" FilePath -> FilePath -> IO ()
=== FilePath
"<s0>my{Test}</s0> :: Int -&gt; test"
        FilePath
"new west" FilePath -> FilePath -> IO ()
=== FilePath
"<s0>{newest}_{new}</s0> :: Int"
        FilePath
"+*" FilePath -> FilePath -> IO ()
=== FilePath
"(<s0>{+*}&amp;</s0>) :: Int"
        FilePath
"+<" FilePath -> FilePath -> IO ()
=== FilePath
"(<s0>&gt;{+&lt;}</s0>) :: Int"
        FilePath
"foo" FilePath -> FilePath -> IO ()
=== FilePath
"<i>data</i> <s0>{Foo}d</s0>"
        FilePath
"foo" FilePath -> FilePath -> IO ()
=== FilePath
"<i>type</i> <s0>{Foo}d</s0>"
        FilePath
"foo" FilePath -> FilePath -> IO ()
=== FilePath
"<i>type family</i> <s0>{Foo}d</s0>"
        FilePath
"foo" FilePath -> FilePath -> IO ()
=== FilePath
"<i>module</i> Foo.Bar.<s0>F{Foo}</s0>"
        FilePath
"foo" FilePath -> FilePath -> IO ()
=== FilePath
"<i>module</i> <s0>{Foo}o</s0>"

action_server_test :: Bool -> FilePath -> IO ()
action_server_test :: Bool -> FilePath -> IO ()
action_server_test Bool
sample FilePath
database = do
    FilePath -> IO () -> IO ()
testing FilePath
"Action.Server.replyServer" (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath -> (StoreRead -> IO ()) -> IO ()
forall a. NFData a => FilePath -> (StoreRead -> IO a) -> IO a
withSearch FilePath
database ((StoreRead -> IO ()) -> IO ()) -> (StoreRead -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StoreRead
store -> do
        Log
log <- IO Log
logNone
        FilePath
dataDir <- IO FilePath
getDataDir
        let check :: (FilePath -> Bool) -> FilePath -> IO ()
check FilePath -> Bool
p FilePath
q = do
                OutputHTML (ByteString -> FilePath
lbstrUnpack -> FilePath
res) <- Log
-> Bool
-> Bool
-> Maybe FilePath
-> StoreRead
-> FilePath
-> FilePath
-> FilePath
-> FilePath
-> Input
-> IO Output
replyServer Log
log Bool
False Bool
False Maybe FilePath
forall a. Maybe a
Nothing StoreRead
store FilePath
"" FilePath
"" (FilePath
dataDir FilePath -> FilePath -> FilePath
</> FilePath
"html") FilePath
"" ([FilePath] -> [(FilePath, FilePath)] -> Input
Input [] [(FilePath
"hoogle",FilePath
q)])
                if FilePath -> Bool
p FilePath
res then Char -> IO ()
putChar Char
'.' else FilePath -> IO ()
forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Bad substring: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
res
        let FilePath
q === :: FilePath -> FilePath -> IO ()
=== FilePath
want = (FilePath -> Bool) -> FilePath -> IO ()
check (FilePath
want FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isInfixOf`) FilePath
q
        let FilePath
q /== :: FilePath -> FilePath -> IO ()
/== FilePath
want = (FilePath -> Bool) -> FilePath -> IO ()
check (Bool -> Bool
not (Bool -> Bool) -> (FilePath -> Bool) -> FilePath -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isInfixOf FilePath
want) FilePath
q
        FilePath
"<test" FilePath -> FilePath -> IO ()
/== FilePath
"<test"
        FilePath
"&test" FilePath -> FilePath -> IO ()
/== FilePath
"&test"
        if Bool
sample then
            FilePath
"Wife" FilePath -> FilePath -> IO ()
=== FilePath
"<b>type family</b>"
         else do
            FilePath
"<>" FilePath -> FilePath -> IO ()
=== FilePath
"<span class=name>(<b>&lt;&gt;</b>)</span>"
            FilePath
"filt" FilePath -> FilePath -> IO ()
=== FilePath
"<span class=name><b>filt</b>er</span>"
            FilePath
"True" FilePath -> FilePath -> IO ()
=== FilePath
"https://hackage.haskell.org/package/base/docs/Prelude.html#v:True"


-------------------------------------------------------------
-- ANALYSE THE LOG


displayLog :: [Summary] -> String
displayLog :: [Summary] -> FilePath
displayLog [Summary]
xs = FilePath
"[" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"," ((Summary -> FilePath) -> [Summary] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map Summary -> FilePath
f [Summary]
xs) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"]"
    where
        f :: Summary -> FilePath
f Summary{Seconds
Int
Day
Average Seconds
summaryErrors :: Int
summaryAverage :: Average Seconds
summarySlowest :: Seconds
summaryUses :: Int
summaryUsers :: Int
summaryDate :: Day
summaryErrors :: Summary -> Int
summaryAverage :: Summary -> Average Seconds
summarySlowest :: Summary -> Seconds
summaryUses :: Summary -> Int
summaryUsers :: Summary -> Int
summaryDate :: Summary -> Day
..} = FilePath
"{date:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show (Day -> FilePath
showGregorian Day
summaryDate) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
",users:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
summaryUsers FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
",uses:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
summaryUses FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
",slowest:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Seconds -> FilePath
forall a. Show a => a -> FilePath
show Seconds
summarySlowest FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
",average:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Seconds -> FilePath
forall a. Show a => a -> FilePath
show (Average Seconds -> Seconds
forall a. Fractional a => Average a -> a
fromAverage Average Seconds
summaryAverage) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
                        FilePath
",errors:" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
summaryErrors FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"}"