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

actionReplay :: CmdLine -> IO ()
actionReplay :: CmdLine -> IO ()
actionReplay Replay{Int
[Char]
Language
database :: CmdLine -> [Char]
language :: CmdLine -> Language
logs :: CmdLine -> [Char]
scope :: CmdLine -> [Char]
logs :: [Char]
database :: [Char]
repeat_ :: Int
language :: Language
scope :: [Char]
repeat_ :: CmdLine -> Int
..} = 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
    [Char]
src <- [Char] -> IO [Char]
readFile [Char]
logs
    let qs :: [Input]
qs = [Maybe Input] -> [Input]
forall a. [Maybe a] -> [a]
catMaybes [[Char] -> Maybe Input
readInput [Char]
url | [Char]
_:[Char]
ip:[Char]
_:[Char]
url:[[Char]]
_ <- ([Char] -> [[Char]]) -> [[Char]] -> [[[Char]]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [[Char]]
words ([[Char]] -> [[[Char]]]) -> [[Char]] -> [[[Char]]]
forall a b. (a -> b) -> a -> b
$ [Char] -> [[Char]]
lines [Char]
src, [Char]
ip [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"-"]
    (Double
t,()
_) <- IO () -> IO (Double, ())
forall (m :: * -> *) a. MonadIO m => m a -> m (Double, a)
duration (IO () -> IO (Double, ())) -> IO () -> IO (Double, ())
forall a b. (a -> b) -> a -> b
$ [Char] -> (StoreRead -> IO ()) -> IO ()
forall a. NFData a => [Char] -> (StoreRead -> IO a) -> IO a
withSearch [Char]
database ((StoreRead -> IO ()) -> IO ()) -> (StoreRead -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \StoreRead
store -> do
        Log
log <- IO Log
logNone
        [Char]
dataDir <- IO [Char]
getDataDir
        let op :: Input -> IO Output
op = Log
-> Bool
-> Bool
-> Maybe [Char]
-> StoreRead
-> [Char]
-> [Char]
-> [Char]
-> [Char]
-> Input
-> IO Output
replyServer Log
log Bool
False Bool
False Maybe [Char]
forall a. Maybe a
Nothing StoreRead
store [Char]
"" [Char]
"" ([Char]
dataDir [Char] -> [Char] -> [Char]
</> [Char]
"html") [Char]
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
'.'
    [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"\nTook " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
showDuration Double
t [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" (" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Double -> [Char]
showDuration (Double
t Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Int -> Double
intToDouble (Int
repeat_ Int -> Int -> Int
forall a. Num a => a -> a -> a
* [Input] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Input]
qs)) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
")"

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

        let qScope :: [[Char]]
qScope = let xs :: [[Char]]
xs = [Char] -> [[Char]]
grab [Char]
"scope" in [[Char]
scope | [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
xs Bool -> Bool -> Bool
&& [Char]
scope [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
""] [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ [[Char]]
xs
        let qSearch :: [[Char]]
qSearch = ([Char] -> Bool) -> [[Char]]
grabBy ([Char] -> [[Char]] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [[Char]
"hoogle",[Char]
"q"])
        let qSource :: [[Char]]
qSource = [[Char]]
qSearch [[Char]] -> [[Char]] -> [[Char]]
forall a. [a] -> [a] -> [a]
++ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"set:stackage") [[Char]]
qScope
        let q :: [Query]
q = ([Char] -> [Query]) -> [[Char]] -> [Query]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap [Char] -> [Query]
parseQuery [[Char]]
qSource
        let ([Query]
q2, [Target]
results) = StoreRead -> [Query] -> ([Query], [Target])
search StoreRead
store [Query]
q
        let body :: Markup
body = Bool
-> Bool
-> Maybe [Char]
-> [([Char], [Char])]
-> [Query]
-> [[Target]]
-> Markup
showResults Bool
local Bool
links Maybe [Char]
haddock ((([Char], [Char]) -> Bool)
-> [([Char], [Char])] -> [([Char], [Char])]
forall a. (a -> Bool) -> [a] -> [a]
filter (([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"mode") ([Char] -> Bool)
-> (([Char], [Char]) -> [Char]) -> ([Char], [Char]) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char], [Char]) -> [Char]
forall a b. (a, b) -> a
fst) [([Char], [Char])]
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="",targetPackage=Nothing, targetModule=Nothing}) [Target]
results
        case [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"mode" [([Char], [Char])]
inputArgs of
            Maybe [Char]
Nothing | [[Char]]
qSource [[Char]] -> [[Char]] -> Bool
forall a. Eq a => a -> a -> Bool
/= [] -> (LBStr -> Output) -> IO LBStr -> IO Output
forall a b. (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap LBStr -> Output
OutputHTML (IO LBStr -> IO Output) -> IO LBStr -> IO Output
forall a b. (a -> b) -> a -> b
$ Template -> [([Char], Template)] -> IO LBStr
templateRender Template
templateIndex
                        [([Char]
"tags", Markup -> Template
html (Markup -> Template) -> Markup -> Template
forall a b. (a -> b) -> a -> b
$ [[Char]] -> Markup
forall {t :: * -> *}. Foldable t => t [Char] -> Markup
tagOptions [[Char]]
qScope)
                        ,([Char]
"body", Markup -> Template
html Markup
body)
                        ,([Char]
"title", [Char] -> Template
text ([Char] -> Template) -> [Char] -> Template
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
qSource [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" - Hoogle")
                        ,([Char]
"search", [Char] -> Template
text ([Char] -> Template) -> [Char] -> Template
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
unwords [[Char]]
qSearch)
                        ,([Char]
"robots", [Char] -> Template
text ([Char] -> Template) -> [Char] -> 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 [Char]
"none" else [Char]
"index")]
                    | Bool
otherwise -> LBStr -> Output
OutputHTML (LBStr -> Output) -> IO LBStr -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [([Char], Template)] -> IO LBStr
templateRender Template
templateHome []
            Just [Char]
"body" -> LBStr -> Output
OutputHTML (LBStr -> Output) -> IO LBStr -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> if [[Char]] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
qSource then Template -> [([Char], Template)] -> IO LBStr
templateRender Template
templateEmpty [] else Template -> [([Char], Template)] -> IO LBStr
templateRender (Markup -> Template
html Markup
body) []
            Just [Char]
"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
$ [Char] -> Int -> Int
grabInt [Char]
"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
$ [Char] -> Int -> Int
grabInt [Char]
"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 [Char] -> [([Char], [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char]
"format" [([Char], [Char])]
inputArgs of
                Just [Char]
"text" -> Output -> IO Output
forall a. a -> IO a
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 [Char]
f -> Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ LBStr -> Output
OutputFail (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack ([Char] -> LBStr) -> [Char] -> LBStr
forall a b. (a -> b) -> a -> b
$ [Char]
"Format mode " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not (currently) supported"
                Maybe [Char]
Nothing -> Output -> IO Output
forall a. a -> IO a
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 [Char]
m -> Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ LBStr -> Output
OutputFail (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack ([Char] -> LBStr) -> [Char] -> LBStr
forall a b. (a -> b) -> a -> b
$ [Char]
"Mode " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
m [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" not (currently) supported"
    [[Char]
"plugin",[Char]
"jquery.js"] -> [Char] -> Output
OutputFile ([Char] -> Output) -> IO [Char] -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO [Char]
JQuery.file
    [[Char]
"plugin",[Char]
"jquery.flot.js"] -> [Char] -> Output
OutputFile ([Char] -> Output) -> IO [Char] -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flot -> IO [Char]
Flot.file Flot
Flot.Flot
    [[Char]
"plugin",[Char]
"jquery.flot.time.js"] -> [Char] -> Output
OutputFile ([Char] -> Output) -> IO [Char] -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Flot -> IO [Char]
Flot.file Flot
Flot.FlotTime

    [[Char]
"canary"] -> do
        UTCTime
now <- IO UTCTime
getCurrentTime
        [Summary]
summ <- Log -> IO [Summary]
logSummary Log
log
        let errs :: Int
errs = [Int] -> Int
forall a. Num a => [a] -> a
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum [Int
summaryErrors | Summary{Double
Int
Day
Average Double
summaryErrors :: Int
summaryDate :: Day
summaryUsers :: Int
summaryUses :: Int
summarySlowest :: Double
summaryAverage :: Average Double
summaryDate :: Summary -> Day
summaryUsers :: Summary -> Int
summaryUses :: Summary -> Int
summarySlowest :: Summary -> Double
summaryAverage :: Summary -> Average Double
summaryErrors :: Summary -> 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 :: Double
alive = Rational -> Double
forall a. Fractional a => Rational -> a
fromRational (Rational -> Double) -> Rational -> Double
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 a. a -> IO a
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
&& Double
alive Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1.5 then LBStr -> Output
OutputText else LBStr -> Output
OutputFail) (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack ([Char] -> LBStr) -> [Char] -> LBStr
forall a b. (a -> b) -> a -> b
$
            [Char]
"Errors " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Int
errs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then [Char]
"good" else [Char]
"bad") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
errs [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" in the last 24 hours.\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
            [Char]
"Updates " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if Double
alive Double -> Double -> Bool
forall a. Ord a => a -> a -> Bool
< Double
1.5 then [Char]
"good" else [Char]
"bad") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
": Last updated " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> Double -> [Char]
forall a. RealFloat a => Int -> a -> [Char]
showDP Int
2 Double
alive [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" days ago.\n"

    [[Char]
"log"] -> do
        LBStr -> Output
OutputHTML (LBStr -> Output) -> IO LBStr -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [([Char], Template)] -> IO LBStr
templateRender Template
templateLog []
    [[Char]
"log.js"] -> do
        [Char]
log <- [Summary] -> [Char]
displayLog ([Summary] -> [Char]) -> IO [Summary] -> IO [Char]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Log -> IO [Summary]
logSummary Log
log
        LBStr -> Output
OutputJavascript (LBStr -> Output) -> IO LBStr -> IO Output
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Template -> [([Char], Template)] -> IO LBStr
templateRender Template
templateLogJs [([Char]
"data",Markup -> Template
html (Markup -> Template) -> Markup -> Template
forall a b. (a -> b) -> a -> b
$ [Char] -> Markup
H.preEscapedString [Char]
log)]
    [[Char]
"stats"] -> do
        Maybe [Char]
stats <- IO (Maybe [Char])
getStatsDebug
        Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ case Maybe [Char]
stats of
            Maybe [Char]
Nothing -> LBStr -> Output
OutputFail (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack [Char]
"GHC Statistics is not enabled, restart with +RTS -T"
            Just [Char]
x -> LBStr -> Output
OutputText (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack [Char]
x
    [Char]
"haddock":[[Char]]
xs | Just [Char]
x <- Maybe [Char]
haddock -> do
        let file :: [Char]
file = [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
x[Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
:[[Char]]
xs
        Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ [Char] -> Output
OutputFile ([Char] -> Output) -> [Char] -> Output
forall a b. (a -> b) -> a -> b
$ [Char]
file [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
hasTrailingPathSeparator [Char]
file then [Char]
"index.html" else [Char]
"")
    [Char]
"file":[[Char]]
xs | Bool
local -> do
        let x :: [Char]
x = [Char
'/' | Bool -> Bool
not Bool
isWindows] [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"/" (([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
dropWhile [Char] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
xs)
        let file :: [Char]
file = [Char]
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (if [Char] -> Bool
hasTrailingPathSeparator [Char]
x then [Char]
"index.html" else [Char]
"")
        if [Char] -> [Char]
takeExtension [Char]
file [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
".html" then
            Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ [Char] -> Output
OutputFile [Char]
file
         else do
            [Char]
src <- [Char] -> IO [Char]
readFile [Char]
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 a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ LBStr -> Output
OutputHTML (LBStr -> Output) -> LBStr -> Output
forall a b. (a -> b) -> a -> b
$ [Char] -> LBStr
lbstrPack ([Char] -> LBStr) -> [Char] -> LBStr
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char] -> [Char] -> [Char]
forall a. Eq a => [a] -> [a] -> [a] -> [a]
replace [Char]
"file://" [Char]
"/file/" [Char]
src
    [[Char]]
xs ->
        Output -> IO Output
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Output -> IO Output) -> Output -> IO Output
forall a b. (a -> b) -> a -> b
$ [Char] -> Output
OutputFile ([Char] -> Output) -> [Char] -> Output
forall a b. (a -> b) -> a -> b
$ [[Char]] -> [Char]
joinPath ([[Char]] -> [Char]) -> [[Char]] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
htmlDir [Char] -> [[Char]] -> [[Char]]
forall a. a -> [a] -> [a]
: [[Char]]
xs
    where
        html :: Markup -> Template
html = Markup -> Template
templateMarkup
        text :: [Char] -> Template
text = Markup -> Template
templateMarkup (Markup -> Template) -> ([Char] -> Markup) -> [Char] -> Template
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Markup
H.string

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


dedupeTake :: Ord k => Int -> (v -> k) -> [v] -> [[v]]
dedupeTake :: forall k v. Ord k => 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 a. [a] -> 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 [Char]
-> [([Char], [Char])]
-> [Query]
-> [[Target]]
-> Markup
showResults Bool
local Bool
links Maybe [Char]
haddock [([Char], [Char])]
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
    Bool -> Markup -> Markup
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ([[Target]] -> Bool
forall a. [a] -> 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{[Char]
Maybe ([Char], [Char])
targetURL :: Target -> [Char]
targetPackage :: Target -> Maybe ([Char], [Char])
targetModule :: Target -> Maybe ([Char], [Char])
targetURL :: [Char]
targetPackage :: Maybe ([Char], [Char])
targetModule :: Maybe ([Char], [Char])
targetType :: [Char]
targetItem :: [Char]
targetDocs :: [Char]
targetType :: Target -> [Char]
targetItem :: Target -> [Char]
targetDocs :: Target -> [Char]
..}:[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 ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ Bool -> Maybe [Char] -> [Char] -> [Char]
showURL Bool
local Maybe [Char]
haddock [Char]
targetURL) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
                    [Query] -> [Char] -> Markup
displayItem [Query]
query [Char]
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 [Char] -> ([Char] -> Markup) -> Markup
forall (m :: * -> *) a.
Applicative m =>
Maybe a -> (a -> m ()) -> m ()
whenJust ([Target] -> Maybe [Char]
useLink [Target]
is) (([Char] -> Markup) -> Markup) -> ([Char] -> Markup) -> Markup
forall a b. (a -> b) -> a -> b
$ \[Char]
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 ([Char] -> AttributeValue
H.stringValue [Char]
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 [Char] -> [Target] -> Markup
showFroms Bool
local Maybe [Char]
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
$ [Char] -> Markup
H.preEscapedString [Char]
targetDocs
    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
$ [Char] -> [Char] -> Markup
f [Char]
cat [Char]
val | ([Char]
cat,[Char]
val) <- [Target] -> [([Char], [Char])]
itemCategories ([Target] -> [([Char], [Char])]) -> [Target] -> [([Char], [Char])]
forall a b. (a -> b) -> a -> b
$ [[Target]] -> [Target]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Target]]
results, Bool -> [Char] -> [Char] -> Query
QueryScope Bool
True [Char]
cat [Char]
val Query -> [Query] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Query]
query]

    where
        useLink :: [Target] -> Maybe String
        useLink :: [Target] -> Maybe [Char]
useLink [Target
t] | Maybe ([Char], [Char]) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe ([Char], [Char]) -> Bool) -> Maybe ([Char], [Char]) -> Bool
forall a b. (a -> b) -> a -> b
$ Target -> Maybe ([Char], [Char])
targetPackage Target
t =
            [Char] -> Maybe [Char]
forall a. a -> Maybe a
Just ([Char] -> Maybe [Char]) -> [Char] -> Maybe [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"https://packdeps.haskellers.com/reverse/" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char] -> [Char]
extractName (Target -> [Char]
targetItem Target
t)
        useLink [Target]
_ = Maybe [Char]
forall a. Maybe a
Nothing

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

        f :: [Char] -> [Char] -> Markup
f [Char]
cat [Char]
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 ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
add ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
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 ([Char] -> AttributeValue
H.stringValue ([Char] -> AttributeValue) -> [Char] -> AttributeValue
forall a b. (a -> b) -> a -> b
$ [Char] -> [Char]
add ([Char] -> [Char]) -> [Char] -> [Char]
forall a b. (a -> b) -> a -> b
$        [Char]
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
val) (Markup -> Markup) -> Markup -> Markup
forall a b. (a -> b) -> a -> b
$
                [Char] -> Markup
H.string ([Char] -> Markup) -> [Char] -> Markup
forall a b. (a -> b) -> a -> b
$ (if [Char]
cat [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
"package" then [Char]
"" else [Char]
cat [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
":") [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
val


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


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

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

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


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

highlightItem :: [Query] -> String -> Markup
highlightItem :: [Query] -> [Char] -> Markup
highlightItem [Query]
qs [Char]
x
    | Just ([Char]
pre,[Char]
x) <- [Char] -> [Char] -> Maybe ([Char], [Char])
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix [Char]
"<s0>" [Char]
x, Just ([Char]
name,[Char]
post) <- [Char] -> [Char] -> Maybe ([Char], [Char])
forall a. Eq a => [a] -> [a] -> Maybe ([a], [a])
stripInfix [Char]
"</s0>" [Char]
x
        = [Char] -> Markup
H.preEscapedString [Char]
pre Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> [Char] -> Markup
highlight ([Char] -> [Char]
unescapeHTML [Char]
name) Markup -> Markup -> Markup
forall a. Semigroup a => a -> a -> a
<> [Char] -> Markup
H.preEscapedString [Char]
post
    | Bool
otherwise = [Char] -> Markup
H.string [Char]
x
    where
        highlight :: [Char] -> 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 = [Char] -> Markup
H.string ([Char] -> Markup) -> [Char] -> Markup
forall a b. (a -> b) -> a -> b
$ ((Bool, Char) -> Char) -> [(Bool, Char)] -> [Char]
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)
-> ([Char] -> [[(Bool, Char)]]) -> [Char] -> Markup
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                    ((Bool, Char) -> Bool) -> [(Bool, Char)] -> [[(Bool, Char)]]
forall k a. Eq k => (a -> k) -> [a] -> [[a]]
groupOn (Bool, Char) -> Bool
forall a b. (a, b) -> a
fst ([(Bool, Char)] -> [[(Bool, Char)]])
-> ([Char] -> [(Bool, Char)]) -> [Char] -> [[(Bool, Char)]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\[Char]
x -> [Bool] -> [Char] -> [(Bool, Char)]
forall a b. [a] -> [b] -> [(a, b)]
zip ([Char] -> [Bool]
f [Char]
x) [Char]
x)
            where
              f :: [Char] -> [Bool]
f (Char
x:[Char]
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) ([Char] -> [Bool]
f [Char]
xs)
                  where m :: Int
m = [Int] -> Int
forall a. Ord a => [a] -> a
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]
: [[Char] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Char]
y | QueryName [Char]
y <- [Query]
qs, [Char] -> [Char]
lower [Char]
y [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` [Char] -> [Char]
lower (Char
xChar -> [Char] -> [Char]
forall a. a -> [a] -> [a]
:[Char]
xs)]
              f (Char
x:[Char]
xs) = Bool
False Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Char] -> [Bool]
f [Char]
xs
              f [] = []

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


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

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


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


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