{-# 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 :: Q [Dec]
countDocRefs = do
  fp <- Loc -> String
loc_filename  (Loc -> String) -> Q Loc -> Q String
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Q Loc
location
  ids <- extractQuotedStrings <$> loadSource fp
  [d|
   data HaddockRefsCounter
   instance CountHaddockRefs HaddockRefsCounter where
     countHaddockRefs _ = length $(lift =<< lookupNames ids)
   |]
  where
    loadSource :: String -> Q String
loadSource String
fp = IO String -> Q String
forall a. IO a -> Q a
runIO (CpphsOptions -> String -> String -> IO String
runCpphs CpphsOptions
defaultCpphsOptions String
fp (String -> IO String) -> IO String -> IO String
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> IO String
readFile String
fp)

-- | Extract quoted strings from Haddock comment
extractQuotedStrings ::
  String -> -- ^ Haskell source code
  [String]
extractQuotedStrings :: String -> [String]
extractQuotedStrings = ([String] -> String -> [String])
-> [String] -> DocH Any String -> [String]
forall b a. (b -> a -> b) -> b -> DocH Any a -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\[String]
b String
i -> String
i String -> [String] -> [String]
forall a. a -> [a] -> [a]
: [String]
b) [] (DocH Any String -> [String])
-> (String -> DocH Any String) -> String -> [String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DocH Any Identifier -> DocH Any String
forall mod. DocH mod Identifier -> DocH mod String
toRegular  (DocH Any Identifier -> DocH Any String)
-> (String -> DocH Any Identifier) -> String -> DocH Any String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> DocH Any Identifier
forall mod. String -> DocH mod Identifier
parseString


-- | Filter and resolve strings into type/value TH 'Language.Haskell.TH.Syntax.Name'.
lookupNames :: [String] -> Q [Name]
lookupNames :: [String] -> Q [Name]
lookupNames [String]
ns = [Maybe Name] -> [Name]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe Name] -> [Name]) -> Q [Maybe Name] -> Q [Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (String -> Q (Maybe Name)) -> [String] -> Q [Maybe Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM String -> Q (Maybe Name)
lookupX [String]
ns
  where
    lookupX :: String -> Q (Maybe Name)
lookupX String
s = String -> Q (Maybe Name)
lookupTypeName String
s Q (Maybe Name) -> (Maybe Name -> Q (Maybe Name)) -> Q (Maybe Name)
forall a b. Q a -> (a -> Q b) -> Q b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe Name
Nothing -> String -> Q (Maybe Name)
lookupValueName String
s
      Just Name
tn -> Maybe Name -> Q (Maybe Name)
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Name -> Q (Maybe Name)) -> Maybe Name -> Q (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Name -> Maybe Name
forall a. a -> Maybe a
Just Name
tn