cabal-testsuite/PackageTests/SetupHooks/SetupHooksC2HsRules/SetupHooks.hs

   1 {-# LANGUAGE DataKinds #-}
   2 {-# LANGUAGE DeriveAnyClass #-}
   3 {-# LANGUAGE DeriveGeneric #-}
   4 {-# LANGUAGE DerivingStrategies #-}
   5 {-# LANGUAGE DeriveTraversable #-}
   6 {-# LANGUAGE DuplicateRecordFields #-}
   7 {-# LANGUAGE OverloadedStrings #-}
   8 {-# LANGUAGE RecordWildCards #-}
   9 {-# LANGUAGE RecursiveDo #-}
  10 {-# LANGUAGE StaticPointers #-}
  11
  12 module SetupHooks where
  13
  14 import Distribution.Compat.Binary
  15 import Distribution.ModuleName
  16 import Distribution.Simple.LocalBuildInfo (interpretSymbolicPathLBI)
  17 import Distribution.Simple.SetupHooks
  18 import Distribution.Simple.Utils
  19 import Distribution.Utils.Path
  20
  21 import Data.Foldable ( for_ )
  22 import Data.List ( isPrefixOf )
  23 import qualified Data.List.NonEmpty as NE ( NonEmpty(..) )
  24 import Data.String
  25 import Data.Traversable ( for )
  26 import GHC.Generics
  27
  28 import qualified Data.Map as Map
  29
  30 setupHooks :: SetupHooks
  31 setupHooks =
  32   noSetupHooks
  33     { buildHooks =
  34         noBuildHooks
  35           { preBuildComponentRules = Just $ rules (static ()) preBuildRules
  36           }
  37     }
  38
  39 preBuildRules :: PreBuildComponentInputs -> RulesM ()
  40 preBuildRules (PreBuildComponentInputs { buildingWhat = what, localBuildInfo = lbi, targetInfo = tgt }) = mdo
  41   let verbosity = buildingWhatVerbosity what
  42       clbi = targetCLBI tgt
  43       autogenDir = autogenComponentModulesDir lbi clbi
  44       buildDir = componentBuildDir lbi clbi
  45
  46       computeC2HsDepsAction (C2HsDepsInput {..}) = do
  47         importLine : _srcLines <- lines <$> readFile (getSymbolicPath $ inDir </> moduleNameSymbolicPath modNm <.> "myChs")
  48         let imports :: [ModuleName]
  49             imports
  50               | "imports:" `isPrefixOf` importLine
  51               = map fromString $ words $ drop 8 importLine
  52               | otherwise
  53               = error "Malformed MyChs file: first line should start with 'imports:'"
  54         warn verbosity $ "Computed C2Hs dependencies of " ++ modName modNm ++ ".myChs: "
  55                       ++ modNames imports
  56         return $
  57           ( [ RuleDependency $ RuleOutput rId 1
  58             | imp <- imports
  59             , let rId = ruleIds Map.! imp ]
  60           , imports )
  61
  62       runC2HsAction (C2HsInput {..}) importModNms = do
  63         let modPath = moduleNameSymbolicPath modNm
  64         warn verbosity $ "Running C2Hs on " ++ modName modNm ++ ".myChs.\n C2Hs dependencies: " ++ modNames importModNms
  65         _importLine : srcLines <- lines <$> readFile (getSymbolicPath $ inDir </> modPath <.> "myChs")
  66
  67         rewriteFileEx verbosity (getSymbolicPath $ hsDir </> modPath <.> "hs") $
  68           unlines $ ("module " ++ modName modNm ++ " where\n") :
  69             (map ( ( "import " ++ ) . modName ) importModNms ++ srcLines)
  70         rewriteFileEx verbosity (getSymbolicPath $ chiDir </> unsafeCoerceSymbolicPath modPath <.> "myChi") ""
  71
  72       mkRule modNm =
  73         dynamicRule (static Dict)
  74           (mkCommand (static Dict) (static computeC2HsDepsAction) $ C2HsDepsInput { ruleIds = modToRuleId, ..})
  75           (mkCommand (static Dict) (static runC2HsAction) $ C2HsInput {hsDir = autogenDir, chiDir = buildDir, ..})
  76           [ FileDependency $ Location inDir (modPath <.> "myChs") ]
  77           ( Location autogenDir (modPath <.> "hs" ) NE.:| [ Location buildDir (unsafeCoerceSymbolicPath modPath <.> "myChi") ] )
  78         where
  79           modPath = moduleNameSymbolicPath modNm
  80           inDir = sameDirectory
  81
  82   -- NB: in practice, we would get the module names by looking at the .cabal
  83   -- file and performing a search for `.chs` files on disk, but for this test
  84   -- we bake this in for simplicity.
  85   let mods = Map.fromList [ ((ix, fromString modNm), ())
  86                           | (ix, modNm) <- [ (0, "C"), (1, "A1"), (2, "B"), (3, "A2") ] ]
  87     -- NB: the extra indices are to ensure the traversal happens in a particular order,
  88     -- which ensures we correctly re-order rules to execute them in dependency order.
  89   modToRuleId <- fmap (Map.mapKeys snd) $ flip Map.traverseWithKey mods $ \ (i, modNm) () ->
  90     registerRule ("C2Hs " <> fromString (show i ++ " " ++ modName modNm)) $ mkRule modNm
  91   return ()
  92
  93 -- | Input to C2Hs dependency computation
  94 data C2HsDepsInput
  95   = C2HsDepsInput
  96   { verbosity :: Verbosity
  97   , inDir :: SymbolicPath Pkg (Dir Source)
  98   , modNm :: ModuleName
  99   , ruleIds :: Map.Map ModuleName RuleId
 100   }
 101   deriving stock ( Show, Generic )
 102   deriving anyclass Binary
 103
 104 -- | Input to C2Hs command
 105 data C2HsInput
 106   = C2HsInput
 107   { verbosity :: Verbosity
 108   , modNm :: ModuleName
 109   , inDir :: SymbolicPath Pkg (Dir Source)
 110   , hsDir :: SymbolicPath Pkg (Dir Source)
 111   , chiDir :: SymbolicPath Pkg (Dir Build)
 112   }
 113   deriving stock ( Show, Generic )
 114   deriving anyclass Binary
 115
 116 modName :: ModuleName -> String
 117 modName = intercalate "." . components
 118
 119 modNames :: [ModuleName] -> String
 120 modNames mns = "[" ++ intercalate ", " (map modName mns) ++ "]"