content: {-# OPTIONS_GHC -Wno-unused-do-bind #-}
  {-# LANGUAGE BangPatterns, GADTs, OverloadedStrings #-}
  module Build
    ( fromExposed
    , fromPaths
    , fromRepl
    , Artifacts(..)
    , Root(..)
    , Module(..)
    , CachedInterface(..)
    , ReplArtifacts(..)
    , DocsGoal(..)
    , getRootNames
    )
    where
  
  
  import Control.Concurrent (forkIO)
  import Control.Concurrent.MVar
  import Control.Monad (filterM, mapM_, sequence_)
  import qualified Data.ByteString as B
  import qualified Data.Char as Char
  import qualified Data.Graph as Graph
  import qualified Data.List as List
  import qualified Data.Map.Utils as Map
  import qualified Data.Map.Strict as Map
  import Data.Map.Strict ((!))
  import qualified Data.Maybe as Maybe
  import qualified Data.Name as Name
  import qualified Data.NonEmptyList as NE
  import qualified Data.OneOrMore as OneOrMore
  import qualified Data.Set as Set
  import qualified System.Directory as Dir
  import qualified System.FilePath as FP
  import System.FilePath ((</>), (<.>))
  
  import qualified AST.Canonical as Can
  import qualified AST.Source as Src
  import qualified AST.Optimized as Opt
  import qualified Compile
  import qualified Elm.Details as Details
  import qualified Elm.Docs as Docs
  import qualified Elm.Interface as I
  import qualified Elm.ModuleName as ModuleName
  import qualified Elm.Outline as Outline
  import qualified Elm.Package as Pkg
  import qualified File
  import qualified Json.Encode as E
  import qualified Parse.Module as Parse
  import qualified Reporting
  import qualified Reporting.Annotation as A
  import qualified Reporting.Error as Error
  import qualified Reporting.Error.Docs as EDocs
  import qualified Reporting.Error.Syntax as Syntax
  import qualified Reporting.Error.Import as Import
  import qualified Reporting.Exit as Exit
  import qualified Reporting.Render.Type.Localizer as L
  import qualified Stuff
  
  
  
  -- ENVIRONMENT
  
  
  data Env =
    Env
      { _key :: Reporting.BKey
      , _root :: FilePath
      , _project :: Parse.ProjectType
      , _srcDirs :: [AbsoluteSrcDir]
      , _buildID :: Details.BuildID
      , _locals :: Map.Map ModuleName.Raw Details.Local
      , _foreigns :: Map.Map ModuleName.Raw Details.Foreign
      }
  
  
  makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
  makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
    case validOutline of
      Details.ValidApp givenSrcDirs ->
        do  srcDirs <- traverse (toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
            return $ Env key root Parse.Application srcDirs buildID locals foreigns
  
      Details.ValidPkg pkg _ _ ->
        do  srcDir <- toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
            return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
  
  
  
  -- SOURCE DIRECTORY
  
  
  newtype AbsoluteSrcDir =
    AbsoluteSrcDir FilePath
  
  
  toAbsoluteSrcDir :: FilePath -> Outline.SrcDir -> IO AbsoluteSrcDir
  toAbsoluteSrcDir root srcDir =
    AbsoluteSrcDir <$> Dir.canonicalizePath
      (
        case srcDir of
          Outline.AbsoluteSrcDir dir -> dir
          Outline.RelativeSrcDir dir -> root </> dir
      )
  
  
  addRelative :: AbsoluteSrcDir -> FilePath -> FilePath
  addRelative (AbsoluteSrcDir srcDir) path =
    srcDir </> path
  
  
  
  -- FORK
  
  
  -- PERF try using IORef semephore on file crawl phase?
  -- described in Chapter 13 of Parallel and Concurrent Programming in Haskell by Simon Marlow
  -- https://www.oreilly.com/library/view/parallel-and-concurrent/9781449335939/ch13.html#sec_conc-par-overhead
  --
  fork :: IO a -> IO (MVar a)
  fork work =
    do  mvar <- newEmptyMVar
        _ <- forkIO $ putMVar mvar =<< work
        return mvar
  
  
  {-# INLINE forkWithKey #-}
  forkWithKey :: (k -> a -> IO b) -> Map.Map k a -> IO (Map.Map k (MVar b))
  forkWithKey func dict =
    Map.traverseWithKey (\k v -> fork (func k v)) dict
  
  
  
  -- FROM EXPOSED
  
  
  fromExposed :: Reporting.Style -> FilePath -> Details.Details -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
  fromExposed style root details docsGoal exposed@(NE.List e es) =
    Reporting.trackBuild style $ \key ->
    do  env <- makeEnv key root details
        dmvar <- Details.loadInterfaces root details
  
        -- crawl
        mvar <- newEmptyMVar
        let docsNeed = toDocsNeed docsGoal
        roots <- Map.fromKeysA (fork . crawlModule env mvar docsNeed) (e:es)
        putMVar mvar roots
        mapM_ readMVar roots
        statuses <- traverse readMVar =<< readMVar mvar
  
        -- compile
        midpoint <- checkMidpoint dmvar statuses
        case midpoint of
          Left problem ->
            return (Left (Exit.BuildProjectProblem problem))
  
          Right foreigns ->
            do  rmvar <- newEmptyMVar
                resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
                putMVar rmvar resultMVars
                results <- traverse readMVar resultMVars
                writeDetails root details results
                finalizeExposed root docsGoal exposed results
  
  
  
  -- FROM PATHS
  
  
  data Artifacts =
    Artifacts
      { _name :: Pkg.Name
      , _deps :: Dependencies
      , _roots :: NE.List Root
      , _modules :: [Module]
      }
  
  
  data Module
    = Fresh ModuleName.Raw I.Interface Opt.LocalGraph
    | Cached ModuleName.Raw Bool (MVar CachedInterface)
  
  
  type Dependencies =
    Map.Map ModuleName.Canonical I.DependencyInterface
  
  
  fromPaths :: Reporting.Style -> FilePath -> Details.Details -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
  fromPaths style root details paths =
    Reporting.trackBuild style $ \key ->
    do  env <- makeEnv key root details
  
        elroots <- findRoots env paths
        case elroots of
          Left problem ->
            return (Left (Exit.BuildProjectProblem problem))
  
          Right lroots ->
            do  -- crawl
                dmvar <- Details.loadInterfaces root details
                smvar <- newMVar Map.empty
                srootMVars <- traverse (fork . crawlRoot env smvar) lroots
                sroots <- traverse readMVar srootMVars
                statuses <- traverse readMVar =<< readMVar smvar
  
                midpoint <- checkMidpointAndRoots dmvar statuses sroots
                case midpoint of
                  Left problem ->
                    return (Left (Exit.BuildProjectProblem problem))
  
                  Right foreigns ->
                    do  -- compile
                        rmvar <- newEmptyMVar
                        resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
                        putMVar rmvar resultsMVars
                        rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
                        results <- traverse readMVar resultsMVars
                        writeDetails root details results
                        toArtifacts env foreigns results <$> traverse readMVar rrootMVars
  
  
  
  -- GET ROOT NAMES
  
  
  getRootNames :: Artifacts -> NE.List ModuleName.Raw
  getRootNames (Artifacts _ _ roots _) =
    fmap getRootName roots
  
  
  getRootName :: Root -> ModuleName.Raw
  getRootName root =
    case root of
      Inside  name     -> name
      Outside name _ _ -> name
  
  
  
  -- CRAWL
  
  
  type StatusDict =
    Map.Map ModuleName.Raw (MVar Status)
  
  
  data Status
    = SCached Details.Local
    | SChanged Details.Local B.ByteString Src.Module DocsNeed
    | SBadImport Import.Problem
    | SBadSyntax FilePath File.Time B.ByteString Syntax.Error
    | SForeign Pkg.Name
    | SKernel
  
  
  crawlDeps :: Env -> MVar StatusDict -> [ModuleName.Raw] -> a -> IO a
  crawlDeps env mvar deps blockedValue =
    do  statusDict <- takeMVar mvar
        let depsDict = Map.fromKeys (\_ -> ()) deps
        let newsDict = Map.difference depsDict statusDict
        statuses <- Map.traverseWithKey crawlNew newsDict
        putMVar mvar (Map.union statuses statusDict)
        mapM_ readMVar statuses
        return blockedValue
    where
      crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
  
  
  crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
  crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar docsNeed name =
    do  let fileName = ModuleName.toFilePath name <.> "elm"
  
        paths <- filterM File.exists (map (`addRelative` fileName) srcDirs)
  
        case paths of
          [path] ->
            case Map.lookup name foreigns of
              Just (Details.Foreign dep deps) ->
                return $ SBadImport $ Import.Ambiguous path [] dep deps
  
              Nothing ->
                do  newTime <- File.getTime path
                    case Map.lookup name locals of
                      Nothing ->
                        crawlFile env mvar docsNeed name path newTime buildID
  
                      Just local@(Details.Local oldPath oldTime deps _ lastChange _) ->
                        if path /= oldPath || oldTime /= newTime || needsDocs docsNeed
                        then crawlFile env mvar docsNeed name path newTime lastChange
                        else crawlDeps env mvar deps (SCached local)
  
          p1:p2:ps ->
            return $ SBadImport $ Import.AmbiguousLocal (FP.makeRelative root p1) (FP.makeRelative root p2) (map (FP.makeRelative root) ps)
  
          [] ->
            case Map.lookup name foreigns of
              Just (Details.Foreign dep deps) ->
                case deps of
                  [] ->
                    return $ SForeign dep
  
                  d:ds ->
                    return $ SBadImport $ Import.AmbiguousForeign dep d ds
  
              Nothing ->
                if Name.isKernel name && Parse.isKernel projectType then
                  do  exists <- File.exists ("src" </> ModuleName.toFilePath name <.> "js")
                      return $ if exists then SKernel else SBadImport Import.NotFound
                else
                  return $ SBadImport Import.NotFound
  
  
  crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
  crawlFile env@(Env _ root projectType _ buildID _ _) mvar docsNeed expectedName path time lastChange =
    do  source <- File.readUtf8 (root </> path)
  
        case Parse.fromByteString projectType source of
          Left err ->
            return $ SBadSyntax path time source err
  
          Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _) ->
            case maybeActualName of
              Nothing ->
                return $ SBadSyntax path time source (Syntax.ModuleNameUnspecified expectedName)
  
              Just name@(A.At _ actualName) ->
                if expectedName == actualName then
                  let
                    deps = map Src.getImportName imports
                    local = Details.Local path time deps (any isMain values) lastChange buildID
                  in
                  crawlDeps env mvar deps (SChanged local source modul docsNeed)
                else
                  return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
  
  
  isMain :: A.Located Src.Value -> Bool
  isMain (A.At _ (Src.Value (A.At _ name) _ _ _)) =
    name == Name._main
  
  
  
  -- CHECK MODULE
  
  
  type ResultDict =
    Map.Map ModuleName.Raw (MVar Result)
  
  
  data Result
    = RNew !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
    | RSame !Details.Local !I.Interface !Opt.LocalGraph !(Maybe Docs.Module)
    | RCached Bool Details.BuildID (MVar CachedInterface)
    | RNotFound Import.Problem
    | RProblem Error.Module
    | RBlocked
    | RForeign I.Interface
    | RKernel
  
  
  data CachedInterface
    = Unneeded
    | Loaded I.Interface
    | Corrupted
  
  
  checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
  checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
    case status of
      SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
        do  results <- readMVar resultsMVar
            depsStatus <- checkDeps root results deps lastCompile
            case depsStatus of
              DepsChange ifaces ->
                do  source <- File.readUtf8 path
                    case Parse.fromByteString projectType source of
                      Right modul -> compile env (DocsNeed False) local source ifaces modul
                      Left err ->
                        return $ RProblem $
                          Error.Module name path time source (Error.BadSyntax err)
  
              DepsSame _ _ ->
                do  mvar <- newMVar Unneeded
                    return (RCached hasMain lastChange mvar)
  
              DepsBlock ->
                return RBlocked
  
              DepsNotFound problems ->
                do  source <- File.readUtf8 path
                    return $ RProblem $ Error.Module name path time source $
                      case Parse.fromByteString projectType source of
                        Right (Src.Module _ _ _ imports _ _ _ _ _) ->
                           Error.BadImports (toImportErrors env results imports problems)
  
                        Left err ->
                          Error.BadSyntax err
  
      SChanged local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) docsNeed ->
        do  results <- readMVar resultsMVar
            depsStatus <- checkDeps root results deps lastCompile
            case depsStatus of
              DepsChange ifaces ->
                compile env docsNeed local source ifaces modul
  
              DepsSame same cached ->
                do  maybeLoaded <- loadInterfaces root same cached
                    case maybeLoaded of
                      Nothing     -> return RBlocked
                      Just ifaces -> compile env docsNeed local source ifaces modul
  
              DepsBlock ->
                return RBlocked
  
              DepsNotFound problems ->
                return $ RProblem $ Error.Module name path time source $
                  Error.BadImports (toImportErrors env results imports problems)
  
      SBadImport importProblem ->
        return (RNotFound importProblem)
  
      SBadSyntax path time source err ->
        return $ RProblem $ Error.Module name path time source $
          Error.BadSyntax err
  
      SForeign home ->
        case foreigns ! ModuleName.Canonical home name of
          I.Public iface -> return (RForeign iface)
          I.Private _ _ _ -> error $ "mistakenly seeing private interface for " ++ Pkg.toChars home ++ " " ++ ModuleName.toChars name
  
      SKernel ->
        return RKernel
  
  
  
  -- CHECK DEPS
  
  
  data DepsStatus
    = DepsChange (Map.Map ModuleName.Raw I.Interface)
    | DepsSame [Dep] [CDep]
    | DepsBlock
    | DepsNotFound (NE.List (ModuleName.Raw, Import.Problem))
  
  
  checkDeps :: FilePath -> ResultDict -> [ModuleName.Raw] -> Details.BuildID -> IO DepsStatus
  checkDeps root results deps lastCompile =
    checkDepsHelp root results deps [] [] [] [] False 0 lastCompile
  
  
  type Dep = (ModuleName.Raw, I.Interface)
  type CDep = (ModuleName.Raw, MVar CachedInterface)
  
  
  checkDepsHelp :: FilePath -> ResultDict -> [ModuleName.Raw] -> [Dep] -> [Dep] -> [CDep] -> [(ModuleName.Raw,Import.Problem)] -> Bool -> Details.BuildID -> Details.BuildID -> IO DepsStatus
  checkDepsHelp root results deps new same cached importProblems isBlocked lastDepChange lastCompile =
    case deps of
      dep:otherDeps ->
        do  result <- readMVar (results ! dep)
            case result of
              RNew (Details.Local _ _ _ _ lastChange _) iface _ _ ->
                checkDepsHelp root results otherDeps ((dep,iface) : new) same cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
  
              RSame (Details.Local _ _ _ _ lastChange _) iface _ _ ->
                checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked (max lastChange lastDepChange) lastCompile
  
              RCached _ lastChange mvar ->
                checkDepsHelp root results otherDeps new same ((dep,mvar) : cached) importProblems isBlocked (max lastChange lastDepChange) lastCompile
  
              RNotFound prob ->
                checkDepsHelp root results otherDeps new same cached ((dep,prob) : importProblems) True lastDepChange lastCompile
  
              RProblem _ ->
                checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
  
              RBlocked ->
                checkDepsHelp root results otherDeps new same cached importProblems True lastDepChange lastCompile
  
              RForeign iface ->
                checkDepsHelp root results otherDeps new ((dep,iface) : same) cached importProblems isBlocked lastDepChange lastCompile
  
              RKernel ->
                checkDepsHelp root results otherDeps new same cached importProblems isBlocked lastDepChange lastCompile
  
  
      [] ->
        case reverse importProblems of
          p:ps ->
            return $ DepsNotFound (NE.List p ps)
  
          [] ->
            if isBlocked then
              return $ DepsBlock
  
            else if null new && lastDepChange <= lastCompile then
              return $ DepsSame same cached
  
            else
              do  maybeLoaded <- loadInterfaces root same cached
                  case maybeLoaded of
                    Nothing     -> return DepsBlock
                    Just ifaces -> return $ DepsChange $ Map.union (Map.fromList new) ifaces
  
  
  
  -- TO IMPORT ERROR
  
  
  toImportErrors :: Env -> ResultDict -> [Src.Import] -> NE.List (ModuleName.Raw, Import.Problem) -> NE.List Import.Error
  toImportErrors (Env _ _ _ _ _ locals foreigns) results imports problems =
    let
      knownModules =
        Set.unions
          [ Map.keysSet foreigns
          , Map.keysSet locals
          , Map.keysSet results
          ]
  
      unimportedModules =
        Set.difference knownModules (Set.fromList (map Src.getImportName imports))
  
      regionDict =
        Map.fromList (map (\(Src.Import (A.At region name) _ _) -> (name, region)) imports)
  
      toError (name, problem) =
        Import.Error (regionDict ! name) name unimportedModules problem
    in
    fmap toError problems
  
  
  
  -- LOAD CACHED INTERFACES
  
  
  loadInterfaces :: FilePath -> [Dep] -> [CDep] -> IO (Maybe (Map.Map ModuleName.Raw I.Interface))
  loadInterfaces root same cached =
    do  loading <- traverse (fork . loadInterface root) cached
        maybeLoaded <- traverse readMVar loading
        case sequence maybeLoaded of
          Nothing ->
            return Nothing
  
          Just loaded ->
            return $ Just $ Map.union (Map.fromList loaded) (Map.fromList same)
  
  
  loadInterface :: FilePath -> CDep -> IO (Maybe Dep)
  loadInterface root (name, ciMvar) =
    do  cachedInterface <- takeMVar ciMvar
        case cachedInterface of
          Corrupted ->
            do  putMVar ciMvar cachedInterface
                return Nothing
  
          Loaded iface ->
            do  putMVar ciMvar cachedInterface
                return (Just (name, iface))
  
          Unneeded ->
            do  maybeIface <- File.readBinary (Stuff.elmi root name)
                case maybeIface of
                  Nothing ->
                    do  putMVar ciMvar Corrupted
                        return Nothing
  
                  Just iface ->
                    do  putMVar ciMvar (Loaded iface)
                        return (Just (name, iface))
  
  
  
  -- CHECK PROJECT
  
  
  checkMidpoint :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> IO (Either Exit.BuildProjectProblem Dependencies)
  checkMidpoint dmvar statuses =
    case checkForCycles statuses of
      Nothing ->
        do  maybeForeigns <- readMVar dmvar
            case maybeForeigns of
              Nothing -> return (Left Exit.BP_CannotLoadDependencies)
              Just fs -> return (Right fs)
  
      Just (NE.List name names) ->
        do  _ <- readMVar dmvar
            return (Left (Exit.BP_Cycle name names))
  
  
  checkMidpointAndRoots :: MVar (Maybe Dependencies) -> Map.Map ModuleName.Raw Status -> NE.List RootStatus -> IO (Either Exit.BuildProjectProblem Dependencies)
  checkMidpointAndRoots dmvar statuses sroots =
    case checkForCycles statuses of
      Nothing ->
        case checkUniqueRoots statuses sroots of
          Nothing ->
            do  maybeForeigns <- readMVar dmvar
                case maybeForeigns of
                  Nothing -> return (Left Exit.BP_CannotLoadDependencies)
                  Just fs -> return (Right fs)
  
          Just problem ->
            do  _ <- readMVar dmvar
                return (Left problem)
  
      Just (NE.List name names) ->
        do  _ <- readMVar dmvar
            return (Left (Exit.BP_Cycle name names))
  
  
  
  -- CHECK FOR CYCLES
  
  
  checkForCycles :: Map.Map ModuleName.Raw Status -> Maybe (NE.List ModuleName.Raw)
  checkForCycles modules =
    let
      !graph = Map.foldrWithKey addToGraph [] modules
      !sccs = Graph.stronglyConnComp graph
    in
    checkForCyclesHelp sccs
  
  
  checkForCyclesHelp :: [Graph.SCC ModuleName.Raw] -> Maybe (NE.List ModuleName.Raw)
  checkForCyclesHelp sccs =
    case sccs of
      [] ->
        Nothing
  
      scc:otherSccs ->
        case scc of
          Graph.AcyclicSCC _     -> checkForCyclesHelp otherSccs
          Graph.CyclicSCC []     -> checkForCyclesHelp otherSccs
          Graph.CyclicSCC (m:ms) -> Just (NE.List m ms)
  
  
  type Node =
    ( ModuleName.Raw, ModuleName.Raw, [ModuleName.Raw] )
  
  
  addToGraph :: ModuleName.Raw -> Status -> [Node] -> [Node]
  addToGraph name status graph =
    let
      dependencies =
        case status of
          SCached  (Details.Local _ _ deps _ _ _)       -> deps
          SChanged (Details.Local _ _ deps _ _ _) _ _ _ -> deps
          SBadImport _                                  -> []
          SBadSyntax _ _ _ _                            -> []
          SForeign _                                    -> []
          SKernel                                       -> []
    in
    (name, name, dependencies) : graph
  
  
  
  -- CHECK UNIQUE ROOTS
  
  
  checkUniqueRoots :: Map.Map ModuleName.Raw Status -> NE.List RootStatus -> Maybe Exit.BuildProjectProblem
  checkUniqueRoots insides sroots =
    let
      outsidesDict =
        Map.fromListWith OneOrMore.more (Maybe.mapMaybe rootStatusToNamePathPair (NE.toList sroots))
    in
    case Map.traverseWithKey checkOutside outsidesDict of
      Left problem ->
        Just problem
  
      Right outsides ->
        case sequence_ (Map.intersectionWithKey checkInside outsides insides) of
          Right ()     -> Nothing
          Left problem -> Just problem
  
  
  rootStatusToNamePathPair :: RootStatus -> Maybe (ModuleName.Raw, OneOrMore.OneOrMore FilePath)
  rootStatusToNamePathPair sroot =
    case sroot of
      SInside _                                         -> Nothing
      SOutsideOk (Details.Local path _ _ _ _ _) _ modul -> Just (Src.getName modul, OneOrMore.one path)
      SOutsideErr _                                     -> Nothing
  
  
  checkOutside :: ModuleName.Raw -> OneOrMore.OneOrMore FilePath -> Either Exit.BuildProjectProblem FilePath
  checkOutside name paths =
    case OneOrMore.destruct NE.List paths of
      NE.List p  []     -> Right p
      NE.List p1 (p2:_) -> Left (Exit.BP_RootNameDuplicate name p1 p2)
  
  
  checkInside :: ModuleName.Raw -> FilePath -> Status -> Either Exit.BuildProjectProblem ()
  checkInside name p1 status =
    case status of
      SCached  (Details.Local p2 _ _ _ _ _)       -> Left (Exit.BP_RootNameDuplicate name p1 p2)
      SChanged (Details.Local p2 _ _ _ _ _) _ _ _ -> Left (Exit.BP_RootNameDuplicate name p1 p2)
      SBadImport _                                -> Right ()
      SBadSyntax _ _ _ _                          -> Right ()
      SForeign _                                  -> Right ()
      SKernel                                     -> Right ()
  
  
  
  -- COMPILE MODULE
  
  
  compile :: Env -> DocsNeed -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO Result
  compile (Env key root projectType _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
    let
      pkg = projectTypeToPkg projectType
    in
    case Compile.compile pkg ifaces modul of
      Right (Compile.Artifacts canonical annotations objects) ->
        case makeDocs docsNeed canonical of
          Left err ->
            return $ RProblem $
              Error.Module (Src.getName modul) path time source (Error.BadDocs err)
  
          Right docs ->
            do  let name = Src.getName modul
                let iface = I.fromModule pkg canonical annotations
                let elmi = Stuff.elmi root name
                File.writeBinary (Stuff.elmo root name) objects
                maybeOldi <- File.readBinary elmi
                case maybeOldi of
                  Just oldi | oldi == iface ->
                    do  -- iface should be fully forced by equality check
                        Reporting.report key Reporting.BDone
                        let local = Details.Local path time deps main lastChange buildID
                        return (RSame local iface objects docs)
  
                  _ ->
                    do  -- iface may be lazy still
                        File.writeBinary elmi iface
                        Reporting.report key Reporting.BDone
                        let local = Details.Local path time deps main buildID buildID
                        return (RNew local iface objects docs)
  
      Left err ->
        return $ RProblem $
          Error.Module (Src.getName modul) path time source err
  
  
  projectTypeToPkg :: Parse.ProjectType -> Pkg.Name
  projectTypeToPkg projectType =
    case projectType of
      Parse.Package pkg -> pkg
      Parse.Application -> Pkg.dummyName
  
  
  
  -- WRITE DETAILS
  
  
  writeDetails :: FilePath -> Details.Details -> Map.Map ModuleName.Raw Result -> IO ()
  writeDetails root (Details.Details time outline buildID locals foreigns extras) results =
    File.writeBinary (Stuff.details root) $
      Details.Details time outline buildID (Map.foldrWithKey addNewLocal locals results) foreigns extras
  
  
  addNewLocal :: ModuleName.Raw -> Result -> Map.Map ModuleName.Raw Details.Local -> Map.Map ModuleName.Raw Details.Local
  addNewLocal name result locals =
    case result of
      RNew  local _ _ _ -> Map.insert name local locals
      RSame local _ _ _ -> Map.insert name local locals
      RCached _ _ _     -> locals
      RNotFound _       -> locals
      RProblem _        -> locals
      RBlocked          -> locals
      RForeign _        -> locals
      RKernel           -> locals
  
  
  
  -- FINALIZE EXPOSED
  
  
  finalizeExposed :: FilePath -> DocsGoal docs -> NE.List ModuleName.Raw -> Map.Map ModuleName.Raw Result -> IO (Either Exit.BuildProblem docs)
  finalizeExposed root docsGoal exposed results =
    case foldr (addImportProblems results) [] (NE.toList exposed) of
      p:ps ->
        return $ Left $ Exit.BuildProjectProblem (Exit.BP_MissingExposed (NE.List p ps))
  
      [] ->
        case Map.foldr addErrors [] results of
          []   -> Right <$> finalizeDocs docsGoal results
          e:es -> return $ Left $ Exit.BuildBadModules root e es
  
  
  addErrors :: Result -> [Error.Module] -> [Error.Module]
  addErrors result errors =
    case result of
      RNew  _ _ _ _ ->   errors
      RSame _ _ _ _ ->   errors
      RCached _ _ _ ->   errors
      RNotFound _   ->   errors
      RProblem e    -> e:errors
      RBlocked      ->   errors
      RForeign _    ->   errors
      RKernel       ->   errors
  
  
  addImportProblems :: Map.Map ModuleName.Raw Result -> ModuleName.Raw -> [(ModuleName.Raw, Import.Problem)] -> [(ModuleName.Raw, Import.Problem)]
  addImportProblems results name problems =
    case results ! name of
      RNew  _ _ _ _ -> problems
      RSame _ _ _ _ -> problems
      RCached _ _ _ -> problems
      RNotFound p   -> (name, p) : problems
      RProblem _    -> problems
      RBlocked      -> problems
      RForeign _    -> problems
      RKernel       -> problems
  
  
  
  -- DOCS
  
  
  data DocsGoal a where
    KeepDocs :: DocsGoal Docs.Documentation
    WriteDocs :: FilePath -> DocsGoal ()
    IgnoreDocs :: DocsGoal ()
  
  
  newtype DocsNeed =
    DocsNeed { needsDocs :: Bool }
  
  
  toDocsNeed :: DocsGoal a -> DocsNeed
  toDocsNeed goal =
    case goal of
      IgnoreDocs  -> DocsNeed False
      WriteDocs _ -> DocsNeed True
      KeepDocs    -> DocsNeed True
  
  
  makeDocs :: DocsNeed -> Can.Module -> Either EDocs.Error (Maybe Docs.Module)
  makeDocs (DocsNeed isNeeded) modul =
    if isNeeded then
      case Docs.fromModule modul of
        Right docs -> Right (Just docs)
        Left err   -> Left err
    else
      Right Nothing
  
  
  finalizeDocs :: DocsGoal docs -> Map.Map ModuleName.Raw Result -> IO docs
  finalizeDocs goal results =
    case goal of
      KeepDocs ->
        return $ Map.mapMaybe toDocs results
  
      WriteDocs path ->
        E.writeUgly path $ Docs.encode $ Map.mapMaybe toDocs results
  
      IgnoreDocs ->
        return ()
  
  
  toDocs :: Result -> Maybe Docs.Module
  toDocs result =
    case result of
      RNew  _ _ _ d -> d
      RSame _ _ _ d -> d
      RCached _ _ _ -> Nothing
      RNotFound _   -> Nothing
      RProblem _    -> Nothing
      RBlocked      -> Nothing
      RForeign _    -> Nothing
      RKernel       -> Nothing
  
  
  
  --------------------------------------------------------------------------------
  ------ NOW FOR SOME REPL STUFF -------------------------------------------------
  --------------------------------------------------------------------------------
  
  
  -- FROM REPL
  
  
  data ReplArtifacts =
    ReplArtifacts
      { _repl_home :: ModuleName.Canonical
      , _repl_modules :: [Module]
      , _repl_localizer :: L.Localizer
      , _repl_annotations :: Map.Map Name.Name Can.Annotation
      }
  
  
  fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
  fromRepl root details source =
    do  env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
        case Parse.fromByteString projectType source of
          Left syntaxError ->
            return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
  
          Right modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
            do  dmvar <- Details.loadInterfaces root details
  
                let deps = map Src.getImportName imports
                mvar <- newMVar Map.empty
                crawlDeps env mvar deps ()
  
                statuses <- traverse readMVar =<< readMVar mvar
                midpoint <- checkMidpoint dmvar statuses
  
                case midpoint of
                  Left problem ->
                    return $ Left $ Exit.ReplProjectProblem problem
  
                  Right foreigns ->
                    do  rmvar <- newEmptyMVar
                        resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
                        putMVar rmvar resultMVars
                        results <- traverse readMVar resultMVars
                        writeDetails root details results
                        depsStatus <- checkDeps root resultMVars deps 0
                        finalizeReplArtifacts env source modul depsStatus resultMVars results
  
  
  finalizeReplArtifacts :: Env -> B.ByteString -> Src.Module -> DepsStatus -> ResultDict -> Map.Map ModuleName.Raw Result -> IO (Either Exit.Repl ReplArtifacts)
  finalizeReplArtifacts env@(Env _ root projectType _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
    let
      pkg =
        projectTypeToPkg projectType
  
      compileInput ifaces =
        case Compile.compile pkg ifaces modul of
          Right (Compile.Artifacts canonical annotations objects) ->
            let
              h = Can._name canonical
              m = Fresh (Src.getName modul) (I.fromModule pkg canonical annotations) objects
              ms = Map.foldrWithKey addInside [] results
            in
            return $ Right $ ReplArtifacts h (m:ms) (L.fromModule modul) annotations
  
          Left errors ->
            return $ Left $ Exit.ReplBadInput source errors
    in
    case depsStatus of
      DepsChange ifaces ->
        compileInput ifaces
  
      DepsSame same cached ->
        do  maybeLoaded <- loadInterfaces root same cached
            case maybeLoaded of
              Just ifaces -> compileInput ifaces
              Nothing     -> return $ Left $ Exit.ReplBadCache
  
      DepsBlock ->
        case Map.foldr addErrors [] results of
          []   -> return $ Left $ Exit.ReplBlocked
          e:es -> return $ Left $ Exit.ReplBadLocalDeps root e es
  
      DepsNotFound problems ->
        return $ Left $ Exit.ReplBadInput source $ Error.BadImports $
          toImportErrors env resultMVars imports problems
  
  
  
  --------------------------------------------------------------------------------
  --------------------------------------------------------------------------------
  ------ AFTER THIS, EVERYTHING IS ABOUT HANDLING MODULES GIVEN BY FILEPATH ------
  --------------------------------------------------------------------------------
  --------------------------------------------------------------------------------
  
  
  
  -- FIND ROOT
  
  
  data RootLocation
    = LInside ModuleName.Raw
    | LOutside FilePath
  
  
  findRoots :: Env -> NE.List FilePath -> IO (Either Exit.BuildProjectProblem (NE.List RootLocation))
  findRoots env paths =
    do  mvars <- traverse (fork . getRootInfo env) paths
        einfos <- traverse readMVar mvars
        return $ checkRoots =<< sequence einfos
  
  
  checkRoots :: NE.List RootInfo -> Either Exit.BuildProjectProblem (NE.List RootLocation)
  checkRoots infos =
    let
      toOneOrMore loc@(RootInfo absolute _ _) =
        (absolute, OneOrMore.one loc)
  
      fromOneOrMore loc locs =
        case locs of
          [] -> Right ()
          loc2:_ -> Left (Exit.BP_MainPathDuplicate (_relative loc) (_relative loc2))
    in
    fmap (\_ -> fmap _location infos) $
      traverse (OneOrMore.destruct fromOneOrMore) $
        Map.fromListWith OneOrMore.more $ map toOneOrMore (NE.toList infos)
  
  
  
  -- ROOT INFO
  
  
  data RootInfo =
    RootInfo
      { _absolute :: FilePath
      , _relative :: FilePath
      , _location :: RootLocation
      }
  
  
  getRootInfo :: Env -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
  getRootInfo env path =
    do  exists <- File.exists path
        if exists
          then getRootInfoHelp env path =<< Dir.canonicalizePath path
          else return (Left (Exit.BP_PathUnknown path))
  
  
  getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
  getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
    let
      (dirs, file) = FP.splitFileName absolutePath
      (final, ext) = FP.splitExtension file
    in
    if ext /= ".elm"
    then
      return $ Left $ Exit.BP_WithBadExtension path
    else
      let
        absoluteSegments = FP.splitDirectories dirs ++ [final]
      in
      case Maybe.mapMaybe (isInsideSrcDirByPath absoluteSegments) srcDirs of
        [] ->
          return $ Right $ RootInfo absolutePath path (LOutside path)
  
        [(_, Right names)] ->
          do  let name = Name.fromChars (List.intercalate "." names)
              matchingDirs <- filterM (isInsideSrcDirByName names) srcDirs
              case matchingDirs of
                d1:d2:_ ->
                  do  let p1 = addRelative d1 (FP.joinPath names <.> "elm")
                      let p2 = addRelative d2 (FP.joinPath names <.> "elm")
                      return $ Left $ Exit.BP_RootNameDuplicate name p1 p2
  
                _ ->
                  return $ Right $ RootInfo absolutePath path (LInside name)
  
        [(s, Left names)] ->
          return $ Left $ Exit.BP_RootNameInvalid path s names
  
        (s1,_):(s2,_):_ ->
          return $ Left $ Exit.BP_WithAmbiguousSrcDir path s1 s2
  
  
  
  isInsideSrcDirByName :: [String] -> AbsoluteSrcDir -> IO Bool
  isInsideSrcDirByName names srcDir =
    File.exists (addRelative srcDir (FP.joinPath names <.> "elm"))
  
  
  isInsideSrcDirByPath :: [String] -> AbsoluteSrcDir -> Maybe (FilePath, Either [String] [String])
  isInsideSrcDirByPath segments (AbsoluteSrcDir srcDir) =
    case dropPrefix (FP.splitDirectories srcDir) segments of
      Nothing ->
        Nothing
  
      Just names ->
        if all isGoodName names
        then Just (srcDir, Right names)
        else Just (srcDir, Left names)
  
  
  isGoodName :: [Char] -> Bool
  isGoodName name =
    case name of
      [] ->
        False
  
      char:chars ->
        Char.isUpper char && all (\c -> Char.isAlphaNum c || c == '_') chars
  
  
  -- INVARIANT: Dir.canonicalizePath has been run on both inputs
  --
  dropPrefix :: [FilePath] -> [FilePath] -> Maybe [FilePath]
  dropPrefix roots paths =
    case roots of
      [] ->
        Just paths
  
      r:rs ->
        case paths of
          []   -> Nothing
          p:ps -> if r == p then dropPrefix rs ps else Nothing
  
  
  
  -- CRAWL ROOTS
  
  
  data RootStatus
    = SInside ModuleName.Raw
    | SOutsideOk Details.Local B.ByteString Src.Module
    | SOutsideErr Error.Module
  
  
  crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
  crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
    case root of
      LInside name ->
        do  statusMVar <- newEmptyMVar
            statusDict <- takeMVar mvar
            putMVar mvar (Map.insert name statusMVar statusDict)
            putMVar statusMVar =<< crawlModule env mvar (DocsNeed False) name
            return (SInside name)
  
      LOutside path ->
        do  time <- File.getTime path
            source <- File.readUtf8 path
            case Parse.fromByteString projectType source of
              Right modul@(Src.Module _ _ _ imports values _ _ _ _) ->
                do  let deps = map Src.getImportName imports
                    let local = Details.Local path time deps (any isMain values) buildID buildID
                    crawlDeps env mvar deps (SOutsideOk local source modul)
  
              Left syntaxError ->
                return $ SOutsideErr $
                  Error.Module "???" path time source (Error.BadSyntax syntaxError)
  
  
  
  -- CHECK ROOTS
  
  
  data RootResult
    = RInside ModuleName.Raw
    | ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph
    | ROutsideErr Error.Module
    | ROutsideBlocked
  
  
  checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
  checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
    case rootStatus of
      SInside name ->
        return (RInside name)
  
      SOutsideErr err ->
        return (ROutsideErr err)
  
      SOutsideOk local@(Details.Local path time deps _ _ lastCompile) source modul@(Src.Module _ _ _ imports _ _ _ _ _) ->
        do  depsStatus <- checkDeps root results deps lastCompile
            case depsStatus of
              DepsChange ifaces ->
                compileOutside env local source ifaces modul
  
              DepsSame same cached ->
                do  maybeLoaded <- loadInterfaces root same cached
                    case maybeLoaded of
                      Nothing     -> return ROutsideBlocked
                      Just ifaces -> compileOutside env local source ifaces modul
  
              DepsBlock ->
                return ROutsideBlocked
  
              DepsNotFound problems ->
                return $ ROutsideErr $ Error.Module (Src.getName modul) path time source $
                    Error.BadImports (toImportErrors env results imports problems)
  
  
  compileOutside :: Env -> Details.Local -> B.ByteString -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> IO RootResult
  compileOutside (Env key _ projectType _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
    let
      pkg = projectTypeToPkg projectType
      name = Src.getName modul
    in
    case Compile.compile pkg ifaces modul of
      Right (Compile.Artifacts canonical annotations objects) ->
        do  Reporting.report key Reporting.BDone
            return $ ROutsideOk name (I.fromModule pkg canonical annotations) objects
  
      Left errors ->
        return $ ROutsideErr $ Error.Module name path time source errors
  
  
  
  -- TO ARTIFACTS
  
  
  data Root
    = Inside ModuleName.Raw
    | Outside ModuleName.Raw I.Interface Opt.LocalGraph
  
  
  toArtifacts :: Env -> Dependencies -> Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either Exit.BuildProblem Artifacts
  toArtifacts (Env _ root projectType _ _ _ _) foreigns results rootResults =
    case gatherProblemsOrMains results rootResults of
      Left (NE.List e es) ->
        Left (Exit.BuildBadModules root e es)
  
      Right roots ->
        Right $ Artifacts (projectTypeToPkg projectType) foreigns roots $
          Map.foldrWithKey addInside (foldr addOutside [] rootResults) results
  
  
  gatherProblemsOrMains :: Map.Map ModuleName.Raw Result -> NE.List RootResult -> Either (NE.List Error.Module) (NE.List Root)
  gatherProblemsOrMains results (NE.List rootResult rootResults) =
    let
      addResult result (es, roots) =
        case result of
          RInside n        -> (  es, Inside n      : roots)
          ROutsideOk n i o -> (  es, Outside n i o : roots)
          ROutsideErr e    -> (e:es,                 roots)
          ROutsideBlocked  -> (  es,                 roots)
  
      errors = Map.foldr addErrors [] results
    in
    case (rootResult, foldr addResult (errors, []) rootResults) of
      (RInside n       , (  [], ms)) -> Right (NE.List (Inside n) ms)
      (RInside _       , (e:es, _ )) -> Left  (NE.List e es)
      (ROutsideOk n i o, (  [], ms)) -> Right (NE.List (Outside n i o) ms)
      (ROutsideOk _ _ _, (e:es, _ )) -> Left  (NE.List e es)
      (ROutsideErr e   , (  es, _ )) -> Left  (NE.List e es)
      (ROutsideBlocked , (  [], _ )) -> error "seems like elm-stuff/ is corrupted"
      (ROutsideBlocked , (e:es, _ )) -> Left  (NE.List e es)
  
  
  addInside :: ModuleName.Raw -> Result -> [Module] -> [Module]
  addInside name result modules =
    case result of
      RNew  _ iface objs _ -> Fresh name iface objs : modules
      RSame _ iface objs _ -> Fresh name iface objs : modules
      RCached main _ mvar  -> Cached name main mvar : modules
      RNotFound _          -> error (badInside name)
      RProblem _           -> error (badInside name)
      RBlocked             -> error (badInside name)
      RForeign _           -> modules
      RKernel              -> modules
  
  
  badInside :: ModuleName.Raw -> [Char]
  badInside name =
    "Error from `" ++ Name.toChars name ++ "` should have been reported already."
  
  
  addOutside :: RootResult -> [Module] -> [Module]
  addOutside root modules =
    case root of
      RInside _                  -> modules
      ROutsideOk name iface objs -> Fresh name iface objs : modules
      ROutsideErr _              -> modules
      ROutsideBlocked            -> modules
  