{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
module IHaskell.Eval.Hoogle (
search,
document,
render,
OutputFormat(..),
HoogleResult(..),
HoogleResponse(..),
parseResponse,
) where
import qualified Data.ByteString.Char8 as CBS
import qualified Data.ByteString.Lazy as LBS
import IHaskellPrelude
import Data.Aeson
import Data.Char (isAlphaNum, isAscii)
import qualified Data.List as List
import qualified Data.Text as T
import Data.Vector (toList)
import Network.HTTP.Client
import Network.HTTP.Client.TLS
import StringUtils (replace, split, splitFirst, strip)
data OutputFormat = Plain
| HTML
data HoogleResponse = HoogleResponse { HoogleResponse -> String
location :: String, HoogleResponse -> String
self :: String, HoogleResponse -> String
docs :: String }
deriving (HoogleResponse -> HoogleResponse -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HoogleResponse -> HoogleResponse -> Bool
$c/= :: HoogleResponse -> HoogleResponse -> Bool
== :: HoogleResponse -> HoogleResponse -> Bool
$c== :: HoogleResponse -> HoogleResponse -> Bool
Eq, Int -> HoogleResponse -> String -> String
[HoogleResponse] -> String -> String
HoogleResponse -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HoogleResponse] -> String -> String
$cshowList :: [HoogleResponse] -> String -> String
show :: HoogleResponse -> String
$cshow :: HoogleResponse -> String
showsPrec :: Int -> HoogleResponse -> String -> String
$cshowsPrec :: Int -> HoogleResponse -> String -> String
Show)
data HoogleResult = SearchResult HoogleResponse
| DocResult HoogleResponse
| NoResult String
deriving Int -> HoogleResult -> String -> String
[HoogleResult] -> String -> String
HoogleResult -> String
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [HoogleResult] -> String -> String
$cshowList :: [HoogleResult] -> String -> String
show :: HoogleResult -> String
$cshow :: HoogleResult -> String
showsPrec :: Int -> HoogleResult -> String -> String
$cshowsPrec :: Int -> HoogleResult -> String -> String
Show
data HoogleResponseList = HoogleResponseList [HoogleResponse]
instance FromJSON HoogleResponseList where
parseJSON :: Value -> Parser HoogleResponseList
parseJSON (Array Array
arr) =
[HoogleResponse] -> HoogleResponseList
HoogleResponseList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. FromJSON a => Value -> Parser a
parseJSON (forall a. Vector a -> [a]
toList Array
arr)
parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected array."
instance FromJSON HoogleResponse where
parseJSON :: Value -> Parser HoogleResponse
parseJSON (Object Object
obj) =
String -> String -> String -> HoogleResponse
HoogleResponse
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"url"
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (String -> String
removeMarkup forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"item")
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj forall a. FromJSON a => Object -> Key -> Parser a
.: Key
"docs"
parseJSON Value
_ = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Expected object with fields: url, item, docs"
query :: String -> IO (Either String String)
query :: String -> IO (Either String String)
query String
str = do
Request
request <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseUrlThrow forall a b. (a -> b) -> a -> b
$ String -> String
queryUrl forall a b. (a -> b) -> a -> b
$ String -> String
urlEncode String
str
Manager
mgr <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
catch
(forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> String
CBS.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
LBS.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> body
responseBody forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
mgr)
(\SomeException
e -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show (SomeException
e :: SomeException))
where
queryUrl :: String -> String
queryUrl :: String -> String
queryUrl = forall r. PrintfType r => String -> r
printf String
"http://hoogle.haskell.org/?hoogle=%s&mode=json"
urlEncode :: String -> String
urlEncode :: String -> String
urlEncode [] = []
urlEncode (Char
ch:String
t)
| (Char -> Bool
isAscii Char
ch Bool -> Bool -> Bool
&& Char -> Bool
isAlphaNum Char
ch) Bool -> Bool -> Bool
|| Char
ch forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"-_.~" :: String) = Char
ch forall a. a -> [a] -> [a]
: String -> String
urlEncode String
t
| Bool -> Bool
not (Char -> Bool
isAscii Char
ch) = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Int -> String -> String
escape (String -> String
urlEncode String
t) ([Int] -> Int -> [Int]
eightBs [] (forall a. Enum a => a -> Int
fromEnum Char
ch))
| Bool
otherwise = Int -> String -> String
escape (forall a. Enum a => a -> Int
fromEnum Char
ch) (String -> String
urlEncode String
t)
where
escape :: Int -> String -> String
escape :: Int -> String -> String
escape Int
b String
rs = Char
'%' forall a. a -> [a] -> [a]
: Int -> String -> String
showH (Int
b forall a. Integral a => a -> a -> a
`div` Int
16) (Int -> String -> String
showH (Int
b forall a. Integral a => a -> a -> a
`mod` Int
16) String
rs)
showH :: Int -> String -> String
showH :: Int -> String -> String
showH Int
x String
xs
| Int
x forall a. Ord a => a -> a -> Bool
<= Int
9 = forall a. Enum a => Int -> a
toEnum (Int
o_0 forall a. Num a => a -> a -> a
+ Int
x) forall a. a -> [a] -> [a]
: String
xs
| Bool
otherwise = forall a. Enum a => Int -> a
toEnum (Int
o_A forall a. Num a => a -> a -> a
+ (Int
x forall a. Num a => a -> a -> a
- Int
10)) forall a. a -> [a] -> [a]
: String
xs
where
o_0 :: Int
o_0 = forall a. Enum a => a -> Int
fromEnum Char
'0'
o_A :: Int
o_A = forall a. Enum a => a -> Int
fromEnum Char
'A'
eightBs :: [Int] -> Int -> [Int]
eightBs :: [Int] -> Int -> [Int]
eightBs [Int]
acc Int
x
| Int
x forall a. Ord a => a -> a -> Bool
<= Int
255 = Int
x forall a. a -> [a] -> [a]
: [Int]
acc
| Bool
otherwise = [Int] -> Int -> [Int]
eightBs ((Int
x forall a. Integral a => a -> a -> a
`mod` Int
256) forall a. a -> [a] -> [a]
: [Int]
acc) (Int
x forall a. Integral a => a -> a -> a
`div` Int
256)
search :: String -> IO [HoogleResult]
search :: String -> IO [HoogleResult]
search String
string = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ((forall a. a -> [a] -> [a]
:[]) forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HoogleResult
NoResult) String -> [HoogleResult]
parseResponse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO (Either String String)
query String
string
parseResponse :: String -> [HoogleResult]
parseResponse :: String -> [HoogleResult]
parseResponse String
jsn =
case forall a. FromJSON a => ByteString -> Either String a
eitherDecode forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict forall a b. (a -> b) -> a -> b
$ String -> ByteString
CBS.pack String
jsn of
Left String
err -> [String -> HoogleResult
NoResult String
err]
Right HoogleResponseList
results ->
case forall a b. (a -> b) -> [a] -> [b]
map HoogleResponse -> HoogleResult
SearchResult forall a b. (a -> b) -> a -> b
$ (\(HoogleResponseList [HoogleResponse]
l) -> [HoogleResponse]
l) HoogleResponseList
results of
[] -> [String -> HoogleResult
NoResult String
"no matching identifiers found."]
[HoogleResult]
res -> [HoogleResult]
res
document :: String -> IO [HoogleResult]
document :: String -> IO [HoogleResult]
document String
string = do
[HoogleResult]
matchingResults <- forall a. (a -> Bool) -> [a] -> [a]
filter HoogleResult -> Bool
matches forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO [HoogleResult]
search String
string
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
case forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe HoogleResult -> Maybe HoogleResult
toDocResult [HoogleResult]
matchingResults of
[] -> [String -> HoogleResult
NoResult String
"no matching identifiers found."]
[HoogleResult]
res -> [HoogleResult]
res
where
matches :: HoogleResult -> Bool
matches (SearchResult HoogleResponse
resp) =
(String
"<s0>" forall a. [a] -> [a] -> [a]
++ String -> String
strip String
string forall a. [a] -> [a] -> [a]
++ String
"</s0>") forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String -> String -> [String]
split String
" " forall a b. (a -> b) -> a -> b
$ HoogleResponse -> String
self HoogleResponse
resp)
matches HoogleResult
_ = Bool
False
toDocResult :: HoogleResult -> Maybe HoogleResult
toDocResult (SearchResult HoogleResponse
resp) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ HoogleResponse -> HoogleResult
DocResult HoogleResponse
resp
toDocResult (DocResult HoogleResponse
_) = forall a. Maybe a
Nothing
toDocResult (NoResult String
_) = forall a. Maybe a
Nothing
render :: OutputFormat -> HoogleResult -> String
render :: OutputFormat -> HoogleResult -> String
render OutputFormat
Plain = HoogleResult -> String
renderPlain
render OutputFormat
HTML = HoogleResult -> String
renderHtml
renderPlain :: HoogleResult -> String
renderPlain :: HoogleResult -> String
renderPlain (NoResult String
res) =
String
"No response available: " forall a. [a] -> [a] -> [a]
++ String
res
renderPlain (SearchResult HoogleResponse
resp) =
forall r. PrintfType r => String -> r
printf String
"%s\nURL: %s\n%s" (HoogleResponse -> String
self HoogleResponse
resp) (HoogleResponse -> String
location HoogleResponse
resp) (HoogleResponse -> String
docs HoogleResponse
resp)
renderPlain (DocResult HoogleResponse
resp) =
forall r. PrintfType r => String -> r
printf String
"%s\nURL: %s\n%s" (HoogleResponse -> String
self HoogleResponse
resp) (HoogleResponse -> String
location HoogleResponse
resp) (HoogleResponse -> String
docs HoogleResponse
resp)
renderHtml :: HoogleResult -> String
renderHtml :: HoogleResult -> String
renderHtml (NoResult String
resp) =
forall r. PrintfType r => String -> r
printf String
"<span class='err-msg'>No result: %s</span>" String
resp
renderHtml (DocResult HoogleResponse
resp) =
String -> String -> String
renderSelf (HoogleResponse -> String
self HoogleResponse
resp) (HoogleResponse -> String
location HoogleResponse
resp)
forall a. [a] -> [a] -> [a]
++
String -> String
renderDocs (HoogleResponse -> String
docs HoogleResponse
resp)
renderHtml (SearchResult HoogleResponse
resp) =
String -> String -> String
renderSelf (HoogleResponse -> String
self HoogleResponse
resp) (HoogleResponse -> String
location HoogleResponse
resp)
forall a. [a] -> [a] -> [a]
++
String -> String
renderDocs (HoogleResponse -> String
docs HoogleResponse
resp)
renderSelf :: String -> String -> String
renderSelf :: String -> String -> String
renderSelf String
string String
loc
| String
"package" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
String
pkg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String -> String -> String
span String
"hoogle-package" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractPackage String
string)
| String
"module" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
let package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
in String
mdl forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
String -> String -> String
span String
"hoogle-module" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractModule String
string) forall a. [a] -> [a] -> [a]
++
Maybe String -> String
packageSub Maybe String
package
| String
"class" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
let package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
in String
cls forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
String -> String -> String
span String
"hoogle-class" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractClass String
string) forall a. [a] -> [a] -> [a]
++
Maybe String -> String
packageSub Maybe String
package
| String
"data" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
let package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
in String
dat forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
String -> String -> String
span String
"hoogle-class" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractData String
string) forall a. [a] -> [a] -> [a]
++
Maybe String -> String
packageSub Maybe String
package
| String
"newtype" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
let package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
in String
nwt forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
String -> String -> String
span String
"hoogle-class" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractNewtype String
string) forall a. [a] -> [a] -> [a]
++
Maybe String -> String
packageSub Maybe String
package
| String
"type" forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` String
string =
let package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
in String
nwt forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++
String -> String -> String
span String
"hoogle-class" (String -> String -> String
link String
loc forall a b. (a -> b) -> a -> b
$ String -> String
extractType String
string) forall a. [a] -> [a] -> [a]
++
Maybe String -> String
packageSub Maybe String
package
| Bool
otherwise =
let [String
name, String
args] = String -> String -> [String]
splitFirst String
"::" String
string
package :: Maybe String
package = String -> Maybe String
extractPackageName String
loc
modname :: Maybe String
modname = String -> Maybe String
extractModuleName String
loc
in String -> String -> String
span String
"hoogle-name"
(String -> String
unicodeReplace forall a b. (a -> b) -> a -> b
$
String -> String -> String
link String
loc (String -> String
strip String
name) forall a. [a] -> [a] -> [a]
++
String
" :: " forall a. [a] -> [a] -> [a]
++
String -> String
strip String
args)
forall a. [a] -> [a] -> [a]
++ Maybe String -> Maybe String -> String
packageAndModuleSub Maybe String
package Maybe String
modname
where
extractPackage :: String -> String
extractPackage = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"package" String
""
extractModule :: String -> String
extractModule = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"module" String
""
extractClass :: String -> String
extractClass = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"class" String
""
extractData :: String -> String
extractData = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"data" String
""
extractNewtype :: String -> String
extractNewtype = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"newtype" String
""
extractType :: String -> String
extractType = String -> String
strip forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String -> String -> String
replace String
"newtype" String
""
pkg :: String
pkg = String -> String -> String
span String
"hoogle-head" String
"package"
mdl :: String
mdl = String -> String -> String
span String
"hoogle-head" String
"module"
cls :: String
cls = String -> String -> String
span String
"hoogle-head" String
"class"
dat :: String
dat = String -> String -> String
span String
"hoogle-head" String
"data"
nwt :: String
nwt = String -> String -> String
span String
"hoogle-head" String
"newtype"
unicodeReplace :: String -> String
unicodeReplace :: String -> String
unicodeReplace =
String -> String -> String -> String
replace String
"forall" String
"∀" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> String -> String -> String
replace String
"=>" String
"⇒" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> String -> String -> String
replace String
"->" String
"→" forall b c a. (b -> c) -> (a -> b) -> a -> c
.
String -> String -> String -> String
replace String
"::" String
"∷"
packageSub :: Maybe String -> String
packageSub Maybe String
Nothing = String
""
packageSub (Just String
package) =
String -> String -> String
span String
"hoogle-sub" forall a b. (a -> b) -> a -> b
$
String
"(" forall a. [a] -> [a] -> [a]
++ String
pkg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String -> String -> String
span String
"hoogle-package" String
package forall a. [a] -> [a] -> [a]
++ String
")"
packageAndModuleSub :: Maybe String -> Maybe String -> String
packageAndModuleSub Maybe String
Nothing Maybe String
_ = String
""
packageAndModuleSub (Just String
package) Maybe String
Nothing = Maybe String -> String
packageSub (forall a. a -> Maybe a
Just String
package)
packageAndModuleSub (Just String
package) (Just String
modname) =
String -> String -> String
span String
"hoogle-sub" forall a b. (a -> b) -> a -> b
$
String
"(" forall a. [a] -> [a] -> [a]
++ String
pkg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String -> String -> String
span String
"hoogle-package" String
package forall a. [a] -> [a] -> [a]
++
String
", " forall a. [a] -> [a] -> [a]
++ String
mdl forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ String -> String -> String
span String
"hoogle-module" String
modname forall a. [a] -> [a] -> [a]
++ String
")"
renderDocs :: String -> String
renderDocs :: String -> String
renderDocs String
doc = String -> String -> String
div' String
"hoogle-doc" String
doc
extractPackageName :: String -> Maybe String
String
lnk = do
let pieces :: [String]
pieces = String -> String -> [String]
split String
"/" String
lnk
Int
archiveLoc <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex String
"archive" [String]
pieces
Int
latestLoc <- forall a. Eq a => a -> [a] -> Maybe Int
List.elemIndex String
"latest" [String]
pieces
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
latestLoc forall a. Num a => a -> a -> a
- Int
archiveLoc forall a. Eq a => a -> a -> Bool
== Int
2
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [String]
pieces forall a. [a] -> Int -> a
List.!! (Int
latestLoc forall a. Num a => a -> a -> a
- Int
1)
extractModuleName :: String -> Maybe String
String
lnk =
String -> String -> String -> String
replace String
"-" String
"." forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall a. Eq a => a -> a -> Bool
/= Char
'.') forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. [a] -> Maybe a
lastMay (String -> String -> [String]
split String
"/" String
lnk)
div' :: String -> String -> String
div' :: String -> String -> String
div' = forall r. PrintfType r => String -> r
printf String
"<div class='%s'>%s</div>"
span :: String -> String -> String
span :: String -> String -> String
span = forall r. PrintfType r => String -> r
printf String
"<span class='%s'>%s</span>"
link :: String -> String -> String
link :: String -> String -> String
link = forall r. PrintfType r => String -> r
printf String
"<a target='_blank' href='%s'>%s</a>"
removeMarkup :: String -> String
removeMarkup :: String -> String
removeMarkup String
s = Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
List.foldl (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> a -> b
($)) (String -> Text
T.pack String
s) [Text -> Text]
replaceAll
where replacements :: [ (T.Text, T.Text) ]
replacements :: [(Text, Text)]
replacements = [ ( Text
"<span class=name>", Text
"" )
, ( Text
"</span>", Text
"" )
, ( Text
"<0>", Text
"" )
, ( Text
"</0>", Text
"" )
, ( Text
">", Text
">" )
, ( Text
"<", Text
"<" )
, ( Text
"<b>", Text
"")
, ( Text
"</b>", Text
"")
]
replaceAll :: [Text -> Text]
replaceAll = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Text -> Text -> Text -> Text
T.replace forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(Text, Text)]
replacements