# LANGUAGE BlockArguments #
# LANGUAGE DeriveGeneric #
# LANGUAGE DerivingStrategies #
# LANGUAGE NamedFieldPuns #
{-# LANGUAGE OverloadedStrings #-}
# LANGUAGE RecordWildCards #
# LANGUAGE TupleSections #

module Build (parser, compile, compile', BuildOptions (..)) where

import Control.Exception (tryJust)
import Control.Monad (forM, guard, join, unless, when)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Supply (runSupplyT)
import Data.Aeson as Aeson
  ( FromJSON,
    ToJSON,
    Value (Object, String),
    decodeFileStrict',
  )
import qualified Data.Aeson as A
import Data.Aeson.Types (parseMaybe)
import Data.Bifunctor (first)
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.UTF8 as LBU8
import Data.Either (isLeft, partitionEithers)
import qualified Data.Aeson.KeyMap as Json.Map
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe, maybeToList, fromJust)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Traversable (for)
import GHC.Generics (Generic)
import qualified Language.PureScript as P
import qualified Language.PureScript.CoreFn as CoreFn
import qualified Language.PureScript.CoreFn.FromJSON as CoreFn
import Language.PureScript.Erl.CodeGen (buildCodegenEnvironment)
import Language.PureScript.Erl.Errors as E
  ( Level (Error, Warning),
    MultipleErrors,
    PPEOptions (ppeCodeColor, ppeFull, ppeRelativeDirectory),
    defaultPPEOptions,
    nonEmpty,
    prettyPrintMultipleErrors,
    prettyPrintMultipleWarnings,
  )
import Language.PureScript.Erl.Errors.JSON
  ( JSONResult (JSONResult),
    toJSONErrors,
  )
import qualified Language.PureScript.Erl.Make as Make
import qualified Language.PureScript.Erl.Make.Monad as MM
import Language.PureScript.Erl.Run (runProgram)
import qualified Language.PureScript.Make.Cache as Cache
import qualified Options.Applicative as Opts
import Protolude (hush, intercalate, (&))
import qualified System.Console.ANSI as ANSI
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath (joinPath, replaceExtension, replaceFileName)
import qualified System.FilePath as FP
import System.FilePath.Glob (glob)
import System.IO (hPutStr, hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError)
import Prelude

data BuildOptions = BuildOptions
  { buildOutputDir :: FilePath,
    buildRun :: Maybe String,
    buildQuiet :: Bool,
    buildChecked :: Bool
  }

data ModResult = ModResult
  { moduleName :: P.ModuleName,
    modulePath :: FilePath,
    coreFn :: Maybe Value,
    foreignFile :: Maybe FilePath,
    externs :: MM.Make (Maybe P.ExternsFile),
    -- , inputTimestamp :: UTCTime
    newCacheInfo :: Map FilePath (UTCTime, MM.Make Cache.ContentHash),
    oldCacheInfo :: Maybe FileCacheInfo
  }

data NoCoreFn
  = FileNoLongerExists FilePath FilePath
  | ParseError FilePath

compile :: BuildOptions -> IO ()
compile opts = do
  _ <- compile' opts
  exitSuccess

compile' :: BuildOptions -> IO (Maybe [CoreFn.Module CoreFn.Ann])
compile' BuildOptions {..} = do
  let coreFnGlob = joinPath [buildOutputDir, "*", "corefn.json"]
      cacheDbFile = joinPath [buildOutputDir, "purerl-cache-db.json"]
  corefnFiles <- globWarningOnMisses warnFileTypeNotFound [coreFnGlob]
  cwd <- liftBase getCurrentDirectory

  when (null corefnFiles) $ do
    hPutStr stderr $
      unlines
        [ "purerl: No input files.",
          "Usage: For basic information, try the `--help' option."
        ]
    exitFailure
  (makeErrors, makeWarnings) <- MM.runMake P.defaultOptions $ do
    cache :: CacheDb <- fromMaybe M.empty <$> MM.readJSONFile cacheDbFile
    modules <- forM corefnFiles $ \corefn -> do
      let extern = replaceFileName corefn "externs.cbor"
          modStr = last $ FP.splitPath $ FP.takeDirectory corefn
          moduleName' = P.ModuleName $ T.pack modStr

      -- Aeson JSON handling is lazy, but if we evaluate the outer Maybe Value we incur the
      -- cost of constructing the big top-level object even if we don't look at it
      res <- readJSONFile corefn
      let readExterns = do
            resExterns <- MM.readExternsFile extern
            case resExterns of
              Just resExterns' -> do
                unless (P.externsIsCurrentVersion resExterns') $
                  liftIO $ hPutStrLn stderr $ "Found externs for wrong compiler version (continuing anyway): " <> extern
                pure $ Just resExterns'
              Nothing -> do
                liftIO $ hPutStrLn stderr $ "Error parsing externs: " <> extern
                pure Nothing

      let fromCorefn = case res of
            Just res' -> do
              let sourceFile = fromJust $ getModulePath res'
              exists <- liftIO $ doesFileExist sourceFile
              if not exists
                then
                  -- TODO We have to care about extraneous stuff in output/ because the set of source modules is implicit
                  -- This could be obviated by spago passing these on command line, in which case we could simply not build these things
                  -- So we assume not building is fine but warn. It's probably OK.
                  pure $ Left $ FileNoLongerExists sourceFile corefn
                else do
                  (foreignFile, newCacheInfo) <- getCacheInfo corefn extern sourceFile
                  pure $ Right $ ModResult moduleName' sourceFile res foreignFile readExterns newCacheInfo Nothing
            Nothing -> do
              liftIO $ hPutStrLn stderr $ "Error parsing corefn: " <> corefn
              pure $ Left $ ParseError corefn
          fromCache =
            M.lookup moduleName' cache & maybe
              (pure Nothing)
              \CacheInfo {sourceFile, cacheInfo = oldCacheInfo} -> do
                do
                  exists <- liftIO $ doesFileExist sourceFile
                  if exists
                    then do
                      (foreignFile, newCacheInfo) <- getCacheInfo corefn extern sourceFile
                      pure $ Just $ ModResult moduleName' sourceFile res foreignFile readExterns newCacheInfo (Just oldCacheInfo)
                    else do
                      pure Nothing
      resCfn <- fromCache
      modRes <- maybe fromCorefn (pure . Right) resCfn

      join <$> for modRes \rr -> do
        (_cacheInfo, nb) <- needsBuild rr
        -- Source path might have changed, just start again as if we didn't find an entry in the cache
  We do n't do this in the first place because it avoids parsing corefn for unchanged files
  ( key point , if the source file moves then the corefn will have changed ) .
        -- While if we're needing to build, that will happen down the line anyway.
        if nb
          then fromCorefn
          else pure $ pure rr

    let (errorModules, modules') = partitionEithers modules

    liftIO do
      let parseErrors = filter (\case (ParseError _) -> True; _ -> False) errorModules
      unless (null parseErrors) do
        hPutStrLn stderr "Exiting due to bad corefn"
        exitFailure
      let movedErrors = mapMaybe (\case (FileNoLongerExists f _) -> Just f; _ -> Nothing) errorModules
      unless (null movedErrors) do
        hPutStrLn stderr $
          "Warning: Some source files no longer exist but those modules externs are present as input (in the output directory):\n\t"
            <> intercalate "\n\t" movedErrors

    let buildActions = Make.buildActions buildOutputDir foreigns True buildChecked
        foreigns = M.fromList $ mapMaybe (\ModResult {moduleName, foreignFile} -> (moduleName,) <$> foreignFile) modules'

  TODO now we are asking  twice
    buildInfo <- traverse (\m -> (m,) <$> needsBuild m) modules'
    let needToBuild = mapMaybe (\(res, (_, ntb)) -> if ntb then Just res else Nothing) buildInfo

    makeRes <- if null needToBuild
      then do
        pure []
      else do
        externsFiles <- traverse externs modules'
        when (any isNothing externsFiles) $ liftIO do
          hPutStrLn stderr "Exiting due to externs error"
          exitFailure

        let env = buildCodegenEnvironment $ foldr P.applyExternsFileToEnvironment P.initEnvironment (catMaybes externsFiles)

        res :: [Either P.ModuleName (CoreFn.Module CoreFn.Ann)] <-
          forM needToBuild \ModResult {moduleName, coreFn} -> do
            unless buildQuiet $
              liftIO $ hPutStrLn stderr $ "Building " <> T.unpack (P.runModuleName moduleName)
            case coreFn of
              Just coreFn'
                | Just (_version, module') <- parseMaybe CoreFn.moduleFromJSON coreFn' -> do
                  _ <- runSupplyT 0 $ Make.codegen buildActions env module'
                  Make.ffiCodegen buildActions module'
                  pure $ Right module'
              _ -> do
                liftIO $ hPutStrLn stderr $ "Error parsing corefn: " <> T.unpack (P.runModuleName moduleName)
                pure $ Left moduleName

        liftIO $ when (any isLeft res) do
          hPutStrLn stderr "Exiting due to corefn error"
          exitFailure

        pure $ catMaybes $ hush <$> res

    let newCache :: CacheDb = M.fromList $ map (\(ModResult {moduleName, modulePath}, (ci, _)) -> (moduleName, CacheInfo (Cache.normaliseForCache cwd modulePath) ci)) buildInfo
    MM.writeJSONFile cacheDbFile newCache

    pure makeRes

  printWarningsAndErrors False False makeWarnings makeErrors

  case buildRun of
    Nothing -> pure ()
    Just runModule -> runProgram $ T.pack runModule

  pure $ either (const Nothing) Just makeErrors
  where
    needsBuild :: ModResult -> MM.Make (FileCacheInfo, Bool)
    needsBuild ModResult {oldCacheInfo, newCacheInfo, moduleName} = do
      -- outputTs <- Make.getOutputTimestamp buildActions mn
      cwd <- liftBase getCurrentDirectory
      let wrapCI = M.singleton moduleName (Cache.CacheInfo $ fromMaybe M.empty oldCacheInfo)
      (cacheInfo, isUpToDate) <- first Cache.unCacheInfo <$> Cache.checkChanged wrapCI moduleName cwd newCacheInfo
      pure (cacheInfo, not isUpToDate)
    printWarningsAndErrors :: forall a. Bool -> Bool -> MultipleErrors -> Either MultipleErrors a -> IO ()
    printWarningsAndErrors verbose False warnings errors = do
      pwd <- getCurrentDirectory
      cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
      let ppeOpts = E.defaultPPEOptions {E.ppeCodeColor = cc, E.ppeFull = verbose, E.ppeRelativeDirectory = pwd}
      when (E.nonEmpty warnings) $
        hPutStrLn stderr (E.prettyPrintMultipleWarnings ppeOpts warnings)
      case errors of
        Left errs -> do
          hPutStrLn stderr (E.prettyPrintMultipleErrors ppeOpts errs)
          exitFailure
        Right _ -> return ()
    printWarningsAndErrors verbose True warnings errors = do
      hPutStrLn stderr . LBU8.toString . A.encode $
        JSONResult
          (toJSONErrors verbose E.Warning warnings)
          (either (toJSONErrors verbose E.Error) (const []) errors)
      either (const exitFailure) (const (return ())) errors

    getModulePath :: Value -> Maybe FilePath
    getModulePath corefn =
      case corefn of
        Object o | Just (String filename) <- Json.Map.lookup "modulePath" o -> Just $ T.unpack filename
        _ -> Nothing

    getCacheInfo :: FilePath -> FilePath -> FilePath -> MM.Make (Maybe FilePath, Map FilePath (UTCTime, MM.Make Cache.ContentHash))
    getCacheInfo corefn extern sourceFile = do
      let getInfo fp = do
            ts <- MM.getTimestamp fp
            pure (ts, MM.hashFile fp)
      foreignFile <- liftIO $ inferForeignModule' sourceFile
      newCacheInfo <- M.fromList <$> traverse (\fp -> (fp,) <$> getInfo fp) (corefn : extern : maybeToList foreignFile)
      pure (foreignFile, newCacheInfo)

    inferForeignModule' :: MonadIO m => FilePath -> m (Maybe FilePath)
    inferForeignModule' path = do
      let jsFile = replaceExtension path "erl"
      exists <- liftIO $ doesFileExist jsFile
      if exists
        then return (Just jsFile)
        else return Nothing

-- | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does
-- not exist or could not be parsed. Errors are captured using the 'MonadError'
-- instance.
readJSONFile :: FilePath -> MM.Make (Maybe Value)
readJSONFile path =
  MM.makeIO ("read JSON file: " <> T.pack path) $ do
    r <- catchDoesNotExist $ Aeson.decodeFileStrict' path
    return $ join r

-- | If the provided action threw an 'isDoesNotExist' error, catch it and
-- return Nothing. Otherwise return Just the result of the inner action.
catchDoesNotExist :: IO a -> IO (Maybe a)
catchDoesNotExist inner = do
  r <- tryJust (guard . isDoesNotExistError) inner
  case r of
    Left () ->
      return Nothing
    Right x ->
      return (Just x)

warnFileTypeNotFound :: String -> IO ()
warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++)

globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
globWarningOnMisses warn = concatMapM globWithWarning
  where
    globWithWarning pattern' = do
      paths <- glob pattern'
      when (null paths) $ warn pattern'
      return paths
    concatMapM f = fmap concat . mapM f

outputDirectory :: Opts.Parser FilePath
outputDirectory =
  Opts.strOption $
    Opts.short 'o'
      <> Opts.long "output"
      <> Opts.value "output"
      <> Opts.showDefault
      <> Opts.help "The output directory"

run :: Opts.Parser (Maybe String)
run =
  Opts.optional $
    Opts.strOption $
      Opts.long "run"
        <> Opts.help "Run the given function"

quiet :: Opts.Parser Bool
quiet =
  Opts.flag False True $
    Opts.short 'q'
      <> Opts.long "quiet"
      <> Opts.help "Print less output"

checked :: Opts.Parser Bool
checked =
  Opts.flag False True $
    Opts.long "checked"
      <> Opts.help "Generate wrapper modules with run-time type-checking of function arguments"

buildOptions :: Opts.Parser BuildOptions
buildOptions =
  BuildOptions <$> outputDirectory
    <*> run
    <*> quiet
    <*> checked

parser :: Opts.Parser (IO ())
parser = compile <$> buildOptions

type CacheDb = Map P.ModuleName CacheInfo

data CacheInfo = CacheInfo
  { sourceFile :: FilePath,
    cacheInfo :: FileCacheInfo
  }
  deriving (Generic, Show)

instance ToJSON CacheInfo

instance FromJSON CacheInfo

type FileCacheInfo = Map FilePath (UTCTime, Cache.ContentHash)
# LANGUAGE OverloadedStrings #
 , inputTimestamp :: UTCTime
 Aeson JSON handling is lazy, but if we evaluate the outer Maybe Value we incur the
 cost of constructing the big top-level object even if we don't look at it
 TODO We have to care about extraneous stuff in output/ because the set of source modules is implicit
 This could be obviated by spago passing these on command line, in which case we could simply not build these things
 So we assume not building is fine but warn. It's probably OK.
 Source path might have changed, just start again as if we didn't find an entry in the cache
 While if we're needing to build, that will happen down the line anyway.
 outputTs <- Make.getOutputTimestamp buildActions mn
 | Read a JSON file in the 'Make' monad, returning 'Nothing' if the file does
 not exist or could not be parsed. Errors are captured using the 'MonadError'
 instance.
 | If the provided action threw an 'isDoesNotExist' error, catch it and
 return Nothing. Otherwise return Just the result of the inner action.
# LANGUAGE BlockArguments #
# LANGUAGE DeriveGeneric #
# LANGUAGE DerivingStrategies #
# LANGUAGE NamedFieldPuns #
# LANGUAGE RecordWildCards #
# LANGUAGE TupleSections #

module Build (parser, compile, compile', BuildOptions (..)) where

import Control.Exception (tryJust)
import Control.Monad (forM, guard, join, unless, when)
import Control.Monad.Base (MonadBase (liftBase))
import Control.Monad.IO.Class (MonadIO (..))
import Control.Monad.Supply (runSupplyT)
import Data.Aeson as Aeson
  ( FromJSON,
    ToJSON,
    Value (Object, String),
    decodeFileStrict',
  )
import qualified Data.Aeson as A
import Data.Aeson.Types (parseMaybe)
import Data.Bifunctor (first)
import Data.Bool (bool)
import qualified Data.ByteString.Lazy.UTF8 as LBU8
import Data.Either (isLeft, partitionEithers)
import qualified Data.Aeson.KeyMap as Json.Map
import Data.Map (Map)
import qualified Data.Map as M
import Data.Maybe (catMaybes, fromMaybe, isNothing, mapMaybe, maybeToList, fromJust)
import qualified Data.Text as T
import Data.Time.Clock (UTCTime)
import Data.Traversable (for)
import GHC.Generics (Generic)
import qualified Language.PureScript as P
import qualified Language.PureScript.CoreFn as CoreFn
import qualified Language.PureScript.CoreFn.FromJSON as CoreFn
import Language.PureScript.Erl.CodeGen (buildCodegenEnvironment)
import Language.PureScript.Erl.Errors as E
  ( Level (Error, Warning),
    MultipleErrors,
    PPEOptions (ppeCodeColor, ppeFull, ppeRelativeDirectory),
    defaultPPEOptions,
    nonEmpty,
    prettyPrintMultipleErrors,
    prettyPrintMultipleWarnings,
  )
import Language.PureScript.Erl.Errors.JSON
  ( JSONResult (JSONResult),
    toJSONErrors,
  )
import qualified Language.PureScript.Erl.Make as Make
import qualified Language.PureScript.Erl.Make.Monad as MM
import Language.PureScript.Erl.Run (runProgram)
import qualified Language.PureScript.Make.Cache as Cache
import qualified Options.Applicative as Opts
import Protolude (hush, intercalate, (&))
import qualified System.Console.ANSI as ANSI
import System.Directory (doesFileExist, getCurrentDirectory)
import System.Exit (exitFailure, exitSuccess)
import System.FilePath (joinPath, replaceExtension, replaceFileName)
import qualified System.FilePath as FP
import System.FilePath.Glob (glob)
import System.IO (hPutStr, hPutStrLn, stderr)
import System.IO.Error (isDoesNotExistError)
import Prelude

data BuildOptions = BuildOptions
  { buildOutputDir :: FilePath,
    buildRun :: Maybe String,
    buildQuiet :: Bool,
    buildChecked :: Bool
  }

data ModResult = ModResult
  { moduleName :: P.ModuleName,
    modulePath :: FilePath,
    coreFn :: Maybe Value,
    foreignFile :: Maybe FilePath,
    externs :: MM.Make (Maybe P.ExternsFile),
    newCacheInfo :: Map FilePath (UTCTime, MM.Make Cache.ContentHash),
    oldCacheInfo :: Maybe FileCacheInfo
  }

data NoCoreFn
  = FileNoLongerExists FilePath FilePath
  | ParseError FilePath

compile :: BuildOptions -> IO ()
compile opts = do
  _ <- compile' opts
  exitSuccess

compile' :: BuildOptions -> IO (Maybe [CoreFn.Module CoreFn.Ann])
compile' BuildOptions {..} = do
  let coreFnGlob = joinPath [buildOutputDir, "*", "corefn.json"]
      cacheDbFile = joinPath [buildOutputDir, "purerl-cache-db.json"]
  corefnFiles <- globWarningOnMisses warnFileTypeNotFound [coreFnGlob]
  cwd <- liftBase getCurrentDirectory

  when (null corefnFiles) $ do
    hPutStr stderr $
      unlines
        [ "purerl: No input files.",
          "Usage: For basic information, try the `--help' option."
        ]
    exitFailure
  (makeErrors, makeWarnings) <- MM.runMake P.defaultOptions $ do
    cache :: CacheDb <- fromMaybe M.empty <$> MM.readJSONFile cacheDbFile
    modules <- forM corefnFiles $ \corefn -> do
      let extern = replaceFileName corefn "externs.cbor"
          modStr = last $ FP.splitPath $ FP.takeDirectory corefn
          moduleName' = P.ModuleName $ T.pack modStr

      res <- readJSONFile corefn
      let readExterns = do
            resExterns <- MM.readExternsFile extern
            case resExterns of
              Just resExterns' -> do
                unless (P.externsIsCurrentVersion resExterns') $
                  liftIO $ hPutStrLn stderr $ "Found externs for wrong compiler version (continuing anyway): " <> extern
                pure $ Just resExterns'
              Nothing -> do
                liftIO $ hPutStrLn stderr $ "Error parsing externs: " <> extern
                pure Nothing

      let fromCorefn = case res of
            Just res' -> do
              let sourceFile = fromJust $ getModulePath res'
              exists <- liftIO $ doesFileExist sourceFile
              if not exists
                then
                  pure $ Left $ FileNoLongerExists sourceFile corefn
                else do
                  (foreignFile, newCacheInfo) <- getCacheInfo corefn extern sourceFile
                  pure $ Right $ ModResult moduleName' sourceFile res foreignFile readExterns newCacheInfo Nothing
            Nothing -> do
              liftIO $ hPutStrLn stderr $ "Error parsing corefn: " <> corefn
              pure $ Left $ ParseError corefn
          fromCache =
            M.lookup moduleName' cache & maybe
              (pure Nothing)
              \CacheInfo {sourceFile, cacheInfo = oldCacheInfo} -> do
                do
                  exists <- liftIO $ doesFileExist sourceFile
                  if exists
                    then do
                      (foreignFile, newCacheInfo) <- getCacheInfo corefn extern sourceFile
                      pure $ Just $ ModResult moduleName' sourceFile res foreignFile readExterns newCacheInfo (Just oldCacheInfo)
                    else do
                      pure Nothing
      resCfn <- fromCache
      modRes <- maybe fromCorefn (pure . Right) resCfn

      join <$> for modRes \rr -> do
        (_cacheInfo, nb) <- needsBuild rr
  We do n't do this in the first place because it avoids parsing corefn for unchanged files
  ( key point , if the source file moves then the corefn will have changed ) .
        if nb
          then fromCorefn
          else pure $ pure rr

    let (errorModules, modules') = partitionEithers modules

    liftIO do
      let parseErrors = filter (\case (ParseError _) -> True; _ -> False) errorModules
      unless (null parseErrors) do
        hPutStrLn stderr "Exiting due to bad corefn"
        exitFailure
      let movedErrors = mapMaybe (\case (FileNoLongerExists f _) -> Just f; _ -> Nothing) errorModules
      unless (null movedErrors) do
        hPutStrLn stderr $
          "Warning: Some source files no longer exist but those modules externs are present as input (in the output directory):\n\t"
            <> intercalate "\n\t" movedErrors

    let buildActions = Make.buildActions buildOutputDir foreigns True buildChecked
        foreigns = M.fromList $ mapMaybe (\ModResult {moduleName, foreignFile} -> (moduleName,) <$> foreignFile) modules'

  TODO now we are asking  twice
    buildInfo <- traverse (\m -> (m,) <$> needsBuild m) modules'
    let needToBuild = mapMaybe (\(res, (_, ntb)) -> if ntb then Just res else Nothing) buildInfo

    makeRes <- if null needToBuild
      then do
        pure []
      else do
        externsFiles <- traverse externs modules'
        when (any isNothing externsFiles) $ liftIO do
          hPutStrLn stderr "Exiting due to externs error"
          exitFailure

        let env = buildCodegenEnvironment $ foldr P.applyExternsFileToEnvironment P.initEnvironment (catMaybes externsFiles)

        res :: [Either P.ModuleName (CoreFn.Module CoreFn.Ann)] <-
          forM needToBuild \ModResult {moduleName, coreFn} -> do
            unless buildQuiet $
              liftIO $ hPutStrLn stderr $ "Building " <> T.unpack (P.runModuleName moduleName)
            case coreFn of
              Just coreFn'
                | Just (_version, module') <- parseMaybe CoreFn.moduleFromJSON coreFn' -> do
                  _ <- runSupplyT 0 $ Make.codegen buildActions env module'
                  Make.ffiCodegen buildActions module'
                  pure $ Right module'
              _ -> do
                liftIO $ hPutStrLn stderr $ "Error parsing corefn: " <> T.unpack (P.runModuleName moduleName)
                pure $ Left moduleName

        liftIO $ when (any isLeft res) do
          hPutStrLn stderr "Exiting due to corefn error"
          exitFailure

        pure $ catMaybes $ hush <$> res

    let newCache :: CacheDb = M.fromList $ map (\(ModResult {moduleName, modulePath}, (ci, _)) -> (moduleName, CacheInfo (Cache.normaliseForCache cwd modulePath) ci)) buildInfo
    MM.writeJSONFile cacheDbFile newCache

    pure makeRes

  printWarningsAndErrors False False makeWarnings makeErrors

  case buildRun of
    Nothing -> pure ()
    Just runModule -> runProgram $ T.pack runModule

  pure $ either (const Nothing) Just makeErrors
  where
    needsBuild :: ModResult -> MM.Make (FileCacheInfo, Bool)
    needsBuild ModResult {oldCacheInfo, newCacheInfo, moduleName} = do
      cwd <- liftBase getCurrentDirectory
      let wrapCI = M.singleton moduleName (Cache.CacheInfo $ fromMaybe M.empty oldCacheInfo)
      (cacheInfo, isUpToDate) <- first Cache.unCacheInfo <$> Cache.checkChanged wrapCI moduleName cwd newCacheInfo
      pure (cacheInfo, not isUpToDate)
    printWarningsAndErrors :: forall a. Bool -> Bool -> MultipleErrors -> Either MultipleErrors a -> IO ()
    printWarningsAndErrors verbose False warnings errors = do
      pwd <- getCurrentDirectory
      cc <- bool Nothing (Just P.defaultCodeColor) <$> ANSI.hSupportsANSI stderr
      let ppeOpts = E.defaultPPEOptions {E.ppeCodeColor = cc, E.ppeFull = verbose, E.ppeRelativeDirectory = pwd}
      when (E.nonEmpty warnings) $
        hPutStrLn stderr (E.prettyPrintMultipleWarnings ppeOpts warnings)
      case errors of
        Left errs -> do
          hPutStrLn stderr (E.prettyPrintMultipleErrors ppeOpts errs)
          exitFailure
        Right _ -> return ()
    printWarningsAndErrors verbose True warnings errors = do
      hPutStrLn stderr . LBU8.toString . A.encode $
        JSONResult
          (toJSONErrors verbose E.Warning warnings)
          (either (toJSONErrors verbose E.Error) (const []) errors)
      either (const exitFailure) (const (return ())) errors

    getModulePath :: Value -> Maybe FilePath
    getModulePath corefn =
      case corefn of
        Object o | Just (String filename) <- Json.Map.lookup "modulePath" o -> Just $ T.unpack filename
        _ -> Nothing

    getCacheInfo :: FilePath -> FilePath -> FilePath -> MM.Make (Maybe FilePath, Map FilePath (UTCTime, MM.Make Cache.ContentHash))
    getCacheInfo corefn extern sourceFile = do
      let getInfo fp = do
            ts <- MM.getTimestamp fp
            pure (ts, MM.hashFile fp)
      foreignFile <- liftIO $ inferForeignModule' sourceFile
      newCacheInfo <- M.fromList <$> traverse (\fp -> (fp,) <$> getInfo fp) (corefn : extern : maybeToList foreignFile)
      pure (foreignFile, newCacheInfo)

    inferForeignModule' :: MonadIO m => FilePath -> m (Maybe FilePath)
    inferForeignModule' path = do
      let jsFile = replaceExtension path "erl"
      exists <- liftIO $ doesFileExist jsFile
      if exists
        then return (Just jsFile)
        else return Nothing

readJSONFile :: FilePath -> MM.Make (Maybe Value)
readJSONFile path =
  MM.makeIO ("read JSON file: " <> T.pack path) $ do
    r <- catchDoesNotExist $ Aeson.decodeFileStrict' path
    return $ join r

catchDoesNotExist :: IO a -> IO (Maybe a)
catchDoesNotExist inner = do
  r <- tryJust (guard . isDoesNotExistError) inner
  case r of
    Left () ->
      return Nothing
    Right x ->
      return (Just x)

warnFileTypeNotFound :: String -> IO ()
warnFileTypeNotFound = hPutStrLn stderr . ("purs compile: No files found using pattern: " ++)

globWarningOnMisses :: (String -> IO ()) -> [FilePath] -> IO [FilePath]
globWarningOnMisses warn = concatMapM globWithWarning
  where
    globWithWarning pattern' = do
      paths <- glob pattern'
      when (null paths) $ warn pattern'
      return paths
    concatMapM f = fmap concat . mapM f

outputDirectory :: Opts.Parser FilePath
outputDirectory =
  Opts.strOption $
    Opts.short 'o'
      <> Opts.long "output"
      <> Opts.value "output"
      <> Opts.showDefault
      <> Opts.help "The output directory"

run :: Opts.Parser (Maybe String)
run =
  Opts.optional $
    Opts.strOption $
      Opts.long "run"
        <> Opts.help "Run the given function"

quiet :: Opts.Parser Bool
quiet =
  Opts.flag False True $
    Opts.short 'q'
      <> Opts.long "quiet"
      <> Opts.help "Print less output"

checked :: Opts.Parser Bool
checked =
  Opts.flag False True $
    Opts.long "checked"
      <> Opts.help "Generate wrapper modules with run-time type-checking of function arguments"

buildOptions :: Opts.Parser BuildOptions
buildOptions =
  BuildOptions <$> outputDirectory
    <*> run
    <*> quiet
    <*> checked

parser :: Opts.Parser (IO ())
parser = compile <$> buildOptions

type CacheDb = Map P.ModuleName CacheInfo

data CacheInfo = CacheInfo
  { sourceFile :: FilePath,
    cacheInfo :: FileCacheInfo
  }
  deriving (Generic, Show)

instance ToJSON CacheInfo

instance FromJSON CacheInfo

type FileCacheInfo = Map FilePath (UTCTime, Cache.ContentHash)