{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS -Wall -fno-warn-missing-signatures #-}

-- | Haddock compatibilty layer and query functions.

module Haskell.Docs.Haddock where

import           Haskell.Docs.Ghc
import           Haskell.Docs.Types

import           Control.Arrow
import           Control.Monad
import           Data.Either
import           Data.List
import           Data.Map (Map)
import qualified Data.Map as M
import           Documentation.Haddock
import           GHC hiding (verbosity)
import           GhcMonad (liftIO)
import           Name
import           PackageConfig
import           Packages

-- * Searching for ident docs

-- | Search a name in the given module.
search :: Maybe PackageConfig
       -> Maybe PackageName
       -> ModuleName
       -> Identifier
       -> Ghc (Either DocsException [IdentDoc])
search mprevious mpname mname name = do
  result <- getPackagesByModule mname
  case result of
    Left{} ->
      return (Left NoFindModule)
    Right [package]   ->
      searchWithPackage package mname name
    Right packages  ->
      case mpname of
        Nothing -> do
          fmap (Right . concat . rights)
               (mapM (\package -> searchWithPackage package mname name)
                     (filter (not . isPrevious) packages))
        Just pname -> do
          case find ((== pname) . PackageName . showPackageName . sourcePackageId) packages of
            Nothing ->
              return (Left NoModulePackageCombo)
            Just package ->
              searchWithPackage package mname name
  where isPrevious m =
          Just (sourcePackageId m) == fmap sourcePackageId mprevious

-- | Search for the given identifier in the given package.
searchWithPackage
  :: PackageConfig
  -> ModuleName
  -> Identifier
  -> Ghc (Either DocsException [IdentDoc])
searchWithPackage package mname name = do
  interfaceFiles <- getHaddockInterfacesByPackage package
  case (lefts interfaceFiles,rights interfaceFiles) of
    ([],[])        -> return (Left NoInterfaceFiles)
    (errs@(_:_),_) -> return (Left (NoParseInterfaceFiles errs))
    (_,files)      ->
      fmap (Right . concat)
           (forM files
                 (\interfaceFile ->
                    fmap (concat . rights)
                         (mapM (searchWithInterface package mname name)
                               (filter ((==mname) . moduleName . instMod)
                                       (ifInstalledIfaces interfaceFile)))))

-- | Search for the given identifier in the interface.
searchWithInterface
  :: PackageConfig
  -> ModuleName
  -> Identifier
  -> InstalledInterface
  -> Ghc (Either DocsException [IdentDoc])
searchWithInterface package mname name interface =
  case find ((==name) . Identifier . getOccString) (instExports interface) of
    Nothing ->
      return (Left NoFindNameInExports)
    Just{} ->
      case M.lookup (unIdentifier name) (interfaceNameMap interface) of
        Nothing ->
          case lookup (unIdentifier name) (map (getOccString &&& id) (instExports interface)) of
            Just subname
              | moduleName (nameModule subname) /= moduleName (instMod interface) ->
                descendSearch package name subname
            _ ->
              return (Left NoFindNameInInterface)
        Just d ->
          do mi <- findIdentifier mname name
             margs <- lookupArgsDocs interface name
             return
               (Right
                  [IdentDoc (sourcePackageId package)
                            d
                            mi
                            margs])

-- * Get documentation of parts of things

-- | Get a mapping from names to doc string of that name from a
-- Haddock interface.
interfaceNameMap :: InstalledInterface -> Map String (Doc String)
#if MIN_VERSION_haddock(2,10,0)
interfaceNameMap iface =
  M.fromList (map (second (fmap getOccString) . first getOccString)
             (M.toList (instDocMap iface)))
#else
interfaceNameMap iface =
  M.fromList (map (second (fmap getOccString . maybe DocEmpty id . fst) . first getOccString)
             (M.toList (instDocMap iface)))
#endif

-- | Get a mapping from names to doc string of that name from a
-- Haddock interface.
interfaceArgMap :: InstalledInterface -> Map String (Map Int (Doc Name))
#if MIN_VERSION_haddock(2,10,0)
interfaceArgMap iface =
  M.fromList (map (first getOccString) (M.toList (instArgMap iface)))
#else
interfaceArgMap iface = M.fromList (map (second (const M.empty) . first getOccString)
                                        (M.toList (instDocMap iface)))
#endif

-- | Find arguments documentation for the identifier.
lookupArgsDocs :: InstalledInterface -> Identifier -> Ghc (Maybe [(Int, Doc String)])
lookupArgsDocs interface name = do
  case M.lookup (unIdentifier name) (interfaceArgMap interface) of
    Nothing -> return Nothing
    Just argMap ->
      return (Just (map (second (fmap getOccString)) (M.toList argMap)))

-- * Querying for packages and interfaces

-- | Search for a module's package, returning suggestions if not
-- found.
getPackagesByModule :: ModuleName -> Ghc (Either [Module] [PackageConfig])
getPackagesByModule m =
  do df <- getSessionDynFlags
     return (fmap (map fst) (lookupModuleWithSuggestions df m))

-- | Get the Haddock interfaces of the given package.
getHaddockInterfacesByPackage :: PackageConfig -> Ghc [Either DocsException InterfaceFile]
getHaddockInterfacesByPackage =
  liftIO .
  mapM (fmap (either (Left . NoReadInterfaceFile) Right) . readInterfaceFile freshNameCache) .
  haddockInterfaces

-- * Internal functions

-- | The module symbol doesn't actually exist in the module we
-- intended, so we descend into the module that it does exist in and
-- restart our search process.
descendSearch :: PackageConfig -> Identifier -> Name -> Ghc (Either DocsException [IdentDoc])
descendSearch package name qname = do
  search (Just package) Nothing (moduleName (nameModule qname)) name