content: {-# LANGUAGE CPP           #-}
  {-# LANGUAGE DeriveGeneric #-}
  {-# LANGUAGE TupleSections #-}
  
  -- | Functions to retrieve and store mapping from modules to their
  -- targets and extensions.
  
  module Importify.Cabal.Target
         ( -- * Maps from modules paths to cache parts
           ExtensionsMap
         , ModulesMap
  
           -- * Target types
         , ModulesBundle (..)
         , TargetId      (..)
  
           -- * Utilities to extract targets
         , extractTargetBuildInfo
         , extractTargetsMap
         , packageExtensions
         , packageTargets
         , targetIdDir
         ) where
  
  import Universum hiding (fromString)
  
  import Data.Aeson (FromJSON (parseJSON), FromJSONKey (fromJSONKey),
                     FromJSONKeyFunction (FromJSONKeyTextParser), ToJSON (toJSON),
                     ToJSONKey (toJSONKey), Value (String), object, withObject, withText, (.:), (.=))
  import Data.Aeson.Types (Parser, toJSONKeyText)
  import Data.Hashable (Hashable)
  import Distribution.ModuleName (ModuleName)
  import Distribution.PackageDescription (Benchmark (..), BenchmarkInterface (..), BuildInfo (..),
                                          CondTree, Executable (..), GenericPackageDescription (..),
                                          Library (..), TestSuite (..), TestSuiteInterface (..),
                                          condTreeData)
  #if MIN_VERSION_Cabal(2,0,0)
  import Distribution.Types.UnqualComponentName (UnqualComponentName, unUnqualComponentName)
  #endif
  
  import Language.Haskell.Exts (prettyExtension)
  import Path (Abs, Dir, File, Path, fromAbsFile)
  
  import Importify.Cabal.Extension (buildInfoExtensions)
  import Importify.Cabal.Module (modulePaths)
  
  import qualified Data.HashMap.Strict as HM
  import qualified Data.Text as T (split)
  
  -- | Mapping from module path to its package and module name.
  type    ModulesMap = HashMap FilePath ModulesBundle  -- cached globally
  type    TargetsMap = HashMap FilePath TargetId       -- not cached
  type ExtensionsMap = HashMap TargetId [String]       -- cached per project package
  
  data TargetId = LibraryId
                | ExecutableId !Text
                | TestSuiteId  !Text
                | BenchmarkId  !Text
                deriving (Show, Eq, Generic)
  
  instance Hashable TargetId
  
  instance ToJSON TargetId where
      toJSON = String . targetIdDir
  
  instance ToJSONKey TargetId where
      toJSONKey = toJSONKeyText targetIdDir
  
  -- | Directory name for corresponding target.
  targetIdDir :: TargetId -> Text
  targetIdDir LibraryId               = "library"
  targetIdDir (ExecutableId exeName)  = "executable@" <> exeName
  targetIdDir (TestSuiteId testName)  = "test-suite@" <> testName
  targetIdDir (BenchmarkId benchName) = "benchmark@"  <> benchName
  
  instance FromJSON TargetId where
      parseJSON = withText "targetId" targetIdParser
  
  instance FromJSONKey TargetId where
      fromJSONKey = FromJSONKeyTextParser targetIdParser
  
  targetIdParser :: Text -> Parser TargetId
  targetIdParser targetText = do
      let targetName = T.split (== '@') targetText
      case targetName of
          ["library"]              -> pure   LibraryId
          ["executable", exeName]  -> pure $ ExecutableId exeName
          ["test-suite", testName] -> pure $ TestSuiteId testName
          ["benchmark", benchName] -> pure $ BenchmarkId benchName
          _                        -> fail $ "Unexpected target: " ++ toString targetText
  
  -- | All data for given module. This is needed to locate all required
  -- information about module by its path.
  data ModulesBundle = ModulesBundle
      { mbPackage :: !Text      -- ^ Module package, like @importify-1.0@
      , mbModule  :: !String    -- ^ Full module name, like @Importify.Main@
      , mbTarget  :: !TargetId  -- ^ Target of module
      } deriving (Show, Eq)
  
  instance ToJSON ModulesBundle where
      toJSON ModulesBundle{..} = object
          [ "package" .= mbPackage
          , "module"  .= mbModule
          , "target"  .= mbTarget
          ]
  
  instance FromJSON ModulesBundle where
      parseJSON = withObject "ModulesBundle" $ \obj -> do
          mbPackage <- obj .: "package"
          mbModule  <- obj .: "module"
          mbTarget  <- obj .: "target"
          pure ModulesBundle{..}
  
  -- | Extract every 'TargetId' for given project description.
  packageTargets :: GenericPackageDescription -> [TargetId]
  packageTargets GenericPackageDescription{..} =
    concat
      [ maybe [] (const [LibraryId]) condLibrary
      , targetMap ExecutableId condExecutables
      , targetMap TestSuiteId  condTestSuites
      , targetMap BenchmarkId  condBenchmarks
      ]
    where
  #if MIN_VERSION_Cabal(2,0,0)
      targetMap tid = map (tid . toText . unUnqualComponentName . fst)
  #else
      targetMap tid = map (tid . toText . fst)
  #endif
  
  -- | Extracts 'BuildInfo' for given 'TargetId'.
  extractTargetBuildInfo
      :: TargetId
      -> GenericPackageDescription
      -> Maybe BuildInfo
  extractTargetBuildInfo LibraryId = fmap (libBuildInfo . condTreeData) . condLibrary
  extractTargetBuildInfo (ExecutableId name) =
      findTargetBuildInfo buildInfo name . condExecutables
  extractTargetBuildInfo (TestSuiteId name) =
      findTargetBuildInfo testBuildInfo name . condTestSuites
  extractTargetBuildInfo (BenchmarkId name) =
      findTargetBuildInfo benchmarkBuildInfo name . condBenchmarks
  
  #if MIN_VERSION_Cabal(2,0,0)
  findTargetBuildInfo :: (target -> info)
                      -> Text
                      -> [(UnqualComponentName, CondTree v c target)]
                      -> Maybe info
  findTargetBuildInfo toInfo name =
      fmap (toInfo . condTreeData . snd)
    . find ((== name) . toText . unUnqualComponentName . fst)
  #else
  findTargetBuildInfo :: (target -> info)
                      -> Text
                      -> [(String, CondTree v c target)]
                      -> Maybe info
  findTargetBuildInfo toInfo name = fmap (toInfo . condTreeData . snd)
                                  . find ((== name) . toText . fst)
  #endif
  
  -- | Extracts mapping from each package target to its extensions enabled by default.
  packageExtensions :: [TargetId] -> GenericPackageDescription -> ExtensionsMap
  packageExtensions targetIds desc = mconcat $ mapMaybe targetToExtensions targetIds
    where
      targetToExtensions :: TargetId -> Maybe ExtensionsMap
      targetToExtensions targetId = toMap targetId <$> extractTargetBuildInfo targetId desc
  
      toMap :: TargetId -> BuildInfo -> ExtensionsMap
      toMap targetId info = one (targetId, map prettyExtension $ buildInfoExtensions info)
  
  -- | This function extracts 'ModulesMap' from given package by given
  -- full path to project root directory.
  extractTargetsMap :: Path Abs Dir -> GenericPackageDescription -> IO TargetsMap
  extractTargetsMap projectPath GenericPackageDescription{..} = do
      libTM    <- libMap
      exeTMs   <- exeMaps
      testTMs  <- testMaps
      benchTMs <- benchMaps
  
      return $ HM.unions $ libTM : exeTMs ++ testTMs ++ benchTMs
    where
      projectPaths :: BuildInfo -> Either [ModuleName] FilePath -> IO [Path Abs File]
      projectPaths = modulePaths projectPath
  
      libPaths :: Library -> IO [Path Abs File]
      libPaths Library{..} = projectPaths libBuildInfo (Left exposedModules)
  
      exePaths :: Executable -> IO [Path Abs File]
      exePaths Executable{..} = projectPaths buildInfo (Right modulePath)
  
      testPaths :: TestSuite -> IO [Path Abs File]
      testPaths TestSuite{..} = projectPaths testBuildInfo $ case testInterface of
          TestSuiteExeV10 _ path -> Right path
          TestSuiteLibV09 _ name -> Left [name]
          TestSuiteUnsupported _ -> Left []
  
      benchPaths :: Benchmark -> IO [Path Abs File]
      benchPaths Benchmark{..} = projectPaths benchmarkBuildInfo $ case benchmarkInterface of
          BenchmarkExeV10 _ path -> Right path
          BenchmarkUnsupported _ -> Left []
  
      libMap :: IO TargetsMap
      libMap = maybe mempty
                     ( collectTargetsMap libPaths
                                         LibraryId
                     . condTreeData)
                     condLibrary
  
      exeMaps :: IO [TargetsMap]
      exeMaps = collectTargetsListMaps condExecutables
                                       ExecutableId
                                       (collectTargetsMap exePaths)
  
      testMaps :: IO [TargetsMap]
      testMaps = collectTargetsListMaps condTestSuites
                                        TestSuiteId
                                        (collectTargetsMap testPaths)
  
      benchMaps :: IO [TargetsMap]
      benchMaps = collectTargetsListMaps condBenchmarks
                                         BenchmarkId
                                         (collectTargetsMap benchPaths)
  
  
  -- | Generalized 'TargetsMap' collector for executables, testsuites and
  -- benchmakrs of package.
  #if MIN_VERSION_Cabal(2,0,0)
  collectTargetsListMaps :: [(UnqualComponentName, CondTree v c target)]
                         -> (Text -> TargetId)
                         -> (TargetId -> target -> IO TargetsMap)
                         -> IO [TargetsMap]
  collectTargetsListMaps treeList idConstructor mapBundler =
      forM treeList $ \(name, condTree) ->
          mapBundler (idConstructor $ toText $ unUnqualComponentName name)
                     (condTreeData condTree)
  #else
  collectTargetsListMaps :: [(String, CondTree v c target)]
                         -> (Text -> TargetId)
                         -> (TargetId -> target -> IO TargetsMap)
                         -> IO [TargetsMap]
  collectTargetsListMaps treeList idConstructor mapBundler =
      forM treeList $ \(name, condTree) ->
          mapBundler (idConstructor $ toText name) $ condTreeData condTree
  #endif
  
  collectTargetsMap :: (target -> IO [Path Abs File])
                    -> TargetId
                    -> target
                    -> IO TargetsMap
  collectTargetsMap modulePathsExtractor targetId target = do
      pathsToModules <- modulePathsExtractor target
      return $ constructModulesMap (map fromAbsFile pathsToModules)
    where
      constructModulesMap :: [FilePath] -> TargetsMap
      constructModulesMap = HM.fromList . map (, targetId)
  