Skip to content

Commit 3a2a761

Browse files
robinheghanrobinheghan
authored
Merge pull request #291 from gren-lang/next
25S Changes
2 parents a4e6a02 + 227a09b commit 3a2a761

Some content is hidden

Large Commits have some content hidden by default. Use the searchbox below for content that may be hidden.

56 files changed

+4558
-2708
lines changed

‎.github/workflows/build.yml

Lines changed: 2 additions & 2 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,8 @@ on:
77
branches: [main]
88

99
env:
10-
ghc: "9.6.6"
11-
cabal: "3.10.3.0"
10+
ghc: "9.8.4"
11+
cabal: "3.12.1.0"
1212

1313
jobs:
1414
validate-code-formatting:

‎.gitignore

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,6 @@
11
.DS_Store
22
*~
3+
.envrc
34

45
# Haskell build stuff
56
dist
@@ -13,4 +14,5 @@ node_modules
1314

1415
# Gren build stuff
1516
.gren
17+
gren_packages
1618
compiler.js

‎builder/src/Build.hs

Lines changed: 189 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -5,7 +5,10 @@
55

66
module Build
77
( fromExposed,
8+
fromExposedSources,
89
fromPaths,
10+
fromPathsSources,
11+
fromMainModules,
912
fromRepl,
1013
Artifacts (..),
1114
Root (..),
@@ -27,9 +30,11 @@ import Control.Concurrent (forkIO)
2730
import Control.Concurrent.MVar
2831
import Control.Monad (filterM)
2932
import Data.ByteString qualified as B
33+
import Data.ByteString.Internal (ByteString)
3034
import Data.Char qualified as Char
3135
import Data.Graph qualified as Graph
3236
import Data.List qualified as List
37+
import Data.Map (Map)
3338
import Data.Map.Strict ((!))
3439
import Data.Map.Strict qualified as Map
3540
import Data.Map.Utils qualified as Map
@@ -134,6 +139,35 @@ fromExposed style root details docsGoal exposed@(NE.List e es) =
134139
writeDetails root details results
135140
finalizeExposed root docsGoal exposed results
136141

142+
fromExposedSources :: Reporting.Style -> FilePath -> Details.Details -> Map ModuleName.Raw ByteString -> DocsGoal docs -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem docs)
143+
fromExposedSources style root details sources docsGoal exposed@(NE.List e es) =
144+
Reporting.trackBuild style $ \key ->
145+
do
146+
env <- makeEnv key root details
147+
dmvar <- Details.loadInterfaces root details
148+
149+
-- crawl
150+
mvar <- newEmptyMVar
151+
let docsNeed = toDocsNeed docsGoal
152+
roots <- Map.fromKeysA (fork . crawlModuleSources env mvar sources docsNeed) (e : es)
153+
putMVar mvar roots
154+
mapM_ readMVar roots
155+
statuses <- traverse readMVar =<< readMVar mvar
156+
157+
-- compile
158+
midpoint <- checkMidpoint dmvar statuses
159+
case midpoint of
160+
Left problem ->
161+
return (Left (Exit.BuildProjectProblem problem))
162+
Right foreigns ->
163+
do
164+
rmvar <- newEmptyMVar
165+
resultMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
166+
putMVar rmvar resultMVars
167+
results <- traverse readMVar resultMVars
168+
writeDetails root details results
169+
finalizeExposed root docsGoal exposed results
170+
137171
-- FROM PATHS
138172

139173
data Artifacts = Artifacts
@@ -184,6 +218,68 @@ fromPaths style root details paths =
184218
writeDetails root details results
185219
toArtifacts env foreigns results <$> traverse readMVar rrootMVars
186220

221+
fromPathsSources :: Reporting.Style -> FilePath -> Details.Details -> Map ModuleName.Raw ByteString -> NE.List FilePath -> IO (Either Exit.BuildProblem Artifacts)
222+
fromPathsSources style root details sources paths =
223+
Reporting.trackBuild style $ \key ->
224+
do
225+
env <- makeEnv key root details
226+
227+
elroots <- findRoots env paths
228+
case elroots of
229+
Left problem ->
230+
return (Left (Exit.BuildProjectProblem problem))
231+
Right lroots ->
232+
do
233+
-- crawl
234+
dmvar <- Details.loadInterfaces root details
235+
smvar <- newMVar Map.empty
236+
srootMVars <- traverse (fork . crawlRootSources env smvar sources) lroots
237+
sroots <- traverse readMVar srootMVars
238+
statuses <- traverse readMVar =<< readMVar smvar
239+
240+
midpoint <- checkMidpointAndRoots dmvar statuses sroots
241+
case midpoint of
242+
Left problem ->
243+
return (Left (Exit.BuildProjectProblem problem))
244+
Right foreigns ->
245+
do
246+
-- compile
247+
rmvar <- newEmptyMVar
248+
resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
249+
putMVar rmvar resultsMVars
250+
rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
251+
results <- traverse readMVar resultsMVars
252+
writeDetails root details results
253+
toArtifacts env foreigns results <$> traverse readMVar rrootMVars
254+
255+
fromMainModules :: Reporting.Style -> FilePath -> Details.Details -> Map ModuleName.Raw ByteString -> NE.List ModuleName.Raw -> IO (Either Exit.BuildProblem Artifacts)
256+
fromMainModules style root details sources rootModules =
257+
Reporting.trackBuild style $ \key ->
258+
do
259+
env <- makeEnv key root details
260+
261+
-- crawl
262+
dmvar <- Details.loadInterfaces root details
263+
smvar <- newMVar Map.empty
264+
srootMVars <- traverse (fork . crawlRootModule env smvar sources) rootModules
265+
sroots <- traverse readMVar srootMVars
266+
statuses <- traverse readMVar =<< readMVar smvar
267+
268+
midpoint <- checkMidpointAndRoots dmvar statuses sroots
269+
case midpoint of
270+
Left problem ->
271+
return (Left (Exit.BuildProjectProblem problem))
272+
Right foreigns ->
273+
do
274+
-- compile
275+
rmvar <- newEmptyMVar
276+
resultsMVars <- forkWithKey (checkModule env foreigns rmvar) statuses
277+
putMVar rmvar resultsMVars
278+
rrootMVars <- traverse (fork . checkRoot env resultsMVars) sroots
279+
results <- traverse readMVar resultsMVars
280+
writeDetails root details results
281+
toArtifacts env foreigns results <$> traverse readMVar rrootMVars
282+
187283
-- GET ROOT NAMES
188284

189285
getRootNames :: Artifacts -> NE.List ModuleName.Raw
@@ -222,6 +318,19 @@ crawlDeps env mvar deps blockedValue =
222318
where
223319
crawlNew name () = fork (crawlModule env mvar (DocsNeed False) name)
224320

321+
crawlDepsSources :: Env -> MVar StatusDict -> Map ModuleName.Raw ByteString -> [ModuleName.Raw] -> a -> IO a
322+
crawlDepsSources env mvar sources deps blockedValue =
323+
do
324+
statusDict <- takeMVar mvar
325+
let depsDict = Map.fromKeys (\_ -> ()) deps
326+
let newsDict = Map.difference depsDict statusDict
327+
statuses <- Map.traverseWithKey crawlNew newsDict
328+
putMVar mvar (Map.union statuses statusDict)
329+
mapM_ readMVar statuses
330+
return blockedValue
331+
where
332+
crawlNew name () = fork (crawlModuleSources env mvar sources (DocsNeed False) name)
333+
225334
crawlModule :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> IO Status
226335
crawlModule env@(Env _ root projectType _ srcDirs buildID locals foreigns) mvar docsNeed name =
227336
do
@@ -261,6 +370,34 @@ crawlModule env@(Env _ root projectType _ srcDirs buildID locals foreigns) mvar
261370
return $ if exists then SKernel else SBadImport Import.NotFound
262371
else return $ SBadImport Import.NotFound
263372

373+
-- TODO: Use (slimmed down) locals to avoid compiling a module twice
374+
-- TODO: Pass on path from frontend
375+
crawlModuleSources :: Env -> MVar StatusDict -> Map ModuleName.Raw ByteString -> DocsNeed -> ModuleName.Raw -> IO Status
376+
crawlModuleSources env@(Env _ _ projectType _ _ buildID _ foreigns) mvar sources docsNeed name =
377+
let path = ModuleName.toFilePath name <.> "gren"
378+
in case Map.lookup name sources of
379+
Just source ->
380+
case Map.lookup name foreigns of
381+
Just (Details.Foreign dep deps) ->
382+
return $ SBadImport $ Import.Ambiguous path [] dep deps
383+
Nothing ->
384+
if Name.isKernel name
385+
then
386+
if Parse.isKernel projectType
387+
then return SKernel
388+
else return $ SBadImport Import.NotFound
389+
else crawlFileSources env mvar sources docsNeed name path source buildID
390+
Nothing ->
391+
case Map.lookup name foreigns of
392+
Just (Details.Foreign dep deps) ->
393+
case deps of
394+
[] ->
395+
return $ SForeign dep
396+
d : ds ->
397+
return $ SBadImport $ Import.AmbiguousForeign dep d ds
398+
Nothing ->
399+
return $ SBadImport Import.NotFound
400+
264401
crawlFile :: Env -> MVar StatusDict -> DocsNeed -> ModuleName.Raw -> FilePath -> File.Time -> Details.BuildID -> IO Status
265402
crawlFile env@(Env _ root projectType _ _ buildID _ _) mvar docsNeed expectedName path time lastChange =
266403
do
@@ -281,6 +418,23 @@ crawlFile env@(Env _ root projectType _ _ buildID _ _) mvar docsNeed expectedNam
281418
in crawlDeps env mvar deps (SChanged local source modul docsNeed)
282419
else return $ SBadSyntax path time source (Syntax.ModuleNameMismatch expectedName name)
283420

421+
crawlFileSources :: Env -> MVar StatusDict -> Map ModuleName.Raw ByteString -> DocsNeed -> ModuleName.Raw -> FilePath -> ByteString -> Details.BuildID -> IO Status
422+
crawlFileSources env@(Env _ _ projectType _ _ buildID _ _) mvar sources docsNeed expectedName path source lastChange =
423+
case Parse.fromByteString projectType source of
424+
Left err ->
425+
return $ SBadSyntax path File.zeroTime source err
426+
Right modul@(Src.Module maybeActualName _ _ imports values _ _ _ _ _ _) ->
427+
case maybeActualName of
428+
Nothing ->
429+
return $ SBadSyntax path File.zeroTime source (Syntax.ModuleNameUnspecified expectedName)
430+
Just name@(A.At _ actualName) ->
431+
if expectedName == actualName
432+
then
433+
let deps = map (Src.getImportName . snd) imports
434+
local = Details.Local path File.zeroTime deps (any (isMain . snd) values) lastChange buildID
435+
in crawlDepsSources env mvar sources deps (SChanged local source modul docsNeed)
436+
else return $ SBadSyntax path File.zeroTime source (Syntax.ModuleNameMismatch expectedName name)
437+
284438
isMain :: A.Located Src.Value -> Bool
285439
isMain (A.At _ (Src.Value (A.At _ name) _ _ _ _)) =
286440
name == Name._main
@@ -961,8 +1115,43 @@ crawlRoot env@(Env _ _ projectType _ _ buildID _ _) mvar root =
9611115
SOutsideErr $
9621116
Error.Module "???" path time source (Error.BadSyntax syntaxError)
9631117

1118+
crawlRootSources :: Env -> MVar StatusDict -> Map ModuleName.Raw ByteString -> RootLocation -> IO RootStatus
1119+
crawlRootSources env@(Env _ _ projectType _ _ buildID _ _) mvar sources root =
1120+
case root of
1121+
LInside name ->
1122+
do
1123+
statusMVar <- newEmptyMVar
1124+
statusDict <- takeMVar mvar
1125+
putMVar mvar (Map.insert name statusMVar statusDict)
1126+
putMVar statusMVar =<< crawlModuleSources env mvar sources (DocsNeed False) name
1127+
return (SInside name)
1128+
LOutside path ->
1129+
do
1130+
time <- File.getTime path
1131+
source <- File.readUtf8 path
1132+
case Parse.fromByteString projectType source of
1133+
Right modul@(Src.Module _ _ _ imports values _ _ _ _ _ _) ->
1134+
do
1135+
let deps = map (Src.getImportName . snd) imports
1136+
let local = Details.Local path time deps (any (isMain . snd) values) buildID buildID
1137+
crawlDeps env mvar deps (SOutsideOk local source modul)
1138+
Left syntaxError ->
1139+
return $
1140+
SOutsideErr $
1141+
Error.Module "???" path time source (Error.BadSyntax syntaxError)
1142+
1143+
crawlRootModule :: Env -> MVar StatusDict -> Map ModuleName.Raw ByteString -> ModuleName.Raw -> IO RootStatus
1144+
crawlRootModule env mvar sources root =
1145+
do
1146+
statusMVar <- newEmptyMVar
1147+
statusDict <- takeMVar mvar
1148+
putMVar mvar (Map.insert root statusMVar statusDict)
1149+
putMVar statusMVar =<< crawlModuleSources env mvar sources (DocsNeed False) root
1150+
return (SInside root)
1151+
9641152
-- CHECK ROOTS
9651153

1154+
-- TODO: Only support RInside
9661155
data RootResult
9671156
= RInside ModuleName.Raw
9681157
| ROutsideOk ModuleName.Raw I.Interface Opt.LocalGraph

‎builder/src/Deps/Diff.hs

Lines changed: 1 addition & 3 deletions
Original file line numberDiff line numberDiff line change
@@ -290,9 +290,7 @@ unionChangesMagnitude unionChanges =
290290
getDocs :: Dirs.PackageCache -> Pkg.Name -> V.Version -> Task.Task Exit.DocsProblem Docs.Documentation
291291
getDocs cache pkg vsn =
292292
do
293-
Task.eio Exit.DP_Git $
294-
Dirs.withRegistryLock cache $
295-
Package.installPackageVersion cache pkg vsn
293+
Task.eio Exit.DP_Git $ Package.installPackageVersion cache pkg vsn
296294
let home = Dirs.package cache pkg vsn
297295
let path = home </> "docs.json"
298296
exists <- Task.io $ File.exists path

‎builder/src/Deps/Solver.hs

Lines changed: 28 additions & 30 deletions
Original file line numberDiff line numberDiff line change
@@ -78,14 +78,13 @@ verify ::
7878
Map.Map Pkg.Name (PossibleFilePath C.Constraint) ->
7979
IO (Result (Map.Map Pkg.Name Details))
8080
verify key cache rootPlatform constraints =
81-
Dirs.withRegistryLock cache $
82-
case try key rootPlatform constraints of
83-
Solver solver ->
84-
solver
85-
(State cache Map.empty)
86-
(\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
87-
(\_ -> return NoSolution)
88-
(\e -> return $ Err e)
81+
case try key rootPlatform constraints of
82+
Solver solver ->
83+
solver
84+
(State cache Map.empty)
85+
(\s a _ -> return $ Ok (Map.mapWithKey (addDeps s) a))
86+
(\_ -> return NoSolution)
87+
(\e -> return $ Err e)
8988

9089
addDeps :: State -> Pkg.Name -> ConstraintSource -> Details
9190
addDeps (State _ constraints) name constraintSource =
@@ -110,28 +109,27 @@ addToApp ::
110109
Outline.AppOutline ->
111110
IO (Result AppSolution)
112111
addToApp key cache pkg compatibleVsn outline@(Outline.AppOutline _ rootPlatform _ direct indirect) =
113-
Dirs.withRegistryLock cache $
114-
let allDeps = Map.union direct indirect
115-
116-
insertableVsn = PossibleFilePath.Other (C.untilNextMajor compatibleVsn)
117-
118-
attempt toConstraint deps =
119-
try
120-
key
121-
rootPlatform
122-
(Map.insert pkg insertableVsn (Map.map (PossibleFilePath.mapWith toConstraint) deps))
123-
in case oneOf
124-
(attempt C.exactly allDeps)
125-
[ attempt C.exactly direct,
126-
attempt C.untilNextMinor direct,
127-
attempt C.untilNextMajor direct
128-
] of
129-
Solver solver ->
130-
solver
131-
(State cache Map.empty)
132-
(\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
133-
(\_ -> return $ NoSolution)
134-
(\e -> return $ Err e)
112+
let allDeps = Map.union direct indirect
113+
114+
insertableVsn = PossibleFilePath.Other (C.untilNextMajor compatibleVsn)
115+
116+
attempt toConstraint deps =
117+
try
118+
key
119+
rootPlatform
120+
(Map.insert pkg insertableVsn (Map.map (PossibleFilePath.mapWith toConstraint) deps))
121+
in case oneOf
122+
(attempt C.exactly allDeps)
123+
[ attempt C.exactly direct,
124+
attempt C.untilNextMinor direct,
125+
attempt C.untilNextMajor direct
126+
] of
127+
Solver solver ->
128+
solver
129+
(State cache Map.empty)
130+
(\s a _ -> return $ Ok (toApp s pkg outline allDeps a))
131+
(\_ -> return $ NoSolution)
132+
(\e -> return $ Err e)
135133

136134
toApp :: State -> Pkg.Name -> Outline.AppOutline -> Map.Map Pkg.Name (PossibleFilePath V.Version) -> Map.Map Pkg.Name ConstraintSource -> AppSolution
137135
toApp (State _ constraints) pkg (Outline.AppOutline gren platform srcDirs direct _) old new =

‎builder/src/Directories.hs

Lines changed: 0 additions & 16 deletions
Original file line numberDiff line numberDiff line change
@@ -7,8 +7,6 @@ module Directories
77
greni,
88
greno,
99
findRoot,
10-
withRootLock,
11-
withRegistryLock,
1210
PackageCache,
1311
getPackageCache,
1412
package,
@@ -22,7 +20,6 @@ import Gren.Package qualified as Pkg
2220
import Gren.Version qualified as V
2321
import System.Directory qualified as Dir
2422
import System.Environment qualified as Env
25-
import System.FileLock qualified as Lock
2623
import System.FilePath ((<.>), (</>))
2724
import System.FilePath qualified as FP
2825

@@ -82,19 +79,6 @@ findRootHelp dirs =
8279
then return (Just (FP.joinPath dirs))
8380
else findRootHelp (init dirs)
8481

85-
-- LOCKS
86-
87-
withRootLock :: FilePath -> IO a -> IO a
88-
withRootLock root work =
89-
do
90-
let dir = projectCache root
91-
Dir.createDirectoryIfMissing True dir
92-
Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
93-
94-
withRegistryLock :: PackageCache -> IO a -> IO a
95-
withRegistryLock (PackageCache dir) work =
96-
Lock.withFileLock (dir </> "lock") Lock.Exclusive (\_ -> work)
97-
9882
-- PACKAGE CACHES
9983

10084
newtype PackageCache = PackageCache FilePath

0 commit comments

Comments
 (0)