content: {-# LANGUAGE FlexibleContexts #-}
  {-# LANGUAGE RankNTypes       #-}
  
  -- TODO: a lot of the stuff in this module could be made pure so that it only
  -- gets called once
  module Package.C.Db.Register ( registerPkg
                               , unregisterPkg
                               , uninstallPkg
                               , uninstallPkgByName
                               , installedDb
                               , lookupOrFail
                               , cPkgToDir
                               , globalPkgDir
                               , printCompilerFlags
                               , printLinkerFlags
                               , printPkgConfigPath
                               , printIncludePath
                               , printLibPath
                               , printCabalFlags
                               , printLdLibPath
                               , packageInstalled
                               , allPackages
                               , parseHostIO
                               , Platform
                               ) where
  
  import           Control.Monad.Reader
  import           Control.Monad.State  (modify)
  import           CPkgPrelude
  import           Data.Binary          (encode)
  import qualified Data.ByteString.Lazy as BSL
  import           Data.Hashable        (Hashable (..))
  import           Data.List            (intercalate)
  import qualified Data.Set             as S
  import           Numeric              (showHex)
  import           Package.C.Db.Memory
  import           Package.C.Db.Monad
  import           Package.C.Db.Type
  import           Package.C.Error
  import           Package.C.Logging
  import           Package.C.Triple
  import           Package.C.Type       hiding (Dep (name))
  
  type Platform = String
  type FlagPrint = forall m. MonadIO m => BuildCfg -> m String
  
  allPackages :: IO [String]
  allPackages = do
      (InstallDb index) <- strictIndex
      pure (buildName <$> toList index)
  
  printCompilerFlags :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m ()
  printCompilerFlags = printFlagsWith buildCfgToCFlags
  
  printLinkerFlags :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m ()
  printLinkerFlags = printFlagsWith buildCfgToLinkerFlags
  
  printPkgConfigPath :: (MonadIO m, MonadDb m) => [String] -> Maybe Platform -> m ()
  printPkgConfigPath = printMany (liftIO . putStrLn <=< (fmap (intercalate ":") . traverse buildCfgToPkgConfigPath))
  
  printIncludePath :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m ()
  printIncludePath = printFlagsWith buildCfgToIncludePath
  
  printLibPath :: (MonadIO m, MonadDb m) => String -> Maybe Platform -> m ()
  printLibPath = printFlagsWith buildCfgToLibPath
  
  parseHostIO :: MonadIO m => Maybe Platform -> m (Maybe TargetTriple)
  parseHostIO (Just x) = fmap Just (parseTripleIO x)
  parseHostIO Nothing  = pure Nothing
  
  printFlagsWith :: (MonadIO m, MonadDb m) => FlagPrint -> String -> Maybe Platform -> m ()
  printFlagsWith f name host = do
  
      parsedHost <- parseHostIO host
  
      maybePackage <- lookupPackage name parsedHost
  
      case maybePackage of
          Nothing -> indexError name
          Just p  -> liftIO (putStrLn =<< f p)
  
  printMany :: (MonadIO m, MonadDb m) => ([BuildCfg] -> m ()) -> [String] -> Maybe Platform -> m ()
  printMany f names host = do
  
      parsedHost <- parseHostIO host
  
      maybePackages <- sequenceA <$> traverse (\n -> lookupPackage n parsedHost) names
  
      case maybePackages of
          Nothing -> indexError (head names)
          Just ps -> f ps
  
  printLdLibPath :: (MonadIO m, MonadDb m) => [String] -> Maybe Platform -> m ()
  printLdLibPath = printMany (liftIO . putStrLn <=< (fmap (intercalate ":") . traverse buildCfgToLibPath))
  
  printCabalFlags :: (MonadIO m, MonadDb m) => [String] -> Maybe Platform -> m ()
  printCabalFlags = printMany (liftIO . putStrLn <=< (fmap unwords . traverse buildCfgToCabalFlag))
  
  buildCfgToCabalFlag :: MonadIO m => BuildCfg -> m String
  buildCfgToCabalFlag = fmap (("--extra-lib-dirs=" ++) . (</> "lib")) . buildCfgToDir
  
  -- TODO: do something more sophisticated; allow packages to return their own
  -- dir?
  buildCfgToLinkerFlags :: MonadIO m => BuildCfg -> m String
  buildCfgToLinkerFlags = fmap (("-L" ++) . (</> "lib")) . buildCfgToDir
  
  buildCfgToCFlags :: MonadIO m => BuildCfg -> m String
  buildCfgToCFlags = fmap (("-I" ++) . (</> "include")) . buildCfgToDir
  
  buildCfgToPkgConfigPath :: MonadIO m => BuildCfg -> m String
  buildCfgToPkgConfigPath = fmap (</> "lib" </> "pkgconfig") . buildCfgToDir
  
  buildCfgToLibPath :: MonadIO m => BuildCfg -> m String
  buildCfgToLibPath = fmap (</> "lib") . buildCfgToDir
  
  buildCfgToIncludePath :: MonadIO m => BuildCfg -> m String
  buildCfgToIncludePath = fmap (</> "include") . buildCfgToDir
  
  installedDb :: (MonadIO m, MonadDb m)
                    => m (S.Set BuildCfg)
  installedDb =
      _installedPackages <$> memIndex
  
  packageInstalled :: (MonadIO m, MonadDb m)
                   => CPkg
                   -> Maybe TargetTriple
                   -> Bool
                   -> BuildVars
                   -> m Bool
  packageInstalled pkg host glob b = do
  
      packs <- installedDb
  
      pure $
             (pkgToBuildCfg pkg host glob True b `S.member` packs)
          || (pkgToBuildCfg pkg host glob False b `S.member` packs)
  
  lookupPackage :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m (Maybe BuildCfg)
  lookupPackage name host = do
  
      packs <- installedDb
  
      let matches = S.filter (\pkg -> buildName pkg == name && targetArch pkg == host) packs
  
      pure (S.lookupMax matches)
  
  lookupOrFail :: (MonadIO m, MonadDb m) => String -> Maybe TargetTriple -> m BuildCfg
  lookupOrFail name host = do
      pk <- lookupPackage name host
      case pk of
          Just cfg -> pure cfg
          Nothing  -> notInstalled name
  
  -- | @since 0.2.3.0
  uninstallPkgByName :: (MonadReader Verbosity m, MonadIO m, MonadDb m)
                     => String
                     -> Maybe TargetTriple
                     -> m ()
  uninstallPkgByName name host =
      uninstallPkg =<< lookupOrFail name host
  
  uninstallPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
               => BuildCfg
               -> m ()
  uninstallPkg cpkg = do
      unregisterPkg cpkg
      (liftIO . removeDirectoryRecursive)
          =<< buildCfgToDir cpkg
  
  unregisterPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
                => BuildCfg
                -> m ()
  unregisterPkg buildCfg = do
  
      putLoud ("Unregistering package " ++ buildName buildCfg ++ "...")
  
      indexFile <- pkgIndex
      indexContents <- memIndex
  
      let modIndex = over installedPackages (S.delete buildCfg)
          newIndex = modIndex indexContents
  
      modify modIndex
  
      liftIO $ BSL.writeFile indexFile (encode newIndex)
  
  -- TODO: replace this with a proper/sensible database
  registerPkg :: (MonadIO m, MonadDb m, MonadReader Verbosity m)
              => CPkg
              -> Maybe TargetTriple
              -> Bool -- ^ Globally installed?
              -> Bool -- ^ Manually installed?
              -> BuildVars
              -> m ()
  registerPkg cpkg host glob usr b = do
  
      putDiagnostic ("Registering package " ++ pkgName cpkg ++ "...")
  
      indexFile <- pkgIndex
      indexContents <- memIndex
  
      let buildCfg = pkgToBuildCfg cpkg host glob usr b
          modIndex = over installedPackages (S.insert buildCfg)
          newIndex = modIndex indexContents
  
      modify modIndex
  
      liftIO $ BSL.writeFile indexFile (encode newIndex)
  
  pkgToBuildCfg :: CPkg
                -> Maybe TargetTriple
                -> Bool
                -> Bool -- ^ Was this package manually installed?
                -> BuildVars
                -> BuildCfg
  pkgToBuildCfg (CPkg n v _ _ bds ds cCmd bCmd iCmd) host glob usr bVar =
      BuildCfg n v (go <$> bds) (go <$> ds) host glob (cCmd bVar) (bCmd bVar) (iCmd bVar) usr -- TODO: fix pinned build deps &c.
      where placeholderVersion = Version [0,1,0,0]
            go (Dep n' _) = (n', placeholderVersion)
  
  platformString :: Maybe TargetTriple -> (FilePath -> FilePath -> FilePath)
  platformString Nothing  = (</>)
  platformString (Just p) = \x y -> x </> show p </> y
  
  buildCfgToDir :: MonadIO m => BuildCfg -> m FilePath
  buildCfgToDir buildCfg = do
      global' <- globalPkgDir
      -- when hashing, pretend everything has was NOT manually installed so they
      -- all have the same hash
      let hashed = showHex (abs (hash (buildCfg { manual = False}))) mempty
          (<?>) = platformString (targetArch buildCfg)
      pure (global' <?> buildName buildCfg ++ "-" ++ showVersion (buildVersion buildCfg) ++ "-" ++ hashed)
  
  globDir :: Maybe TargetTriple -> FilePath
  globDir Nothing      = "/usr/local"
  globDir (Just arch') = "/usr" </> show arch'
  
  cPkgToDir :: MonadIO m
            => CPkg
            -> Maybe TargetTriple
            -> Bool
            -> BuildVars
            -> m FilePath
  cPkgToDir pk host False bv = buildCfgToDir (pkgToBuildCfg pk host False undefined bv)
  cPkgToDir _ host _ _       = pure (globDir host)
  