serokell/importify

{-# 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)