summaryrefslogtreecommitdiff
path: root/src/Language/PureScript/Make/BuildPlan.hs
blob: 7f728f2c5268a09193da4caaec7c04967302be88 (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
module Language.PureScript.Make.BuildPlan
  ( BuildPlan()
  , construct
  , getResult
  , collectErrors
  , collectResults
  , markComplete
  , needsRebuild
  ) where

import           Prelude

import           Control.Concurrent.Async.Lifted as A
import           Control.Concurrent.Lifted as C
import           Control.Monad hiding (sequence)
import           Control.Monad.Trans.Class (lift)
import           Control.Monad.Trans.Control (MonadBaseControl(..))
import           Control.Monad.Trans.Maybe (MaybeT(..), runMaybeT)
import           Data.Foldable (foldl')
import qualified Data.Map as M
import           Data.Maybe (catMaybes, fromMaybe)
import           Data.Time.Clock (UTCTime)
import           Language.PureScript.AST
import           Language.PureScript.Crash
import qualified Language.PureScript.CST as CST
import           Language.PureScript.Errors
import           Language.PureScript.Externs
import           Language.PureScript.Make.Actions as Actions
import           Language.PureScript.Names (ModuleName)

-- | The BuildPlan tracks information about our build progress, and holds all
-- prebuilt modules for incremental builds.
data BuildPlan = BuildPlan
  { bpPrebuilt :: M.Map ModuleName Prebuilt
  , bpBuildJobs :: M.Map ModuleName BuildJob
  }

data Prebuilt = Prebuilt
  { pbModificationTime :: UTCTime
  , pbExternsFile :: ExternsFile
  }

data BuildJob = BuildJob
  { bjResult :: C.MVar (Maybe (MultipleErrors, ExternsFile))
  , bjErrors :: C.MVar (Maybe MultipleErrors)
  }

-- | Called when we finished compiling a module and want to report back the
-- compilation result, as well as any potential errors that were thrown.
markComplete
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> ModuleName
  -> Maybe (MultipleErrors, ExternsFile)
  -> Maybe MultipleErrors
  -> m ()
markComplete buildPlan moduleName result errors = do
  let BuildJob rVar eVar = fromMaybe (internalError "make: markComplete no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)
  putMVar rVar result
  putMVar eVar errors

-- | Whether or not the module with the given ModuleName needs to be rebuilt
needsRebuild :: BuildPlan -> ModuleName -> Bool
needsRebuild bp moduleName = M.member moduleName (bpBuildJobs bp)

-- | Collects errors for all modules that have been rebuilt. This will block
-- until all outstanding build jobs are finished.
collectErrors
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> m [MultipleErrors]
collectErrors buildPlan  = do
  errors <- traverse readMVar $ map bjErrors $ M.elems (bpBuildJobs buildPlan)
  pure (catMaybes errors)

-- | Collects ExternsFiles for all prebuilt as well as rebuilt modules. Panics
-- if any build job returned an error.
collectResults
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> m (M.Map ModuleName ExternsFile)
collectResults buildPlan = do
  let externs = M.map pbExternsFile (bpPrebuilt buildPlan)
  barrierResults <- traverse (takeMVar . bjResult) $ bpBuildJobs buildPlan
  let barrierExterns = M.map (snd . fromMaybe (internalError "make: externs were missing but no errors reported.")) barrierResults
  pure (M.union externs barrierExterns)

-- | Gets the the build result for a given module name independent of whether it
-- was rebuilt or prebuilt. Prebuilt modules always return no warnings.
getResult
  :: (MonadBaseControl IO m)
  => BuildPlan
  -> ModuleName
  -> m (Maybe (MultipleErrors, ExternsFile))
getResult buildPlan moduleName =
  case M.lookup moduleName (bpPrebuilt buildPlan) of
    Just es ->
      pure (Just (MultipleErrors [], pbExternsFile es))
    Nothing ->
      readMVar $ bjResult $ fromMaybe (internalError "make: no barrier") $ M.lookup moduleName (bpBuildJobs buildPlan)

-- | Constructs a BuildPlan for the given module graph.
--
-- The given MakeActions are used to collect various timestamps in order to
-- determine whether a module needs rebuilding.
construct
  :: forall m. (Monad m, MonadBaseControl IO m)
  => MakeActions m
  -> ([CST.PartialResult Module], [(ModuleName, [ModuleName])])
  -> m BuildPlan
construct MakeActions{..} (sorted, graph) = do
  prebuilt <- foldl' collectPrebuiltModules M.empty . catMaybes <$> A.forConcurrently sorted findExistingExtern
  let toBeRebuilt = filter (not . flip M.member prebuilt . getModuleName . CST.resPartial) sorted
  buildJobs <- foldM makeBuildJob M.empty (map (getModuleName . CST.resPartial) toBeRebuilt)
  pure $ BuildPlan prebuilt buildJobs
  where
    makeBuildJob prev moduleName = do
      buildJob <- BuildJob <$> C.newEmptyMVar <*> C.newEmptyMVar
      pure (M.insert moduleName buildJob prev)

    findExistingExtern :: CST.PartialResult Module -> m (Maybe (ModuleName, Bool, Prebuilt))
    findExistingExtern (getModuleName . CST.resPartial -> moduleName) = runMaybeT $ do
      inputTimestamp <- lift $ getInputTimestamp moduleName
      (rebuildNever, existingTimestamp) <-
        case inputTimestamp of
          Left RebuildNever ->
            fmap (True,) $ MaybeT $ getOutputTimestamp moduleName
          Right (Just t1) -> do
            outputTimestamp <- MaybeT $ getOutputTimestamp moduleName
            guard (t1 < outputTimestamp)
            pure (False, outputTimestamp)
          _ -> mzero
      externsFile <- MaybeT $ decodeExterns . snd <$> readExterns moduleName
      pure (moduleName, rebuildNever, Prebuilt existingTimestamp externsFile)

    collectPrebuiltModules :: M.Map ModuleName Prebuilt -> (ModuleName, Bool, Prebuilt) -> M.Map ModuleName Prebuilt
    collectPrebuiltModules prev (moduleName, rebuildNever, pb)
      | rebuildNever = M.insert moduleName pb prev
      | otherwise = do
          let deps = fromMaybe (internalError "make: module not found in dependency graph.") (lookup moduleName graph)
          case traverse (fmap pbModificationTime . flip M.lookup prev) deps of
            Nothing ->
              -- If we end up here, one of the dependencies didn't exist in the
              -- prebuilt map and so we know a dependency needs to be rebuilt, which
              -- means we need to be rebuilt in turn.
              prev
            Just modTimes ->
              case maximumMaybe modTimes of
                Just depModTime | pbModificationTime pb < depModTime ->
                  prev
                _ -> M.insert moduleName pb prev

maximumMaybe :: Ord a => [a] -> Maybe a
maximumMaybe [] = Nothing
maximumMaybe xs = Just $ maximum xs