{-# LANGUAGE ViewPatterns, PatternGuards, TupleSections, OverloadedStrings, Rank2Types, DeriveDataTypeable #-}
module Input.Haddock(parseHoogle, fakePackage, input_haddock_test) where
import Language.Haskell.Exts as HSE
import Data.Char
import Data.List.Extra
import Data.Data
import Input.Item
import General.Util
import Control.DeepSeq
import Control.Monad.Trans.Class
import General.Conduit
import Control.Monad.Extra
import Control.Exception.Extra
import Data.Generics.Uniplate.Data
import General.Str
data Entry = EPackage PkgName
| EModule ModName
| EDecl (Decl ())
deriving (Data,Typeable,Show)
fakePackage :: PkgName -> String -> (Maybe Target, [Item])
fakePackage name desc = (Just $ Target (hackagePackageURL name) Nothing Nothing "package" (renderPackage name) desc, [IPackage name])
parseHoogle :: Monad m => (String -> m ()) -> URL -> LBStr -> ConduitM i (Maybe Target, [Item]) m ()
parseHoogle warning url body = sourceLStr body .| linesCR .| zipFromC 1 .| parserC warning .| hierarchyC url .| mapC (\x -> rnf x `seq` x)
parserC :: Monad m => (String -> m ()) -> ConduitM (Int, BStr) (Target, Entry) m ()
parserC warning = f [] ""
where
f com url = do
x <- await
whenJust x $ \(i,s) -> case () of
_ | Just s <- bstrStripPrefix "-- | " s -> f [s] url
| Just s <- bstrStripPrefix "--" s -> f (if null com then [] else bstrTrimStart s : com) url
| Just s <- bstrStripPrefix "@url " s -> f com (bstrUnpack s)
| bstrNull $ bstrTrimStart s -> f [] ""
| otherwise -> do
case parseLine $ fixLine $ bstrUnpack s of
Left y -> lift $ warning $ show i ++ ":" ++ y
Right [EDecl InfixDecl{}] -> return ()
Right xs -> forM_ xs $ \x ->
yield (Target url Nothing Nothing (typeItem x) (renderItem x) $ reformat $ reverse com, x)
f [] ""
typeItem (EPackage x) = "package"
typeItem (EModule x) = "module"
typeItem _ = ""
reformat :: [BStr] -> String
reformat = unlines . map bstrUnpack
hierarchyC :: Monad m => URL -> ConduitM (Target, Entry) (Maybe Target, [Item]) m ()
hierarchyC packageUrl = void $ mapAccumC f (Nothing, Nothing)
where
f (pkg, mod) (t, EPackage x) = ((Just (strUnpack x, url), Nothing), (Just t{targetURL=url}, [IPackage x]))
where url = targetURL t `orIfNull` packageUrl
f (pkg, mod) (t, EModule x) = ((pkg, Just (strUnpack x, url)), (Just t{targetPackage=pkg, targetURL=url}, [IModule x]))
where url = targetURL t `orIfNull` (if isGhc then ghcModuleURL x else hackageModuleURL x)
f (pkg, mod) (t, EDecl i@InstDecl{}) = ((pkg, mod), (Nothing, hseToItem_ i))
f (pkg, mod) (t, EDecl x) = ((pkg, mod), (Just t{targetPackage=pkg, targetModule=mod, targetURL=url}, hseToItem_ x))
where url = targetURL t `orIfNull` case x of
_ | [n] <- declNames x -> hackageDeclURL (isTypeSig x) n
| otherwise -> ""
isGhc = "~ghc" `isInfixOf` packageUrl || "/" `isSuffixOf` packageUrl
hseToItem_ x = hseToItem x `orIfNull` error ("hseToItem failed, " ++ pretty x)
infix 1 `orIfNull`
orIfNull x y = if null x then y else x
renderPackage x = "<b>package</b> <span class=name><s0>" ++ escapeHTML (strUnpack x) ++ "</s0></span>"
renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "<b>module</b> " ++ escapeHTML pre ++ "<span class=name><s0>" ++ escapeHTML post ++ "</s0></span>"
renderItem :: Entry -> String
renderItem = keyword . focus
where
keyword x | Just b <- stripPrefix "type family " x = "<b>type family</b> " ++ b
| (a,b) <- word1 x, a `elem` kws = "<b>" ++ a ++ "</b> " ++ b
| otherwise = x
where kws = words "class data type newtype"
name x = "<span class=name>" ++ x ++ "</span>" :: String
focus (EModule x) = renderModule x
focus (EPackage x) = renderPackage x
focus (EDecl x) | [now] <- declNames x, (pre,stripPrefix now -> Just post) <- breakOn now $ pretty x =
if "(" `isSuffixOf` pre && ")" `isPrefixOf` post then
init (escapeHTML pre) ++ name ("(" ++ highlight now ++ ")") ++ escapeHTML (tail post)
else
escapeHTML pre ++ name (highlight now) ++ escapeHTML post
focus (EDecl x) = pretty x
highlight :: String -> String
highlight x = "<s0>" ++ escapeHTML x ++ "</s0>"
parseLine :: String -> Either String [Entry]
parseLine x@('@':str) = case a of
"package" | [b] <- words b, b /= "" -> Right [EPackage $ strPack b]
"version" -> Right []
_ -> Left $ "unknown attribute: " ++ x
where (a,b) = word1 str
parseLine (stripPrefix "module " -> Just x) = Right [EModule $ strPack x]
parseLine x | Just x <- readItem x = case x of
TypeSig a bs c -> Right [EDecl (TypeSig a [b] c) | b <- bs]
x -> Right [EDecl x]
parseLine x = Left $ "failed to parse: " ++ x
fixLine :: String -> String
fixLine (stripPrefix "instance [incoherent] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlap ok] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [overlapping] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "instance [safe] " -> Just x) = fixLine $ "instance " ++ x
fixLine (stripPrefix "(#) " -> Just x) = "( # ) " ++ x
fixLine ('[':x:xs) | isAlpha x || x `elem` ("_(" :: String), (a,']':b) <- break (== ']') xs = x : a ++ b
fixLine ('[':':':xs) | (a,']':b) <- break (== ']') xs = "(:" ++ a ++ ")" ++ b
fixLine x | "class " `isPrefixOf` x = fst $ breakOn " where " x
fixLine x = x
readItem :: String -> Maybe (Decl ())
readItem x | ParseOk y <- myParseDecl x = Just $ unGADT y
readItem x
| Just x <- stripPrefix "newtype " x
, ParseOk (DataDecl an _ b c d e) <- fmap unGADT $ myParseDecl $ "data " ++ x
= Just $ DataDecl an (NewType ()) b c d e
readItem x
| ParseOk (GDataDecl _ _ _ _ _ [GadtDecl s name _ _ _ ty] _) <- myParseDecl $ "data Data where " ++ x
, let f (TyBang _ _ _ (TyParen _ x@TyApp{})) = x
f (TyBang _ _ _ x) = x
f x = x
= Just $ TypeSig s [name] $ applyFun1 $ map f $ unapplyFun ty
readItem ('(':xs)
| (com,')':rest) <- span (== ',') xs
, ParseOk (TypeSig s [Ident{}] ty) <- myParseDecl $ replicate (length com + 2) 'a' ++ rest
= Just $ TypeSig s [Ident s $ '(':com++")"] ty
readItem (stripPrefix "data (" -> Just xs)
| (com,')':rest) <- span (== ',') xs
, ParseOk (DataDecl a b c d e f) <- fmap unGADT $ myParseDecl $
"data " ++ replicate (length com + 2) 'A' ++ rest
= Just $ DataDecl a b c (transform (op $ '(':com++")") d) e f
where op s DHead{} = DHead () $ Ident () s
op s x = x
readItem _ = Nothing
myParseDecl = fmap (fmap $ const ()) . parseDeclWithMode parseMode
unGADT (GDataDecl a b c d _ [] e) = DataDecl a b c d [] e
unGADT x = x
prettyItem :: Entry -> String
prettyItem (EPackage x) = "package " ++ strUnpack x
prettyItem (EModule x) = "module " ++ strUnpack x
prettyItem (EDecl x) = pretty x
input_haddock_test :: IO ()
input_haddock_test = testing "Input.Haddock.parseLine" $ do
let a === b | fmap (map prettyItem) (parseLine a) == Right [b] = putChar '.'
| otherwise = errorIO $ show (a,b,parseLine a, fmap (map prettyItem) $ parseLine a)
let test a = a === a
test "type FilePath = [Char]"
test "data Maybe a"
test "Nothing :: Maybe a"
test "Just :: a -> Maybe a"
test "newtype Identity a"
test "foo :: Int# -> b"
test "(,,) :: a -> b -> c -> (a, b, c)"
test "data (,,) a b"
test "reverse :: [a] -> [a]"
test "reverse :: [:a:] -> [:a:]"
test "module Foo.Bar"
test "data Char"
"data Char :: *" === "data Char"
"newtype ModuleName :: *" === "newtype ModuleName"
"Progress :: !(Maybe String) -> {-# UNPACK #-} !Int -> !(Int -> Bool) -> Progress" ===
"Progress :: Maybe String -> Int -> (Int -> Bool) -> Progress"
test "( # ) :: Int"
test "pattern MyPattern :: ()"