<commit_before>--
-- Haddock - A Haskell Documentation Tool
--
-- (c) <NAME> 2003
--
-- This file, (c) <NAME> 2006-2008
-- Write out Hoogle compatible documentation
-- http://www.haskell.org/hoogle/

module Haddock.Backends.Hoogle ( 
    ppHoogle
  ) where


import Haddock.GHC
import GHC hiding ((<.>))
import SrcLoc
import Outputable

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import System.FilePath


prefix = ["-- Hoogle documentation, generated by Haddock"
         ,"-- See Hoogle, http://www.haskell.org/hoogle/"
         ,""]


ppHoogle :: String -> String -> [Interface] -> FilePath -> IO ()
ppHoogle package version ifaces odir = do
    let filename = package <.> "txt"
        contents = prefix ++
                   ["@package " ++ package] ++
                   ["@version " ++ version | version /= ""] ++
                   concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
    writeFile (odir </> filename) (unlines contents)


ppModule :: Interface -> [String]
ppModule iface = "" : doc (ifaceDoc iface) ++
                 ["module " ++ moduleString (ifaceMod iface)] ++
                 concatMap ppExport exported ++
                 concatMap ppInstance (ifaceInstances iface)
    where
        locals = Set.fromList $ ifaceLocals iface
        exported = [i | i@(ExportDecl{expItemDecl=decl}) <- ifaceExportItems iface
                      , isLocal (unLoc decl)]
        isLocal decl
          | Just name <- getMainDeclBinder decl = name `Set.member` locals
          | otherwise = False


---------------------------------------------------------------------
-- Utility functions

unL (L _ x) = x
reL = L undefined


dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
dropComment [] = []


out :: Outputable a => a -> String
out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
    where
        f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
        f (x:xs) = x : f xs
        f [] = []


typeSig :: String -> [String] -> String
typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds)


---------------------------------------------------------------------
-- How to print each export

ppExport :: ExportItem Name -> [String]
ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl)
    where
        f (TyClD d@TyData{}) = ppData d
        f (TyClD d@ClassDecl{}) = ppClass d
        f (ForD (ForeignImport name typ _)) = [out $ SigD $ TypeSig name typ]
        f (ForD (ForeignExport name typ _)) = [out $ SigD $ TypeSig name typ]
        f decl = [out decl]
ppExport _ = []


-- note: does not yet output documentation for class methods
ppClass :: TyClDecl Name -> [String]
ppClass x = out x{tcdSigs=[]} :
            map (out . addContext . unL) (tcdSigs x)
    where
        addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
        f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d
        f x = HsForAllTy Implicit [] (reL [context]) (reL x)

        context = reL $ HsClassP (unL $ tcdLName x)
            (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x))

        tyVar (UserTyVar x) = x
        tyVar (KindedTyVar x _) = x


ppInstance :: Instance -> [String]
ppInstance x = [dropComment $ out x]


ppData :: TyClDecl Name -> [String]
ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
           concatMap (ppCtor x . unL) (tcdCons x)
    where
        -- GHC gives out "data Bar =", we want to delete the equals
        showData = reverse . dropWhile (`elem` " =") . reverse . out


ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
    where
        f (PrefixCon args) = [typeSig name $ map out args ++ [resType]]
        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
        f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
                          [ldoc (cd_fld_doc r) ++
                           [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r]]
                          | r <- recs]

        name = out $ unL $ con_name con

        resType = case con_res con of
            ResTyH98 -> unwords $ out (tcdLName dat) : map out (tcdTyVars dat)
            ResTyGADT x -> out $ unL x


---------------------------------------------------------------------
-- DOCUMENTATION

ldoc :: Maybe (LHsDoc Name) -> [String]
ldoc = doc . liftM unL

doc :: Maybe (HsDoc Name) -> [String]
doc Nothing = []
doc (Just d) = "" : zipWith (++) ("-- | " : repeat "--   ") (showTags $ markup markupTag d)


data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
           deriving Show

type Tags = [Tag]

box f x = [f x]
str a = [Str a]

-- TODO:
-- want things like paragraph, pre etc to be handled by blank lines in the source document
-- and things like \n and \t converted away
-- much like blogger in HTML mode
-- everything else wants to be included as tags, neatly nested for some (ul,li,ol)
-- or inlne for others (a,i,tt)
-- entities (&,>,<) should always be appropriately escaped

markupTag :: DocMarkup Name [Tag]
markupTag = Markup {<commit_msg>Remove the TODO in the Hoogle HTML generation, was already done<commit_after>--
-- Haddock - A Haskell Documentation Tool
--
-- (c) <NAME> 2003
--
-- This file, (c) <NAME> 2006-2008
-- Write out Hoogle compatible documentation
-- http://www.haskell.org/hoogle/

module Haddock.Backends.Hoogle ( 
    ppHoogle
  ) where


import Haddock.GHC
import GHC hiding ((<.>))
import SrcLoc
import Outputable

import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
import qualified Data.Set as Set
import System.FilePath


prefix = ["-- Hoogle documentation, generated by Haddock"
         ,"-- See Hoogle, http://www.haskell.org/hoogle/"
         ,""]


ppHoogle :: String -> String -> [Interface] -> FilePath -> IO ()
ppHoogle package version ifaces odir = do
    let filename = package <.> "txt"
        contents = prefix ++
                   ["@package " ++ package] ++
                   ["@version " ++ version | version /= ""] ++
                   concat [ppModule i | i <- ifaces, OptHide `notElem` ifaceOptions i]
    writeFile (odir </> filename) (unlines contents)


ppModule :: Interface -> [String]
ppModule iface = "" : doc (ifaceDoc iface) ++
                 ["module " ++ moduleString (ifaceMod iface)] ++
                 concatMap ppExport exported ++
                 concatMap ppInstance (ifaceInstances iface)
    where
        locals = Set.fromList $ ifaceLocals iface
        exported = [i | i@(ExportDecl{expItemDecl=decl}) <- ifaceExportItems iface
                      , isLocal (unLoc decl)]
        isLocal decl
          | Just name <- getMainDeclBinder decl = name `Set.member` locals
          | otherwise = False


---------------------------------------------------------------------
-- Utility functions

unL (L _ x) = x
reL = L undefined


dropComment (' ':'-':'-':' ':_) = []
dropComment (x:xs) = x : dropComment xs
dropComment [] = []


out :: Outputable a => a -> String
out = f . unwords . map (dropWhile isSpace) . lines . showSDocUnqual . ppr
    where
        f xs | " <document comment>" `isPrefixOf` xs = f $ drop 19 xs
        f (x:xs) = x : f xs
        f [] = []


typeSig :: String -> [String] -> String
typeSig name flds = name ++ " :: " ++ concat (intersperse " -> " flds)


---------------------------------------------------------------------
-- How to print each export

ppExport :: ExportItem Name -> [String]
ppExport (ExportDecl decl dc _) = doc dc ++ f (unL decl)
    where
        f (TyClD d@TyData{}) = ppData d
        f (TyClD d@ClassDecl{}) = ppClass d
        f (ForD (ForeignImport name typ _)) = [out $ SigD $ TypeSig name typ]
        f (ForD (ForeignExport name typ _)) = [out $ SigD $ TypeSig name typ]
        f decl = [out decl]
ppExport _ = []


-- note: does not yet output documentation for class methods
ppClass :: TyClDecl Name -> [String]
ppClass x = out x{tcdSigs=[]} :
            map (out . addContext . unL) (tcdSigs x)
    where
        addContext (TypeSig name (L l sig)) = TypeSig name (L l $ f sig)
        f (HsForAllTy a b con d) = HsForAllTy a b (reL $ context : unL con) d
        f x = HsForAllTy Implicit [] (reL [context]) (reL x)

        context = reL $ HsClassP (unL $ tcdLName x)
            (map (reL . HsTyVar . tyVar . unL) (tcdTyVars x))

        tyVar (UserTyVar x) = x
        tyVar (KindedTyVar x _) = x


ppInstance :: Instance -> [String]
ppInstance x = [dropComment $ out x]


ppData :: TyClDecl Name -> [String]
ppData x = showData x{tcdCons=[],tcdDerivs=Nothing} :
           concatMap (ppCtor x . unL) (tcdCons x)
    where
        -- GHC gives out "data Bar =", we want to delete the equals
        showData = reverse . dropWhile (`elem` " =") . reverse . out


ppCtor :: TyClDecl Name -> ConDecl Name -> [String]
ppCtor dat con = ldoc (con_doc con) ++ f (con_details con)
    where
        f (PrefixCon args) = [typeSig name $ map out args ++ [resType]]
        f (InfixCon a1 a2) = f $ PrefixCon [a1,a2]
        f (RecCon recs) = f (PrefixCon $ map cd_fld_type recs) ++ concat
                          [ldoc (cd_fld_doc r) ++
                           [out (unL $ cd_fld_name r) `typeSig` [resType, out $ cd_fld_type r]]
                          | r <- recs]

        name = out $ unL $ con_name con

        resType = case con_res con of
            ResTyH98 -> unwords $ out (tcdLName dat) : map out (tcdTyVars dat)
            ResTyGADT x -> out $ unL x


---------------------------------------------------------------------
-- DOCUMENTATION

ldoc :: Maybe (LHsDoc Name) -> [String]
ldoc = doc . liftM unL

doc :: Maybe (HsDoc Name) -> [String]
doc Nothing = []
doc (Just d) = "" : zipWith (++) ("-- | " : repeat "--   ") (showTags $ markup markupTag d)


data Tag = TagL Char [Tags] | TagP Tags | TagPre Tags | TagInline String Tags | Str String
           deriving Show

type Tags = [Tag]

box f x = [f x]
str a = [Str a]

-- want things like paragraph, pre etc to be handled by blank lines in the source document
-- and things like \n and \t converted away
-- much like blogger in HTML mode
-- everything else wants to be included as tags, neatly nested for some (ul,li,ol)
-- or inlne for others (a,i,tt)
-- entities (&,>,<) should always be appropriately escaped

markupTag :: DocMarkup Name [Tag]
markupTag = Markup {
{'fraction_non_alphanumeric': 0.1598012042435248, 'fraction_numerical': 0.003822995316830737, 'mean_word_length': 2.033922876195999, 'pattern_counts': {'":': 0, '<': 25, '<?xml version=': 0, '>': 57, 'https://': 0, 'lorem ipsum': 0, 'www.': 4, 'xml': 0}, 'pii_count': 0, 'substrings_counts': 0, 'word_list_counts': {'cursed_substrings.json': 0, 'profanity_word_list.json': 0, 'sexual_word_list.json': 0, 'zh_pornsignals.json': 0}}
{'dir': 'git-commits-cleaned', 'id': '3927038', 'n_tokens_mistral': 3393, 'n_tokens_neox': 3254, 'n_words': 1133}