{-# 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
-- | An entry in the Hoogle DB
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])
-- | Given a file name (for errors), feed in lines to the conduit and emit either errors or items
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
-- only check Nothing as some items (e.g. "instance () :> Foo a")
-- don't roundtrip but do come out equivalent
Right [EDecl InfixDecl{}] -> return () -- can ignore infix constructors
Right xs -> forM_ xs $ \x ->
yield (Target url Nothing Nothing (typeItem x) (renderItem x) $ reformat $ reverse com, x) -- descendBi stringShare x)
f [] ""
typeItem (EPackage x) = "package"
typeItem (EModule x) = "module"
typeItem _ = ""
-- FIXME: used to be in two different modules, now does and then undoes lots of stuff
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 = "package " ++ escapeHTML (strUnpack x) ++ ""
renderModule (breakEnd (== '.') . strUnpack -> (pre,post)) = "module " ++ escapeHTML pre ++ "" ++ escapeHTML post ++ ""
renderItem :: Entry -> String
renderItem = keyword . focus
where
keyword x | Just b <- stripPrefix "type family " x = "type family " ++ b
| (a,b) <- word1 x, a `elem` kws = "" ++ a ++ " " ++ b
| otherwise = x
where kws = words "class data type newtype"
name x = "" ++ x ++ "" :: 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 = "" ++ escapeHTML x ++ ""
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 -- newtype
| 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 -- constructors
| 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) -- tuple constructors
| (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) -- tuple data type
| (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 -- partial application, to share the initialisation cost
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"
-- Broken in the last HSE release, fixed in HSE HEAD
-- test "quotRemInt# :: Int# -> Int# -> (# Int#, Int# #)"
test "( # ) :: Int"
test "pattern MyPattern :: ()"