Internal.hs

{-# OPTIONS_HADDOCK hide, prune #-}
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE CPP, DeriveLift #-}
module Haddock.UseRefs.Internal where

import Data.Maybe (catMaybes)
import Documentation.Haddock.Parser
import Haddock.UseRefs.Type
import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Language.Preprocessor.Cpphs (runCpphs, defaultCpphsOptions)

#if !MIN_VERSION_template_haskell(2,23,0)
deriving instance Lift OccName
deriving instance Lift ModName
deriving instance Lift PkgName
deriving instance Lift NameSpace
deriving instance Lift NameFlavour
deriving instance Lift Name
#endif

-- | Call in module with names mentioned only in documentation to
-- avoid warnings.
countDocRefs :: Q [Dec]
countDocRefs = do
  fp <- loc_filename  <$> location
  ids <- extractQuotedStrings <$> loadSource fp
  [d|
   data HaddockRefsCounter
   instance CountHaddockRefs HaddockRefsCounter where
     countHaddockRefs _ = length $(lift =<< lookupNames ids)
   |]
  where
    loadSource fp = runIO (runCpphs defaultCpphsOptions fp =<< readFile fp)

-- | Extract quoted strings from Haddock comment
extractQuotedStrings ::
  String -> -- ^ Haskell source code
  [String]
extractQuotedStrings = foldl' (\b i -> i : b) [] . toRegular  . parseString


-- | Filter and resolve strings into type/value TH 'Language.Haskell.TH.Syntax.Name'.
lookupNames :: [String] -> Q [Name]
lookupNames ns = catMaybes <$> mapM lookupX ns
  where
    lookupX s = lookupTypeName s >>= \case
      Nothing -> lookupValueName s
      Just tn -> pure $ Just tn