From ddb16c2a7b15cc9e97deb3af248b5a525e96f1f6 Mon Sep 17 00:00:00 2001 From: Changlin Li Date: Sun, 26 Nov 2023 19:26:22 -0800 Subject: [PATCH] IT WORKS!!!! First version that seems to build everything without a hitch! --- README.md | 16 ++ REASONING.md | 16 +- builder/src/Deps/Solver.hs | 9 +- builder/src/Elm/Details.hs | 292 ++++++++++++++++++++-------- builder/src/File.hs | 5 +- builder/src/Stuff.hs | 17 ++ cabal.project.freeze.ghc92 | 178 ----------------- cabal.project.freeze.ghc94 | 142 -------------- compiler/src/Generate/JavaScript.hs | 18 +- terminal/src/Develop.hs | 1 + terminal/src/Init.hs | 2 +- terminal/src/Install.hs | 4 +- terminal/src/Make.hs | 7 + terminal/src/Repl.hs | 1 + 14 files changed, 295 insertions(+), 413 deletions(-) delete mode 100644 cabal.project.freeze.ghc92 delete mode 100644 cabal.project.freeze.ghc94 diff --git a/README.md b/README.md index 54f01c748..44b8d74b6 100644 --- a/README.md +++ b/README.md @@ -1,3 +1,19 @@ +# Zelm + +This is a conservative fork of the Elm compiler. It aims to preserve complete +backwards compatibility and (nearly) complete forwards comptability with the +mainline Elm compiler as of Elm 0.19.1. + +We say "nearly" because there are certain bugs in the Elm compiler that will be +fixed by the Zelm compiler. In particular some code which compiles successfully +using the Zelm compiler may cause the mainline Elm compiler to crash. + +Zelm's main purpose is to provide a method for bug fixes and patches + +For a more in-depth look at + +**The following is the README for the original Elm compiler:** + # Elm A delightful language for reliable webapps. diff --git a/REASONING.md b/REASONING.md index 50fab3f5e..9b2900c11 100644 --- a/REASONING.md +++ b/REASONING.md @@ -274,7 +274,6 @@ As such Zelm hopes to **These are hopes not commitments.** But I do consider them valid barometers of whether Zelm has a project has succeeded. - Because Zelm does not intend (at least not until 2025) to do feature development on the Elm language itself, Zelm makes a different set of social trade-offs compared to Elm itself. @@ -287,13 +286,18 @@ and no changes to any APIs. **Much like the technical goals, the social goals of Zelm are very tightly scoped to this goal of responsiveness**. -I hope that by intentionally side-stepping questions of +To achieve this goal of timeliness, Zelm makes two trade-offs that are very +different from Elm itself. + +1. We intentionally are side-stepping many fundamental design questions around + the language itself, at least until 2025. +2. We intend to lead by committee rather than individual. -Zelm prefers to lead by committee rather than individual. +The first point hopefully will allow us -We hope to have a stable roster of at least five people managing `zelm` and -`zelm-explorations`, maybe more (although for tie-breaking purposes I'd like to -keep the number odd). +In particular, our eventual goal is to have a stable roster of at least five +people managing `zelm` and `zelm-explorations`, maybe more (although for +tie-breaking purposes I'd like to keep the number odd). # FAQ diff --git a/builder/src/Deps/Solver.hs b/builder/src/Deps/Solver.hs index 343f63da8..e14cd001e 100644 --- a/builder/src/Deps/Solver.hs +++ b/builder/src/Deps/Solver.hs @@ -390,7 +390,7 @@ constraintsDecoder = data Env = - Env Stuff.PackageCache Http.Manager Connection Registry.ZelmRegistries + Env Stuff.PackageCache Http.Manager Connection Registry.ZelmRegistries Stuff.PackageOverridesCache initEnv :: IO (Either Exit.RegistryProblem Env) @@ -398,6 +398,7 @@ initEnv = do mvar <- newEmptyMVar _ <- forkIO $ putMVar mvar =<< Http.getManager cache <- Stuff.getPackageCache + packageOverridesCache <- Stuff.getPackageOverridesCache zelmCache <- Stuff.getZelmCache customRepositoriesConfigLocation <- Stuff.getOrCreateZelmCustomRepositoryConfig customRepositoriesDataOrErr <- loadCustomRepositoriesData customRepositoriesConfigLocation @@ -413,7 +414,7 @@ initEnv = do eitherRegistry <- Registry.fetch manager zelmCache customRepositoriesData case eitherRegistry of Right latestRegistry -> - return $ Right $ Env cache manager (Online manager) latestRegistry + return $ Right $ Env cache manager (Online manager) latestRegistry packageOverridesCache Left problem -> return $ Left $ problem @@ -422,10 +423,10 @@ initEnv = do eitherRegistry <- Registry.update manager zelmCache cachedRegistry case eitherRegistry of Right latestRegistry -> - return $ Right $ Env cache manager (Online manager) latestRegistry + return $ Right $ Env cache manager (Online manager) latestRegistry packageOverridesCache Left _ -> - return $ Right $ Env cache manager Offline cachedRegistry + return $ Right $ Env cache manager Offline cachedRegistry packageOverridesCache diff --git a/builder/src/Elm/Details.hs b/builder/src/Elm/Details.hs index 589da0cbd..0745c1a57 100644 --- a/builder/src/Elm/Details.hs +++ b/builder/src/Elm/Details.hs @@ -68,6 +68,7 @@ import Control.Exception (SomeException, catches, Handler (..), BlockedIndefinit import qualified Reporting.Annotation as Report.Annotation import qualified Elm.PackageOverrideData as PackageOverrideData import Data.Tuple (swap) +import qualified Elm.Constraint as C @@ -167,10 +168,10 @@ loadInterfaces root (Details _ _ _ _ _ extras) = verifyInstall :: BW.Scope -> FilePath -> Solver.Env -> Outline.Outline -> IO (Either Exit.Details ()) -verifyInstall scope root (Solver.Env cache manager connection registry) outline = +verifyInstall scope root (Solver.Env cache manager connection registry packageOverridesCache) outline = do time <- File.getTime (root "elm.json") let key = Reporting.ignorer - let env = Env key scope root cache manager connection registry + let env = Env key scope root cache manager connection registry packageOverridesCache case outline of Outline.Pkg pkg -> Task.run (verifyPkg env time pkg >> return ()) Outline.App app -> Task.run (verifyApp env time app >> return ()) @@ -227,6 +228,7 @@ data Env = , _manager :: Http.Manager , _connection :: Solver.Connection , _registry :: Registry.ZelmRegistries + , _packageOverridesCache :: Stuff.PackageOverridesCache } @@ -244,8 +246,8 @@ initEnv key scope root = Left problem -> return $ Left $ Exit.DetailsCannotGetRegistry problem - Right (Solver.Env cache manager connection registry) -> - return $ Right (Env key scope root cache manager connection registry, outline) + Right (Solver.Env cache manager connection registry packageOverridesCache) -> + return $ Right (Env key scope root cache manager connection registry packageOverridesCache, outline) @@ -291,11 +293,11 @@ overrideDirectDeps & Map.delete originalPackageName & Map.insert overridePackageName overridePackageVersion -groupByOverridingPkg :: [PackageOverrideData] -> Map.Map Pkg.Name Pkg.Name -groupByOverridingPkg packageOverrides = +groupByOriginalPkg :: [PackageOverrideData] -> Map.Map Pkg.Name (Pkg.Name, V.Version) +groupByOriginalPkg packageOverrides = Map.fromListWith const - (fmap (\po -> (PackageOverrideData._overridePackageName po, PackageOverrideData._originalPackageName po)) packageOverrides) + (fmap (\po -> (PackageOverrideData._originalPackageName po, (PackageOverrideData._overridePackageName po, PackageOverrideData._overridePackageVersion po))) packageOverrides) verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _ packageOverrides) = @@ -314,9 +316,9 @@ verifyApp env time outline@(Outline.AppOutline elmVersion srcDirs direct _ _ _ p let allDepsWithOverrides = foldr overrideSolutionDetails actual packageOverrides let directDepsWithOverrides = foldr overrideDirectDeps direct packageOverrides -- FIXME: Think about what to do with multiple packageOverrides that have the same keys (probably shouldn't be possible?) - let pkgToOverridingPkg = groupByOverridingPkg packageOverrides + let originalPkgToOverridingPkg = groupByOriginalPkg packageOverrides if Map.size stated == Map.size actual - then verifyDependencies env time (ValidApp srcDirs) allDepsWithOverrides directDepsWithOverrides pkgToOverridingPkg + then verifyDependencies env time (ValidApp srcDirs) actual direct originalPkgToOverridingPkg else Task.throw $ Exit.DetailsHandEditedDependencies else Task.throw $ Exit.DetailsBadElmInAppOutline elmVersion @@ -334,7 +336,7 @@ checkAppDeps (Outline.AppOutline _ _ direct indirect testDirect testIndirect _) verifyConstraints :: Env -> Map.Map Pkg.Name Con.Constraint -> Task (Map.Map Pkg.Name Solver.Details) -verifyConstraints (Env _ _ _ cache _ connection registry) constraints = +verifyConstraints (Env _ _ _ cache _ connection registry _) constraints = do result <- Task.io $ Solver.verify cache connection registry constraints case result of Solver.Ok details -> return details @@ -398,8 +400,29 @@ genericErrorHandler msg action = invertMap :: (Ord k, Ord v) => Map.Map k v -> Map.Map v k invertMap forwardMap = Map.fromList (fmap swap (Map.toList forwardMap)) -verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Map.Map Pkg.Name Pkg.Name -> Task Details -verifyDependencies env@(Env key scope root cache _ _ _) time outline solution directDeps overridingPkgToOriginalPkg = +verifyDependencies :: Env -> File.Time -> ValidOutline -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name a -> Map.Map Pkg.Name (Pkg.Name, V.Version) -> Task Details +verifyDependencies (Env key scope root cache manager _ zelmRegistries packageOverridesCache) time outline solution directDeps originalPkgToOverridingPkg = + let + generateBuildData :: Pkg.Name -> V.Version -> BuildData + generateBuildData pkgName pkgVersion = case Map.lookup pkgName originalPkgToOverridingPkg of + Nothing -> BuildOriginalPackage $ + OriginalPackageBuildData + { _pkg = pkgName + , _version = pkgVersion + , _buildCache = cache + } + Just (overridingPkgName, overridingPkgVersion) -> BuildWithOverridingPackage $ + OverridingPackageBuildData + { _originalPkg = pkgName + , _originalPkgVersion = pkgVersion + , _overridingPkg = overridingPkgName + , _overridingPkgVersion = overridingPkgVersion + , _overridingCache = packageOverridesCache + } + + extractVersionFromDetails (Solver.Details vsn _) = vsn + extractConstraintsFromDetails (Solver.Details _ constraints) = constraints + in Task.eio id $ do Reporting.report key (Reporting.DStart (Map.size solution)) print "Made it to VERIFYDEPENDENCIES 0" @@ -407,7 +430,7 @@ verifyDependencies env@(Env key scope root cache _ _ _) time outline solution di print "Made it to VERIFYDEPENDENCIES 1" print ("SOLUTION: " ++ show solution) mvars <- Stuff.withRegistryLock cache $ - Map.traverseWithKey (\k v -> fork (verifyDep env mvar solution k (Map.lookup k overridingPkgToOriginalPkg) (invertMap overridingPkgToOriginalPkg) v)) solution + Map.traverseWithKey (\k details -> fork (verifyDep key (generateBuildData k (extractVersionFromDetails details)) manager zelmRegistries mvar solution (extractConstraintsFromDetails details))) solution print ("Made it to VERIFYDEPENDENCIES 2: " ++ show (Map.keys mvars)) putMVar mvar mvars print "Made it to VERIFYDEPENDENCIES 3" @@ -472,25 +495,36 @@ type Dep = Either (Maybe Exit.DetailsBadDep) Artifacts --- FIXME: Look at comment on build and bubble transitively -verifyDep :: Env -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Pkg.Name -> Maybe Pkg.Name -> Map.Map Pkg.Name Pkg.Name -> Solver.Details -> IO Dep -verifyDep (Env key _ _ cache manager _ zelmRegistry) depsMVar solution pkg originalPkgMaybe originalPkgToOverridingPkg details@(Solver.Details vsn directDeps) = - do let fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps - exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn) - print (show exists ++ "A0" ++ Stuff.package cache pkg vsn) - exists <- Dir.doesDirectoryExist (Stuff.package cache pkg vsn "src") +verifyDep :: Reporting.DKey -> BuildData -> Http.Manager -> ZelmRegistries -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Map.Map Pkg.Name Solver.Details -> Map.Map Pkg.Name C.Constraint -> IO Dep +verifyDep key buildData manager zelmRegistry depsMVar solution directDeps = + let + fingerprint = Map.intersectionWith (\(Solver.Details v _) _ -> v) solution directDeps + cacheFilePath = cacheFilePathFromBuildData buildData + -- These are the pkg names and versions that we actually perform downloading and error reporting on + (primaryPkg, primaryPkgVersion) = + case buildData of + BuildOriginalPackage (OriginalPackageBuildData { _pkg=pkg, _version=vsn }) -> + (pkg, vsn) + BuildWithOverridingPackage + (OverridingPackageBuildData {_overridingPkg=overridingPkg, _overridingPkgVersion=overridingPkgVer}) -> + (overridingPkg, overridingPkgVer) + downloadPackageAction = downloadPackageToFilePath cacheFilePath zelmRegistry manager primaryPkg primaryPkgVersion + in + do exists <- Dir.doesDirectoryExist cacheFilePath + print (show exists ++ "A0" ++ cacheFilePath) + exists <- Dir.doesDirectoryExist (cacheFilePath "src") if exists then do Reporting.report key Reporting.DCached - maybeCache <- File.readBinary (Stuff.package cache pkg vsn "artifacts.dat") + maybeCache <- File.readBinary (cacheFilePath "artifacts.dat") case maybeCache of Nothing -> - build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg details fingerprint Set.empty + build key buildData depsMVar fingerprint Set.empty Just (ArtifactCache fingerprints artifacts) -> if Set.member fingerprint fingerprints then Reporting.report key Reporting.DBuilt >> return (Right artifacts) - else build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg details fingerprint fingerprints + else build key buildData depsMVar fingerprint fingerprints else do Reporting.report key Reporting.DRequested -- Normally we don't need to create the directory because it's created during the @@ -513,16 +547,16 @@ verifyDep (Env key _ _ cache manager _ zelmRegistry) depsMVar solution pkg origi -- package was used around and we want that to drive the constraint process in -- the bad case that the override package is malformed and doesn't follow the -- same dependencies as the original package. - Dir.createDirectoryIfMissing True (Stuff.package cache pkg vsn) - result <- downloadPackage cache zelmRegistry manager pkg vsn + Dir.createDirectoryIfMissing True cacheFilePath + result <- downloadPackageAction case result of Left problem -> - do Reporting.report key (Reporting.DFailed pkg vsn) - return $ Left $ Just $ Exit.BD_BadDownload pkg vsn problem + do Reporting.report key (Reporting.DFailed primaryPkg primaryPkgVersion) + return $ Left $ Just $ Exit.BD_BadDownload primaryPkg primaryPkgVersion problem Right () -> - do Reporting.report key (Reporting.DReceived pkg vsn) - build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg details fingerprint Set.empty + do Reporting.report key (Reporting.DReceived primaryPkg primaryPkgVersion) + build key buildData depsMVar fingerprint Set.empty @@ -547,10 +581,48 @@ isZelm :: Pkg.Name -> Bool isZelm name = take 4 (Utf8.toChars (Pkg._project name)) == "time" --- FIXME: I don't think I need pkg originalPkgMaybe and originalPkgToOverridingPkg, maybe pass in bidirectional map? -build :: Reporting.DKey -> Stuff.PackageCache -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Pkg.Name -> Maybe Pkg.Name -> Map.Map Pkg.Name Pkg.Name -> Solver.Details -> Fingerprint -> Set.Set Fingerprint -> IO Dep -build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg (Solver.Details vsn _) f fs = - do eitherOutline <- Outline.read (Stuff.package cache pkg vsn) +data OverridingPackageBuildData = OverridingPackageBuildData + { _originalPkg :: Pkg.Name + , _originalPkgVersion :: V.Version + , _overridingPkg :: Pkg.Name + , _overridingPkgVersion :: V.Version + , _overridingCache :: Stuff.PackageOverridesCache + } + +data OriginalPackageBuildData = OriginalPackageBuildData + { _pkg :: Pkg.Name + , _version :: V.Version + , _buildCache :: Stuff.PackageCache + } + +data BuildData + = BuildOriginalPackage OriginalPackageBuildData + | BuildWithOverridingPackage OverridingPackageBuildData + + +cacheFilePathFromBuildData :: BuildData -> FilePath +cacheFilePathFromBuildData buildData = + case buildData of + BuildOriginalPackage (OriginalPackageBuildData { _pkg=pkg, _version=vsn, _buildCache=cache }) -> + Stuff.package cache pkg vsn + BuildWithOverridingPackage + (OverridingPackageBuildData {_originalPkg=origPkg, _originalPkgVersion=origPkgVer, _overridingPkg=overPkg, _overridingPkgVersion=overPkgVer, _overridingCache=cache}) -> + Stuff.packageOverride cache origPkg origPkgVer overPkg overPkgVer + + +build :: Reporting.DKey -> BuildData -> MVar (Map.Map Pkg.Name (MVar Dep)) -> Fingerprint -> Set.Set Fingerprint -> IO Dep +build key buildData depsMVar f fs = + let + cacheFilePath = cacheFilePathFromBuildData buildData + (pkg, vsn) = case buildData of + BuildOriginalPackage (OriginalPackageBuildData { _pkg=pkg, _version=vsn, _buildCache=cache }) -> + (pkg, vsn) + BuildWithOverridingPackage + (OverridingPackageBuildData {_originalPkg=origPkg, _originalPkgVersion=origPkgVer, _overridingPkg=overPkg, _overridingPkgVersion=overPkgVer, _overridingCache=cache}) -> + (origPkg, origPkgVer) + + in + do eitherOutline <- Outline.read cacheFilePath print ("COMPILING: " ++ show pkg ++ show vsn ++ " OUTLINE: " ++ show eitherOutline) case eitherOutline of Left _ -> @@ -565,10 +637,8 @@ build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg (Solver do allDeps <- readMVar depsMVar when (isZelm pkg) (print $ "zelm package: allDeps keys are" ++ show (Map.keys allDeps)) -- FIXME: Think about whether there is a more elegant way of doing this - let depsWithOverrides = Map.fromList (fmap (\n -> (Maybe.fromMaybe n (Map.lookup n originalPkgToOverridingPkg), ())) (Map.keys deps)) when (isZelm pkg) (print $ "zelm package: deps keys are" ++ show (Map.keys deps)) - when (isZelm pkg) (print $ "zelm package: depsWithOverrides keys are" ++ show (Map.keys depsWithOverrides)) - directDeps <- traverse readMVar (Map.intersection allDeps depsWithOverrides) + directDeps <- traverse readMVar (Map.intersection allDeps deps) when (isZelm pkg) (print $ "zelm package: directDeps are" ++ show directDeps) case sequence directDeps of Left x -> @@ -577,12 +647,12 @@ build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg (Solver return $ Left $ Nothing Right directArtifacts -> - do let src = Stuff.package cache pkg vsn "src" + do let src = cacheFilePath "src" let foreignDeps = gatherForeignInterfaces directArtifacts when (isZelm pkg) (print ("zelm package: directArtifacts" ++ show directArtifacts)) when (isZelm pkg) (print ("zelm package: foreignDeps" ++ show foreignDeps)) let exposedDict = Map.fromKeys (\_ -> ()) (Outline.flattenExposed exposed) - docsStatus <- getDocsStatus cache pkg vsn + docsStatus <- getDocsStatusFromFilePath cacheFilePath mvar <- newEmptyMVar mvars <- Map.traverseWithKey (const . fork . crawlModule foreignDeps mvar pkg src docsStatus) exposedDict putMVar mvar mvars @@ -601,7 +671,7 @@ build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg (Solver when (isZelm pkg) (print "zelm package: past rmvar") let extractDepsFromStatus status = case status of (SLocal _ deps _) -> deps; _ -> Map.empty when (isZelm pkg) (print ("statuses: " ++ show (fmap extractDepsFromStatus statuses))) - let compileAction status = genericErrorHandler ("This package failed: " ++ show pkg) (compile pkg originalPkgMaybe rmvar status) + let compileAction status = genericErrorHandler ("This package failed: " ++ show pkg) (compile pkg rmvar status) rmvars <- traverse (fork . compileAction) statuses when (isZelm pkg) (print "zelm package: past rmvars") putMVar rmvar rmvars @@ -615,13 +685,13 @@ build key cache depsMVar pkg originalPkgMaybe originalPkgToOverridingPkg (Solver Just results -> let - path = Stuff.package cache pkg vsn "artifacts.dat" + path = cacheFilePath "artifacts.dat" ifaces = gatherInterfaces exposedDict results objects = gatherObjects results artifacts = Artifacts ifaces objects fingerprints = Set.insert f fs in - do writeDocs cache pkg vsn docsStatus results + do writeDocsToFilePath cacheFilePath docsStatus results File.writeBinary path (ArtifactCache fingerprints artifacts) Reporting.report key Reporting.DBuilt return (Right artifacts) @@ -804,38 +874,8 @@ data Result --- We need to use the package override data when compiling because the compiler --- special-cases a lot of compilation behavior for the elm/core module. Most of this --- special-casing is done by specifically checking or writing the "elm/core" --- module literal. This means any efforts to override the "elm/core" with --- another package that has a different author name or package name will cause a --- mysterious compilation error. --- --- But we want to allow people to name their packages something that's *not* --- elm/core! And we want to preserve that information as deep as possible, so --- that we can give intelligent errors when doing dependency resolution, instead --- of claiming to look for "elm/core" when in fact we're looking for another --- package. --- --- The ideal strategy would be to generalize this special-casing because in --- theory it's not needed. But that would be a gargantuan task. --- --- Instead, we trick the compiler by swapping in the "elm/core" literal during --- compilation. But again we want to delay this swapping until compilation --- proper so that we can get intelligent error messages during dependency --- resolution. --- --- This is actually less of a hack than it seems. Large parts of the Elm --- compiler actually only check module names, not package names, to the point --- that if two packages had the same module names this can cause compilation --- errors. It is rather more of a hack (but an extremely painful one to remove) --- that the Elm compiler uses package names in its compilation process. --- --- But the main upshot of this is that error message quality is actually still --- pretty much preserved (although Elm's error messages when a dependency causes --- problems were never great to begin with.) -compile :: Pkg.Name -> Maybe Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result) -compile pkg originalPkgNameMaybe mvar status = +compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result) +compile pkg mvar status = case status of SLocal docsStatus deps modul -> do resultsDict <- readMVar mvar @@ -846,22 +886,21 @@ compile pkg originalPkgNameMaybe mvar status = when (isZelm pkg ) (print ("all keys in thingToRead: " ++ show (Map.keys thingToRead))) maybeResults <- Map.traverseWithKey (\k v -> hasLocked ("compiling this pkg: " ++ show pkg ++ "reading this module: " ++ show k) (readMVar v)) (Map.intersection resultsDict deps) when (isZelm pkg) (print "made it past maybeResults") - let originalPkgName = Maybe.fromMaybe pkg originalPkgNameMaybe case sequence maybeResults of Nothing -> do when (isZelm pkg) (print "nothing branch of sequence maybeResults") return Nothing Just results -> - case Compile.compile originalPkgName (Map.mapMaybe getInterface results) modul of + case Compile.compile pkg (Map.mapMaybe getInterface results) modul of Left compileError -> do - print ("compileError for " ++ show pkg ++ " original pkg " ++ show originalPkgName ++ "module: " ++ show modul ++ ": " ++ show compileError) + print ("compileError for " ++ show pkg ++ " pkg " ++ show pkg ++ "module: " ++ show modul ++ ": " ++ show compileError) return Nothing Right (Compile.Artifacts canonical annotations objects) -> let - ifaces = I.fromModule originalPkgName canonical annotations + ifaces = I.fromModule pkg canonical annotations docs = makeDocs docsStatus canonical in return (Just (RLocal ifaces objects docs)) @@ -902,6 +941,20 @@ getDocsStatus cache pkg vsn = then return DocsNotNeeded else return DocsNeeded +getDocsStatusFromFilePath :: FilePath -> IO DocsStatus +getDocsStatusFromFilePath pathToDocsDir = + do exists <- File.exists (pathToDocsDir "docs.json") + if exists + then return DocsNotNeeded + else return DocsNeeded + +getDocsStatusOverridePkg :: Stuff.PackageOverridesCache -> Pkg.Name -> V.Version -> Pkg.Name -> V.Version -> IO DocsStatus +getDocsStatusOverridePkg cache originalPkg originalVsn overridingPkg overridingVsn = + do exists <- File.exists (Stuff.packageOverride cache originalPkg originalVsn overridingPkg overridingVsn "docs.json") + if exists + then return DocsNotNeeded + else return DocsNeeded + makeDocs :: DocsStatus -> Can.Module -> Maybe Docs.Module makeDocs status modul = @@ -925,6 +978,26 @@ writeDocs cache pkg vsn status results = DocsNotNeeded -> return () +writeDocsToFilePath :: FilePath -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO () +writeDocsToFilePath pathToDocsDir status results = + case status of + DocsNeeded -> + E.writeUgly (pathToDocsDir "docs.json") $ + Docs.encode $ Map.mapMaybe toDocs results + + DocsNotNeeded -> + return () + +writeDocsOverridingPackage :: Stuff.PackageOverridesCache -> Pkg.Name -> V.Version -> Pkg.Name -> V.Version -> DocsStatus -> Map.Map ModuleName.Raw Result -> IO () +writeDocsOverridingPackage cache originalPkg originalVsn overridingPkg overridingVsn status results = + case status of + DocsNeeded -> + E.writeUgly (Stuff.packageOverride cache originalPkg originalVsn overridingPkg overridingVsn "docs.json") $ + Docs.encode $ Map.mapMaybe toDocs results + + DocsNotNeeded -> + return () + toDocs :: Result -> Maybe Docs.Module toDocs result = @@ -960,6 +1033,28 @@ downloadPackage cache zelmRegistries manager pkg vsn = pure (Left $ Exit.PP_PackageNotInRegistry blah pkg vsn) +-- FIXME: reduce duplication with downloadPackage +downloadPackageToFilePath :: FilePath -> ZelmRegistries -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ()) +downloadPackageToFilePath filePath zelmRegistries manager pkg vsn = + case Registry.lookupPackageRegistryKey zelmRegistries pkg vsn of + Just (Registry.RepositoryUrlKey repositoryUrl) -> + do + exists <- Dir.doesDirectoryExist filePath + print (show exists ++ "A (toFilePath)" ++ filePath) + downloadPackageFromElmPackageRepoToFilePath filePath repositoryUrl manager pkg vsn + Just (Registry.PackageUrlKey packageUrl) -> + do + exists <- Dir.doesDirectoryExist filePath + print (show exists ++ "B (toFilePath)" ++ filePath) + downloadPackageDirectlyToFilePath filePath packageUrl manager + Nothing -> + let + --FIXME + blah = fmap show (Map.keys $ Registry._registries zelmRegistries) + in + pure (Left $ Exit.PP_PackageNotInRegistry blah pkg vsn) + + downloadPackageDirectly :: Stuff.PackageCache -> PackageUrl -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ()) downloadPackageDirectly cache packageUrl manager pkg vsn = let @@ -972,6 +1067,18 @@ downloadPackageDirectly cache packageUrl manager pkg vsn = print "hello world 2! FIXME" File.writePackage (Stuff.package cache pkg vsn) archive +downloadPackageDirectlyToFilePath :: FilePath -> PackageUrl -> Http.Manager -> IO (Either Exit.PackageProblem ()) +downloadPackageDirectlyToFilePath filePath packageUrl manager = + let + urlString = Utf8.toChars packageUrl + in + Http.getArchive manager urlString Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent urlString) $ + -- FIXME: Deal with the SHA hash instead of ignoring it + \(_, archive) -> + Right <$> do + print "hello world 2! FIXME (toFilePath)" + File.writePackage filePath archive + downloadPackageFromElmPackageRepo :: Stuff.PackageCache -> RepositoryUrl -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ()) downloadPackageFromElmPackageRepo cache repositoryUrl manager pkg vsn = @@ -1003,6 +1110,37 @@ downloadPackageFromElmPackageRepo cache repositoryUrl manager pkg vsn = else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha) +-- FIXME: Reduce duplication +downloadPackageFromElmPackageRepoToFilePath :: FilePath -> RepositoryUrl -> Http.Manager -> Pkg.Name -> V.Version -> IO (Either Exit.PackageProblem ()) +downloadPackageFromElmPackageRepoToFilePath filePath repositoryUrl manager pkg vsn = + let + url = Website.metadata repositoryUrl pkg vsn "endpoint.json" + in + do eitherByteString <- + Http.get manager url [] id (return . Right) + exists <- Dir.doesDirectoryExist filePath + print (show exists ++ "B0 (toFilePath)" ++ filePath) + + case eitherByteString of + Left err -> + return $ Left $ Exit.PP_BadEndpointRequest err + + Right byteString -> + case D.fromByteString endpointDecoder byteString of + Left _ -> + return $ Left $ Exit.PP_BadEndpointContent url + + Right (endpoint, expectedHash) -> + Http.getArchive manager endpoint Exit.PP_BadArchiveRequest (Exit.PP_BadArchiveContent endpoint) $ + \(sha, archive) -> + if expectedHash == Http.shaToChars sha + then Right <$> do + exists <- Dir.doesDirectoryExist filePath + print (show exists ++ "C (toFilePath)" ++ filePath) + File.writePackage filePath archive + else return $ Left $ Exit.PP_BadArchiveHash endpoint expectedHash (Http.shaToChars sha) + + endpointDecoder :: D.Decoder e (String, String) endpointDecoder = do url <- D.field "url" D.string diff --git a/builder/src/File.hs b/builder/src/File.hs index d37b59d0b..207fe4a54 100644 --- a/builder/src/File.hs +++ b/builder/src/File.hs @@ -172,8 +172,11 @@ encodingError path ioErr = writeBuilder :: FilePath -> B.Builder -> IO () writeBuilder path builder = IO.withBinaryFile path IO.WriteMode $ \handle -> - do IO.hSetBuffering handle (IO.BlockBuffering Nothing) + do print "writeBuilder 1" + IO.hSetBuffering handle (IO.BlockBuffering Nothing) + print "writeBuilder 2" B.hPutBuilder handle builder + print "writeBuilder 3" diff --git a/builder/src/Stuff.hs b/builder/src/Stuff.hs index c07a33a92..6dbe53ff0 100644 --- a/builder/src/Stuff.hs +++ b/builder/src/Stuff.hs @@ -12,10 +12,13 @@ module Stuff , withRegistryLock , PackageCache , ZelmSpecificCache + , PackageOverridesCache , getPackageCache , getZelmCache + , getPackageOverridesCache , registry , package + , packageOverride , getReplCache , getElmHome , getOrCreateZelmCustomRepositoryConfig @@ -163,12 +166,21 @@ newtype PackageCache = PackageCache FilePath newtype ZelmSpecificCache = ZelmSpecificCache FilePath +newtype PackageOverridesCache = PackageOverridesCache FilePath + getPackageCache :: IO PackageCache getPackageCache = PackageCache <$> getCacheDir "packages" +getPackageOverridesCache :: IO PackageOverridesCache +getPackageOverridesCache = + do + (ZelmSpecificCache zelmSpecificCache) <- getZelmCache + pure $ PackageOverridesCache zelmSpecificCache + + getZelmCache :: IO ZelmSpecificCache getZelmCache = ZelmSpecificCache <$> getOrCreateZelmCacheDir @@ -184,6 +196,11 @@ package (PackageCache dir) name version = dir Pkg.toFilePath name V.toChars version +packageOverride :: PackageOverridesCache -> Pkg.Name -> V.Version -> Pkg.Name -> V.Version -> FilePath +packageOverride (PackageOverridesCache dir) originalPkgName originalPkgVersion overridingPkgName overridingPkgVersion = + dir Pkg.toFilePath originalPkgName V.toChars originalPkgVersion Pkg.toFilePath overridingPkgName V.toChars overridingPkgVersion + + -- CACHE diff --git a/cabal.project.freeze.ghc92 b/cabal.project.freeze.ghc92 deleted file mode 100644 index a07ef71fe..000000000 --- a/cabal.project.freeze.ghc92 +++ /dev/null @@ -1,178 +0,0 @@ -active-repositories: hackage.haskell.org:merge -constraints: any.HTTP ==4000.4.1, - HTTP -conduit10 +network-uri -warn-as-error -warp-tests, - any.HUnit ==1.6.2.0, - any.QuickCheck ==2.14.3, - QuickCheck -old-random +templatehaskell, - any.SHA ==1.6.4.4, - SHA -exe, - any.ansi-terminal ==1.0, - ansi-terminal -example, - any.ansi-terminal-types ==0.11.5, - any.ansi-wl-pprint ==0.6.9, - ansi-wl-pprint -example, - any.appar ==0.1.8, - any.array ==0.5.4.0, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.async ==2.2.4, - async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.barbies ==2.0.4.0, - any.base ==4.16.4.0, - any.base-orphans ==0.9.0, - any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.16, - any.binary ==0.8.9.0, - any.blaze-builder ==0.4.2.3, - any.byteorder ==1.0.4, - any.bytestring ==0.11.4.0, - any.bytestring-builder ==0.10.8.2.0, - bytestring-builder +bytestring_has_builder, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.cereal ==0.5.8.3, - cereal -bytestring-builder, - any.clock ==0.8.4, - clock -llvm, - any.colour ==2.3.6, - any.concurrent-output ==1.10.19, - any.constraints ==0.13.4, - any.containers ==0.6.5.1, - any.cookie ==0.4.6, - any.crypton ==0.33, - crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.crypton-connection ==0.3.1, - any.crypton-x509 ==1.7.6, - any.crypton-x509-store ==1.6.9, - any.crypton-x509-system ==1.6.7, - any.crypton-x509-validation ==1.6.12, - any.data-array-byte ==0.1.0.1, - any.data-default-class ==0.1.2.0, - any.deepseq ==1.4.6.1, - any.digest ==0.0.1.3, - digest -bytestring-in-base, - any.directory ==1.3.6.2, - any.distributive ==0.6.2.1, - distributive +semigroups +tagged, - any.edit-distance ==0.2.2.1, - elm -dev, - any.erf ==2.0.0.0, - any.exceptions ==0.10.4, - any.file-embed ==0.0.15.0, - any.filelock ==0.1.1.7, - any.filepath ==1.4.2.2, - any.ghc-bignum ==1.2, - any.ghc-boot-th ==9.2.8, - any.ghc-prim ==0.8.0, - any.happy ==1.20.1.1, - any.hashable ==1.4.3.0, - hashable +integer-gmp -random-initial-seed, - any.haskeline ==0.8.2, - any.haskell-lexer ==1.1.1, - any.hedgehog ==1.4, - any.hourglass ==0.2.12, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.http-client ==0.7.14, - http-client +network-uri, - any.http-client-tls ==0.3.6.3, - any.http-types ==0.12.3, - any.integer-gmp ==1.1, - any.integer-logarithms ==1.0.3.1, - integer-logarithms -check-bounds +integer-gmp, - any.io-streams ==1.5.2.2, - io-streams +network -nointeractivetests +zlib, - any.io-streams-haproxy ==1.0.1.0, - any.iproute ==1.7.12, - any.language-glsl ==0.3.0, - any.lifted-async ==0.10.2.4, - any.lifted-base ==0.2.3.12, - any.logict ==0.8.1.0, - any.memory ==0.18.0, - memory +support_bytestring +support_deepseq, - any.mime-types ==0.1.1.0, - any.mmorph ==1.2.0, - any.monad-control ==1.0.3.1, - any.mtl ==2.2.2, - any.network ==3.1.4.0, - network -devel, - any.network-uri ==2.6.4.2, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.3, - any.optparse-applicative ==0.18.1.0, - optparse-applicative +process, - any.parsec ==3.1.15.0, - any.pem ==0.2.4, - any.pretty ==1.1.3.6, - any.pretty-show ==1.10, - any.prettyclass ==1.0.0.0, - any.prettyprinter ==1.7.1, - prettyprinter -buildreadme +text, - any.prettyprinter-ansi-terminal ==1.1.3, - any.primitive ==0.8.0.0, - any.process ==1.6.16.0, - any.random ==1.2.1.1, - any.raw-strings-qq ==1.1, - any.readable ==0.3.1, - any.regex-base ==0.94.0.2, - any.regex-posix ==0.96.0.1, - regex-posix -_regex-posix-clib, - any.resourcet ==1.3.0, - any.rts ==1.0.2, - any.safe-exceptions ==0.1.7.4, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.smallcheck ==1.2.1.1, - any.snap-core ==1.0.5.1, - snap-core -debug +network-uri -portable, - any.snap-server ==1.1.2.1, - snap-server -build-pong -build-testserver -debug -openssl -portable, - any.socks ==0.6.1, - any.splitmix ==0.1.0.4, - splitmix -optimised-mixer, - any.stm ==2.5.0.2, - any.streaming-commons ==0.2.2.6, - streaming-commons -use-bytestring-builder, - any.tagged ==0.8.8, - tagged +deepseq +transformers, - any.tasty ==1.5, - tasty +unix, - any.tasty-hedgehog ==1.4.0.2, - any.tasty-hunit ==0.10.1, - any.tasty-quickcheck ==0.10.3, - any.tasty-smallcheck ==0.8.2, - any.template-haskell ==2.18.0.0, - any.terminal-size ==0.3.4, - any.terminfo ==0.4.1.5, - any.text ==1.2.5.0, - any.th-compat ==0.1.4, - any.time ==1.11.1.1, - any.tls ==1.9.0, - tls +compat -hans +network, - any.transformers ==0.5.6.2, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.2, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.type-equality ==1, - any.unix ==2.7.2.2, - any.unix-compat ==0.7, - unix-compat -old-time, - any.unix-time ==0.4.11, - any.unliftio-core ==0.2.1.0, - any.unordered-containers ==0.2.19.1, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.vector ==0.13.0.0, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-stream ==0.1.0.0, - any.wl-pprint-annotated ==0.1.0.1, - any.zip-archive ==0.4.3, - zip-archive -executable, - any.zlib ==0.6.3.0, - zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, - any.zlib-bindings ==0.1.1.5 -index-state: hackage.haskell.org 2023-09-27T15:54:35Z diff --git a/cabal.project.freeze.ghc94 b/cabal.project.freeze.ghc94 deleted file mode 100644 index 4d1be9326..000000000 --- a/cabal.project.freeze.ghc94 +++ /dev/null @@ -1,142 +0,0 @@ -active-repositories: hackage.haskell.org:merge -constraints: any.HTTP ==4000.4.1, - HTTP -conduit10 +network-uri -warn-as-error -warp-tests, - any.HUnit ==1.6.2.0, - any.SHA ==1.6.4.4, - SHA -exe, - any.ansi-terminal ==1.0, - ansi-terminal -example, - any.ansi-terminal-types ==0.11.5, - any.ansi-wl-pprint ==0.6.9, - ansi-wl-pprint -example, - any.appar ==0.1.8, - any.array ==0.5.4.0, - any.asn1-encoding ==0.9.6, - any.asn1-parse ==0.9.5, - any.asn1-types ==0.3.4, - any.async ==2.2.4, - async -bench, - any.attoparsec ==0.14.4, - attoparsec -developer, - any.base ==4.17.1.0, - any.base-orphans ==0.9.0, - any.base64-bytestring ==1.2.1.0, - any.basement ==0.0.16, - any.binary ==0.8.9.1, - any.blaze-builder ==0.4.2.3, - any.byteorder ==1.0.4, - any.bytestring ==0.11.4.0, - any.bytestring-builder ==0.10.8.2.0, - bytestring-builder +bytestring_has_builder, - any.call-stack ==0.4.0, - any.case-insensitive ==1.2.1.0, - any.cereal ==0.5.8.3, - cereal -bytestring-builder, - any.clock ==0.8.4, - clock -llvm, - any.colour ==2.3.6, - any.containers ==0.6.7, - any.cookie ==0.4.6, - any.crypton ==0.33, - crypton -check_alignment +integer-gmp -old_toolchain_inliner +support_aesni +support_deepseq +support_pclmuldq +support_rdrand -support_sse +use_target_attributes, - any.crypton-connection ==0.3.1, - any.crypton-x509 ==1.7.6, - any.crypton-x509-store ==1.6.9, - any.crypton-x509-system ==1.6.7, - any.crypton-x509-validation ==1.6.12, - any.data-default-class ==0.1.2.0, - any.deepseq ==1.4.8.0, - any.digest ==0.0.1.3, - digest -bytestring-in-base, - any.directory ==1.3.7.1, - any.edit-distance ==0.2.2.1, - elm -dev, - any.exceptions ==0.10.5, - any.file-embed ==0.0.15.0, - any.filelock ==0.1.1.7, - any.filepath ==1.4.2.2, - any.ghc-bignum ==1.3, - any.ghc-boot-th ==9.4.5, - any.ghc-prim ==0.9.0, - any.hashable ==1.4.3.0, - hashable +integer-gmp -random-initial-seed, - any.haskeline ==0.8.2, - any.hourglass ==0.2.12, - any.hsc2hs ==0.68.10, - hsc2hs -in-ghc-tree, - any.http-client ==0.7.14, - http-client +network-uri, - any.http-client-tls ==0.3.6.3, - any.http-types ==0.12.3, - any.integer-gmp ==1.1, - any.integer-logarithms ==1.0.3.1, - integer-logarithms -check-bounds +integer-gmp, - any.io-streams ==1.5.2.2, - io-streams +network -nointeractivetests +zlib, - any.io-streams-haproxy ==1.0.1.0, - any.iproute ==1.7.12, - any.language-glsl ==0.3.0, - any.lifted-base ==0.2.3.12, - any.memory ==0.18.0, - memory +support_bytestring +support_deepseq, - any.mime-types ==0.1.1.0, - any.monad-control ==1.0.3.1, - any.mtl ==2.2.2, - any.network ==3.1.4.0, - network -devel, - any.network-uri ==2.6.4.2, - any.old-locale ==1.0.0.7, - any.old-time ==1.1.0.3, - any.parsec ==3.1.16.1, - any.pem ==0.2.4, - any.pretty ==1.1.3.6, - any.prettyclass ==1.0.0.0, - any.primitive ==0.8.0.0, - any.process ==1.6.16.0, - any.random ==1.2.1.1, - any.raw-strings-qq ==1.1, - any.readable ==0.3.1, - any.regex-base ==0.94.0.2, - any.regex-posix ==0.96.0.1, - regex-posix -_regex-posix-clib, - any.rts ==1.0.2, - any.scientific ==0.3.7.0, - scientific -bytestring-builder -integer-simple, - any.snap-core ==1.0.5.1, - snap-core -debug +network-uri -portable, - any.snap-server ==1.1.2.1, - snap-server -build-pong -build-testserver -debug -openssl -portable, - any.socks ==0.6.1, - any.splitmix ==0.1.0.4, - splitmix -optimised-mixer, - any.stm ==2.5.1.0, - any.streaming-commons ==0.2.2.6, - streaming-commons -use-bytestring-builder, - any.template-haskell ==2.19.0.0, - any.terminfo ==0.4.1.5, - any.text ==2.0.2, - any.th-compat ==0.1.4, - any.time ==1.12.2, - any.tls ==1.9.0, - tls +compat -hans +network, - any.transformers ==0.5.6.2, - any.transformers-base ==0.4.6, - transformers-base +orphaninstances, - any.transformers-compat ==0.7.2, - transformers-compat -five +five-three -four +generic-deriving +mtl -three -two, - any.unix ==2.7.3, - any.unix-compat ==0.7, - unix-compat -old-time, - any.unix-time ==0.4.11, - any.unordered-containers ==0.2.19.1, - unordered-containers -debug, - any.utf8-string ==1.0.2, - any.vector ==0.13.0.0, - vector +boundschecks -internalchecks -unsafechecks -wall, - any.vector-stream ==0.1.0.0, - any.zip-archive ==0.4.3, - zip-archive -executable, - any.zlib ==0.6.3.0, - zlib -bundled-c-zlib -non-blocking-ffi -pkg-config, - any.zlib-bindings ==0.1.1.5 -index-state: hackage.haskell.org 2023-09-27T15:54:35Z diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index d8116f33f..1033d7e7d 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -30,6 +30,10 @@ import qualified Generate.Mode as Mode import qualified Reporting.Doc as D import qualified Reporting.Render.Type as RT import qualified Reporting.Render.Type.Localizer as L +import qualified Debug.Trace as Debug +import Control.Exception (Exception, throw) +import qualified Elm.Package as Pkg +import qualified Data.Maybe as Maybe @@ -182,14 +186,24 @@ addGlobal mode graph state@(State revKernels builders seen) global = addGlobalHelp mode graph global $ State revKernels builders (Set.insert global seen) +data MyException = MyException String + deriving (Show) + +instance Exception MyException addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State -addGlobalHelp mode graph global state = +addGlobalHelp mode graph currentGlobal state = let addDeps deps someState = Set.foldl' (addGlobal mode graph) someState deps + Opt.Global globalCanonical globalName = currentGlobal + canonicalPkgName = ModuleName._package globalCanonical + global = Opt.Global ( globalCanonical { ModuleName._package = canonicalPkgName } ) globalName + globalInGraph = case Map.lookup global graph of + Just x -> x + Nothing -> throw (MyException ("addGlobalHelp: this was graph keys " ++ show (Map.keys graph) ++ " and this was old global " ++ show currentGlobal ++ " and this was new global: " ++ show global)) in - case graph ! global of + case globalInGraph of Opt.Define expr deps -> addStmt (addDeps deps state) ( var global (Expr.generate mode expr) diff --git a/terminal/src/Develop.hs b/terminal/src/Develop.hs index 003393647..a1632e033 100644 --- a/terminal/src/Develop.hs +++ b/terminal/src/Develop.hs @@ -32,6 +32,7 @@ import qualified Reporting import qualified Reporting.Exit as Exit import qualified Reporting.Task as Task import qualified Stuff +import qualified Elm.Details as ModuleName diff --git a/terminal/src/Init.hs b/terminal/src/Init.hs index 8ddbb69c2..19f92df48 100644 --- a/terminal/src/Init.hs +++ b/terminal/src/Init.hs @@ -70,7 +70,7 @@ init = Left problem -> return (Left (Exit.InitRegistryProblem problem)) - Right (Solver.Env cache _ connection registry) -> + Right (Solver.Env cache _ connection registry _) -> do result <- Solver.verify cache connection registry defaults case result of Solver.Err exit -> diff --git a/terminal/src/Install.hs b/terminal/src/Install.hs index df7819c46..aba8596ab 100644 --- a/terminal/src/Install.hs +++ b/terminal/src/Install.hs @@ -149,7 +149,7 @@ attemptChangesHelp root env oldOutline newOutline question = makeAppPlan :: Solver.Env -> Pkg.Name -> Outline.AppOutline -> Task (Changes V.Version) -makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect _) = +makeAppPlan (Solver.Env cache _ connection registry _) pkg outline@(Outline.AppOutline _ _ direct indirect testDirect testIndirect _) = if Map.member pkg direct then return AlreadyInstalled @@ -212,7 +212,7 @@ makeAppPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.AppOut makePkgPlan :: Solver.Env -> Pkg.Name -> Outline.PkgOutline -> Task (Changes C.Constraint) -makePkgPlan (Solver.Env cache _ connection registry) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) = +makePkgPlan (Solver.Env cache _ connection registry _) pkg outline@(Outline.PkgOutline _ _ _ _ _ deps test _) = if Map.member pkg deps then return AlreadyInstalled else diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index 69b0e14d2..fa21b5609 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -35,6 +35,7 @@ import qualified Data.Map as Map import Elm.Details (Foreign(..)) import qualified Data.Utf8 as Utf8 import Elm.Package (Name(..)) +import qualified Elm.Package as Pkg @@ -93,6 +94,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) = p:ps -> do artifacts <- buildPaths style root details (NE.List p ps) + Task.io (print "Made it to RUN 3") case maybeOutput of Nothing -> case getMains artifacts of @@ -114,7 +116,9 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) = case getNoMains artifacts of [] -> do builder <- toBuilder root details desiredMode artifacts + Task.io (print "Made it to RUN 4") generate style target builder (Build.getRootNames artifacts) + Task.io (print "Made it to RUN 5") name:names -> Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) @@ -251,8 +255,11 @@ generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw - generate style target builder names = Task.io $ do Dir.createDirectoryIfMissing True (FP.takeDirectory target) + print "generate 1" File.writeBuilder target builder + print "generate 2" Reporting.reportGenerate style names target + print "generate 3" diff --git a/terminal/src/Repl.hs b/terminal/src/Repl.hs index 45f471b17..79c833214 100644 --- a/terminal/src/Repl.hs +++ b/terminal/src/Repl.hs @@ -67,6 +67,7 @@ import qualified Reporting.Render.Code as Code import qualified Reporting.Report as Report import qualified Reporting.Task as Task import qualified Stuff +import qualified Elm.Details as ModuleName