Conf.hs

module Pipe.Conf where
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.M
import PackageConf
import FilePath       
import Text.ParserCombinators.Parsec hiding (State)
import qualified Distribution.InstalledPackageInfo   as CI
import qualified Distribution.Simple.Compiler        as CC
import qualified Distribution.Simple.GHC             as CG
import qualified Distribution.Simple.PackageIndex    as CI
import qualified Distribution.Simple.Program.Builtin as CP
import qualified Distribution.Simple.Program.Db      as CP
import qualified Distribution.Simple.Program         as CP
import qualified Distribution.Package as C
import qualified Distribution.Verbosity           as CVB
import qualified Distribution.Version             as CV
import qualified Distribution.Text        as CT
import Db
import qualified Options as O
import           Data.Maybe
import           Data.Maybe.Util
import qualified Data.List as L
import qualified Data.Set  as S
import Pipes
import qualified Module as Ghc
import Data.String.Util

field :: String -> Parser String
field str =
  string str 
  >> char ':'
  >> many (char ' ') 
  >> manyTill anyToken (void (char '\n') <|> eof)

singleField :: String -> Parser String 
singleField str = try (field str) <|> (anyToken >> singleField str) 
 
parsedDbPath :: String -> M String 
parsedDbPath path = do
  buf <- liftIO $ readFile path
  fromE $ runParser (singleField "package-db") () path buf

cabalSandboxConfig :: FilePath
cabalSandboxConfig = "./cabal.sandbox.config"       

cabalDb :: Db -> M CC.PackageDB
cabalDb db = 
  case db of
    (Global   ) -> return CC.GlobalPackageDB
    (User     ) -> return CC.UserPackageDB
    (Dir  p) ->
      fromCheck =<< liftIO (checkDir p "b") 
    s@(Sandbox) ->
      fromCheck =<< liftIO (checkFile cabalSandboxConfig (show s)) 
  where
    fromCheck Nothing        =
      CC.SpecificPackageDB <$> parsedDbPath cabalSandboxConfig 
    fromCheck (Just err_str) =
      err err_str 
        
ghcVersionRange :: CV.VersionRange
ghcVersionRange = 
 CV.intersectVersionRanges 
   (CV.orLaterVersion (CV.Version [7,10]   [])) 
   (CV.earlierVersion (CV.Version [7,10,2] [])) 

toIndex :: [CC.PackageDB] -> M CI.InstalledPackageIndex 
toIndex stack = do 
  version <- liftIO $ CP.programFindVersion CP.ghcPkgProgram CVB.normal "ghc-pkg"
  case version of
    Nothing ->
      warning $
        "unable to determine ghc-pkg version, \n" ++ clause
    Just v ->
      unless (CV.withinRange v ghcVersionRange) $ 
        warning $
          "ghc-pkg version: "
          ++ show (CT.disp v) ++ " not within allowable range,\n"
          ++ clause
  liftIO $ do
    minimal_programs <- CP.configureAllKnownPrograms CVB.normal $ 
      CP.restoreProgramDb [CP.ghcPkgProgram, CP.ghcProgram] CP.emptyProgramDb

    CG.getInstalledPackages CVB.silent stack minimal_programs
  where
    clause :: String
    clause = 
      "results may not match current supported haddock: " 
      ++ show (CT.disp ghcVersionRange) 

fromIndex :: C.Dependency -> CI.InstalledPackageIndex -> Maybe PackageConf 
fromIndex dep index = 
  let 
    -- For clarity:
    versions :: [(CV.Version, [CI.InstalledPackageInfo])]
    versions = CI.lookupDependency index dep
  in
    listToMaybe . catMaybes . concatMap (map toConf . snd) $ versions 
  where
    toConf :: CI.InstalledPackageInfo -> Maybe PackageConf 
    toConf info = do 
      interfaceFile' <- listToMaybe $ CI.haddockInterfaces info
      htmlDir'       <- listToMaybe $ CI.haddockHTMLs info
      return $ 
        PackageConf 
          (Ghc.stringToPackageKey . show . CT.disp $ CI.sourcePackageId info)
          interfaceFile' htmlDir' 
          (CI.exposed info)

toOptionDbs :: O.Options -> S.Set Db
toOptionDbs options = 
  S.fromList . catMaybes $ 
    (Dir <$> O.db options) 
    : map (uncurry toMaybe)
        [ (not $ O.nouser options, User), (O.sandbox options, Sandbox) ]

-- | Produce remaining db's given total ordering of dbs and possibly
-- smaller list of dbs.
fromOrdering :: [Db] -> S.Set Db -> Either String [Db]
fromOrdering []           s =
  if S.null s then
    Right []
  else
    Left $ "failed to match package db(s) with defined ordering, dbs:\n" ++ 
           (indenting 2 . listing $ S.toList s)
fromOrdering (o:ordering) s =  
  if not $ S.member o s then 
    fromOrdering ordering s
  else
    case L.find (o ==) (S.elems s) of
       Nothing -> Left "failed to find matched db in ordering"
       Just e  -> (e :) <$> fromOrdering ordering (S.delete o s)

pipe_PackageConf :: O.Options -> PipeM C.Dependency PackageConf ()
pipe_PackageConf options = do
  index <- lift $ do 
    dbs <- -- Right now the cabal API requires a global db,
          -- and for that to be first.
      (Global:)
      <$>
      fromE (fromOrdering (O.dbOrdering options) $ toOptionDbs options)
    liftIO . putStr $
      "using package db stack:\n"
      ++ (listing $ map ((++) " > " . show) dbs)
      ++ "\n\n"
    toIndex =<< stackreverse <$> mapM cabalDb dbs
  forever $ do
    dep <- await
    case fromIndex dep index of 
      Nothing -> 
        lift . warning $ 
          "failed to find suitable documentation candidate for package:\n " 
          ++ (show . CT.disp $ dep) 
      Just conf -> do
        strings <- liftIO $ problems conf
        if L.null strings then
          yield conf
        else do
          lift . warning $ 
            "skipping package: " ++ show (CT.disp dep) ++ ", with conf problems:\n" 
             ++ indenting 2 (listing strings)
          return ()
  where
    -- | Counter-intuitively,
    -- Cabal right now actually evaluates the stack from right to left.
    -- not left to right.. and we still have to preserve the first member
    -- (Global)
    stackreverse s = head s : L.reverse (drop 1 s)