content: {-# 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.Maybe
  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
  import Safe
  
  
  -- | 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 [ignoreMath 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{}] -> pure () -- 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 [] ""
  
  
  -- See https://github.com/ndmitchell/hoogle/issues/353
  -- for functions like `tail` which start <math>.
  ignoreMath :: BStr -> BStr
  ignoreMath x | Just x <- "&lt;math&gt;" `bstrStripPrefix` x
               = fromMaybe x $ ". " `bstrStripPrefix` x
  ignoreMath x = x
  
  
  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 = "<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 (tailErr 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 -- 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 :: ()"
  