content: {-# LANGUAGE GADTs #-}
  
  module Rules.Compile (compilePackage) where
  
  import Hadrian.BuildPath
  import Hadrian.Oracles.TextFile
  
  import Base
  import Context as C
  import Expression
  import Oracles.Flag (platformSupportsSharedLibs)
  import Rules.Generate
  import Settings
  import Target
  import Utilities
  
  import qualified Text.Parsec as Parsec
  
  -- * Rules for building objects and Haskell interface files
  
  compilePackage :: [(Resource, Int)] -> Rules ()
  compilePackage rs = do
      root <- buildRootRules
      -- We match all file paths that look like:
      --   <root>/...stuffs.../build/...stuffs.../<something>.<suffix>
      --
      -- where:
      --   - the '...stuffs...' bits can be one or more path components,
      --   - the '<suffix>' part is a way prefix (e.g thr_p_, or nothing if
      --     vanilla) followed by an object file extension, without the dot
      --     (o, o-boot, hi, hi-boot),
      --
      -- and parse the information we need (stage, package path, ...) from
      -- the path and figure out the suitable way to produce that object file.
      alternatives $ do
        -- Language is identified by subdirectory under /build.
        -- These are non-haskell files so only have a .o or .<way>_o suffix.
        [ root -/- "**/build/c/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs C
  
        [ root -/- "**/build/cmm/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs Cmm
  
        [ root -/- "**/build/cpp/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs Cxx
  
        [ root -/- "**/build/s/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs Asm
  
        [ root -/- "**/build/S/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs Asm
  
        [ root -/- "**/build/js/**/*." ++ wayPat ++ "o"
          | wayPat <- wayPats] |%> compileNonHsObject rs JS
  
        -- All else is haskell.
        -- These come last as they overlap with the above rules' file patterns.
  
        -- When building dynamically we depend on the static rule if shared libs
        -- are supported, because it will add the -dynamic-too flag when
        -- compiling to build the dynamic files alongside the static files
        ( root -/- "**/build/**/*.dyn_o" :& root -/- "**/build/**/*.dyn_hi" :& Nil )
          &%> \ ( dyn_o :& _dyn_hi :& _ ) -> do
            p <- platformSupportsSharedLibs
            if p
              then do
                 -- We `need` ".o/.hi" because GHC is called with `-dynamic-too`
                 -- and builds ".dyn_o/.dyn_hi" too.
                 changed <- needHasChanged [dyn_o -<.> "o", dyn_o -<.> "hi"]
  
                 -- If for some reason a previous Hadrian execution has been
                 -- interrupted after the rule for .o/.hi generation has completed
                 -- but before the current rule for .dyn_o/.dyn_hi has completed,
                 -- or if some of the dynamic artifacts have been removed by the
                 -- user, "needing" the non dynamic artifacts is not enough as
                 -- Shake won't execute the associated action. Hence we detect
                 -- this case and we explicitly build the dynamic artifacts here:
                 case changed of
                    [] -> compileHsObjectAndHi rs dyn_o
                    _  -> pure ()
  
              else compileHsObjectAndHi rs dyn_o
  
        forM_ ((,) <$> hsExts <*> wayPats) $ \ ((oExt, hiExt), wayPat) ->
          (  (root -/- "**/build/**/*." ++ wayPat ++ oExt)
          :& (root -/- "**/build/**/*." ++ wayPat ++ hiExt)
          :& Nil ) &%>
            \ ( o :& _hi :& _ ) ->
              compileHsObjectAndHi rs o
    where
      hsExts = [ ("o", "hi")
               , ("o-boot", "hi-boot")
               ]
      wayPats = [ "", "*_" ]
  
  -- * Object file paths types and parsers
  
  {- We are using a non uniform representation that separates
     object files produced from Haskell code and from other
     languages, because the two "groups" have to be parsed
     differently enough that this would complicated the parser
     significantly.
  
     Indeed, non-Haskell files can only produce .o (or .thr_o, ...)
     files while Haskell modules can produce those as well as
     interface files, both in -boot or non-boot variants.
  
     Moreover, non-Haskell object files live under:
       <root>/stage<N>/<path/to/pkg>/build/{c,cmm,s}/
  
     while Haskell object/interface files live under:
       <root>/stage<N>/<path/to/pkg>/build/
  
     So the kind of object is partially determined by
     whether we're in c/, cmm/ or s/ but also by the
     object file's extension, in the case of a Haskell file.
     This could have been addressed with some knot-tying but
     Parsec's monad doesn't give us a MonadFix instance.
  
     We therefore stick to treating those two type of object
     files non uniformly.
  -}
  
  -- | Non Haskell source languages that we compile to get object files.
  data SourceLang = Asm | C | Cmm | Cxx | JS deriving (Eq, Show)
  
  parseSourceLang :: Parsec.Parsec String () SourceLang
  parseSourceLang = Parsec.choice
    [ Parsec.string "js" *>  pure JS
    , Parsec.char 'c' *> Parsec.choice
        [ Parsec.string "mm" *> pure Cmm
        , Parsec.string "pp" *> pure Cxx
        , pure C
        ]
    , Parsec.char 's' *> pure Asm
    ]
  
  type Basename = String
  
  parseBasename :: Parsec.Parsec String () Basename
  parseBasename = Parsec.manyTill Parsec.anyChar (Parsec.try $ Parsec.char '.')
  
  -- | > <c|cmm|s>/<file>.<way prefix>_o
  data NonHsObject = NonHsObject SourceLang Basename Way
    deriving (Eq, Show)
  
  parseNonHsObject :: Parsec.Parsec String () NonHsObject
  parseNonHsObject = do
      lang <- parseSourceLang
      _ <- Parsec.char '/'
      file <- parseBasename
      way <- parseWayPrefix vanilla
      _ <- Parsec.char 'o'
      return (NonHsObject lang file way)
  
  -- | > <o|hi|o-boot|hi-boot>
  data SuffixType = O | Hi | OBoot | HiBoot deriving (Eq, Show)
  
  parseSuffixType :: Parsec.Parsec String () SuffixType
  parseSuffixType = Parsec.choice
    [ Parsec.char 'o' *> Parsec.choice
        [ Parsec.string "-boot" *> pure OBoot
        , pure O
        ]
    , Parsec.string "hi" *> Parsec.choice
        [ Parsec.string "-boot" *> pure HiBoot
        , pure Hi
        ]
    ]
  
  -- | > <way prefix>_<o|hi|o-boot|hi-boot>
  data Extension = Extension Way SuffixType deriving (Eq, Show)
  
  parseExtension :: Parsec.Parsec String () Extension
  parseExtension = Extension <$> parseWayPrefix vanilla <*> parseSuffixType
  
  -- | > <file>.<way prefix>_<o|hi|o-boot|hi-boot>
  data HsObject = HsObject Basename Extension deriving (Eq, Show)
  
  parseHsObject :: Parsec.Parsec String () HsObject
  parseHsObject = do
      file <- parseBasename
      ext <- parseExtension
      return (HsObject file ext)
  
  data Object = Hs HsObject | NonHs NonHsObject deriving (Eq, Show)
  
  parseObject :: Parsec.Parsec String () Object
  parseObject = Parsec.choice
      [ NonHs <$> parseNonHsObject
      , Hs    <$> parseHsObject ]
  
  -- * Toplevel parsers
  
  parseBuildObject :: FilePath -> Parsec.Parsec String () (BuildPath Object)
  parseBuildObject root = parseBuildPath root parseObject
  
  -- * Getting contexts from objects
  
  objectContext :: BuildPath Object -> Context
  objectContext (BuildPath _ stage pkgPath obj) =
      Context stage (unsafeFindPackageByPath pkgPath) way Inplace
    where
      way = case obj of
          NonHs (NonHsObject _lang _file w)         -> w
          Hs    (HsObject _file (Extension w _suf)) -> w
  
  -- * Building an object
  
  compileHsObjectAndHi
      :: [(Resource, Int)] -> FilePath -> Action ()
  compileHsObjectAndHi rs objpath = do
    root <- buildRoot
    b@(BuildPath _root stage _path _o)
      <- parsePath (parseBuildObject root) "<object file path parser>" objpath
    let ctx = objectContext b
        way = C.way ctx
    ctxPath <- contextPath ctx
    (src, deps) <- lookupDependencies (ctxPath -/- ".dependencies") objpath
    need (src:deps)
    -- The .conf file is needed when template-haskell is implicitly added as a dependency
    -- when a module in the template-haskell package is compiled. (See #24737)
    when  (isLibrary (C.package ctx)) (need . (:[]) =<< pkgConfFile ctx)
  
    -- The .dependencies file lists indicating inputs. ghc will
    -- generally read more *.hi and *.hi-boot files (direct inputs).
    -- Allow such reads (see https://gitlab.haskell.org/ghc/ghc/wikis/Developing-Hadrian#haskell-object-files-and-hi-inputs)
    -- Note that this may allow too many *.hi and *.hi-boot files, but
    -- calculating the exact set of direct inputs is not feasible.
    trackAllow [ "**/*." ++ hisuf     way
               , "**/*." ++ hibootsuf way
               ]
  
    buildWithResources rs $ target ctx (Ghc CompileHs stage) [src] [objpath]
  
  compileNonHsObject :: [(Resource, Int)] -> SourceLang -> FilePath -> Action ()
  compileNonHsObject rs lang path = do
    root <- buildRoot
    b@(BuildPath _root stage _path _o)
      <- parsePath (parseBuildObject root) "<object file path parser>" path
    let
      ctx = objectContext b
      builder = case lang of
        C -> Ghc CompileCWithGhc
        Cxx-> Ghc CompileCppWithGhc
        _ -> Ghc CompileHs
    src <- case lang of
        Asm -> obj2src "S"   (const False)      ctx path
        C   -> obj2src "c"   (const False)      ctx path
        Cmm -> obj2src "cmm" isGeneratedCmmFile ctx path
        Cxx -> obj2src "cpp" (const False) ctx path
        JS  -> obj2src "js" (const False) ctx path
    need [src]
    needDependencies lang ctx src (path <.> "d")
    buildWithResources rs $ target ctx (builder stage) [src] [path]
  
  -- * Helpers
  
  -- | Discover dependencies of a given source file by iteratively calling @gcc@
  -- in the @-MM -MG@ mode and building generated dependencies if they are missing
  -- until reaching a fixed point.
  needDependencies :: SourceLang -> Context -> FilePath -> FilePath -> Action ()
  needDependencies lang context@Context {..} src depFile = do
      gens <- interpretInContext context generatedDependencies
      need gens
      discover
    where
      discover = do
          build $ target context (Cc (FindCDependencies depType) stage) [src] [depFile]
          deps <- parseFile depFile
          -- Generated dependencies, if not yet built, will not be found and hence
          -- will be referred to simply by their file names.
          let notFound = filter (\file -> file == takeFileName file) deps
          -- We find the full paths to generated dependencies, so we can request
          -- to build them by calling 'need'.
          todo <- catMaybes <$> mapM (fullPathIfGenerated context) notFound
  
          if null todo
          then need deps -- The list of dependencies is final, need all
          else do
              need todo  -- Build newly discovered generated dependencies
              discover   -- Continue the discovery process
  
      -- We need to pass different flags to cc depending on whether the
      -- file to compile is a .c or a .cpp file
      depType = if lang == Cxx then CxxDep else CDep
  
      parseFile :: FilePath -> Action [String]
      parseFile file = do
          input <- liftIO $ readFile file
          case parseMakefile input of
              [(_file, deps)] -> return deps
              _               -> return []
  
  -- | Find a given 'FilePath' in the list of generated files in the given
  -- 'Context' and return its full path.
  fullPathIfGenerated :: Context -> FilePath -> Action (Maybe FilePath)
  fullPathIfGenerated context file = interpretInContext context $ do
      generated <- generatedDependencies
      return $ find ((== file) . takeFileName) generated
  
  obj2src :: String -> (FilePath -> Bool) -> Context -> FilePath -> Action FilePath
  obj2src extension isGenerated context@Context {..} obj
      | isGenerated src = return src
      | otherwise       = (pkgPath package ++) <$> suffix
    where
      src    = obj -<.> extension
      suffix = do
          path <- buildPath context
          return $ fromMaybe ("Cannot determine source for " ++ obj)
                 $ stripPrefix (path -/- extension) src
  