mirror of
https://github.com/gren-lang/compiler.git
synced 2024-09-17 11:47:14 +03:00
Merge pull request #115 from gren-lang/add-node-builder
Add support for compiling NodeJS applications
This commit is contained in:
commit
dfe645f819
@ -46,6 +46,7 @@ import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as P
|
||||
import Json.Encode qualified as E
|
||||
import Parse.Module qualified as Parse
|
||||
import Reporting qualified
|
||||
@ -66,6 +67,7 @@ data Env = Env
|
||||
{ _key :: Reporting.BKey,
|
||||
_root :: FilePath,
|
||||
_project :: Parse.ProjectType,
|
||||
_platform :: P.Platform,
|
||||
_srcDirs :: [AbsoluteSrcDir],
|
||||
_buildID :: Details.BuildID,
|
||||
_locals :: Map.Map ModuleName.Raw Details.Local,
|
||||
@ -75,14 +77,14 @@ data Env = Env
|
||||
makeEnv :: Reporting.BKey -> FilePath -> Details.Details -> IO Env
|
||||
makeEnv key root (Details.Details _ validOutline buildID locals foreigns _) =
|
||||
case validOutline of
|
||||
Details.ValidApp givenSrcDirs ->
|
||||
Details.ValidApp platform givenSrcDirs ->
|
||||
do
|
||||
srcDirs <- traverse (Outline.toAbsoluteSrcDir root) (NE.toList givenSrcDirs)
|
||||
return $ Env key root Parse.Application srcDirs buildID locals foreigns
|
||||
Details.ValidPkg pkg _ ->
|
||||
return $ Env key root Parse.Application platform srcDirs buildID locals foreigns
|
||||
Details.ValidPkg platform pkg _ ->
|
||||
do
|
||||
srcDir <- Outline.toAbsoluteSrcDir root (Outline.RelativeSrcDir "src")
|
||||
return $ Env key root (Parse.Package pkg) [srcDir] buildID locals foreigns
|
||||
return $ Env key root (Parse.Package pkg) platform [srcDir] buildID locals foreigns
|
||||
|
||||
-- FORK
|
||||
|
||||
@ -221,7 +223,7 @@ crawlDeps env mvar deps blockedValue =
|
||||
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 =
|
||||
crawlModule env@(Env _ root projectType _ srcDirs buildID locals foreigns) mvar docsNeed name =
|
||||
do
|
||||
let fileName = ModuleName.toFilePath name <.> "gren"
|
||||
|
||||
@ -260,7 +262,7 @@ crawlModule env@(Env _ root projectType srcDirs buildID locals foreigns) mvar do
|
||||
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 =
|
||||
crawlFile env@(Env _ root projectType _ _ buildID _ _) mvar docsNeed expectedName path time lastChange =
|
||||
do
|
||||
source <- File.readUtf8 (root </> path)
|
||||
|
||||
@ -304,7 +306,7 @@ data CachedInterface
|
||||
| Corrupted
|
||||
|
||||
checkModule :: Env -> Dependencies -> MVar ResultDict -> ModuleName.Raw -> Status -> IO Result
|
||||
checkModule env@(Env _ root projectType _ _ _ _) foreigns resultsMVar name status =
|
||||
checkModule env@(Env _ root projectType _ _ _ _ _) foreigns resultsMVar name status =
|
||||
case status of
|
||||
SCached local@(Details.Local path time deps hasMain lastChange lastCompile) ->
|
||||
do
|
||||
@ -429,7 +431,7 @@ checkDepsHelp root results deps new same cached importProblems isBlocked lastDep
|
||||
-- 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 =
|
||||
toImportErrors (Env _ _ _ _ _ _ locals foreigns) results imports problems =
|
||||
let knownModules =
|
||||
Set.unions
|
||||
[ Map.keysSet foreigns,
|
||||
@ -596,9 +598,9 @@ checkInside name p1 status =
|
||||
-- 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 =
|
||||
compile (Env key root projectType platform _ buildID _ _) docsNeed (Details.Local path time deps main lastChange _) source ifaces modul =
|
||||
let pkg = projectTypeToPkg projectType
|
||||
in case Compile.compile pkg ifaces modul of
|
||||
in case Compile.compile platform pkg ifaces modul of
|
||||
Right (Compile.Artifacts canonical annotations objects) ->
|
||||
case makeDocs docsNeed canonical of
|
||||
Left err ->
|
||||
@ -754,7 +756,7 @@ data ReplArtifacts = ReplArtifacts
|
||||
fromRepl :: FilePath -> Details.Details -> B.ByteString -> IO (Either Exit.Repl ReplArtifacts)
|
||||
fromRepl root details source =
|
||||
do
|
||||
env@(Env _ _ projectType _ _ _ _) <- makeEnv Reporting.ignorer root details
|
||||
env@(Env _ _ projectType _ _ _ _ _) <- makeEnv Reporting.ignorer root details
|
||||
case Parse.fromByteString projectType source of
|
||||
Left syntaxError ->
|
||||
return $ Left $ Exit.ReplBadInput source $ Error.BadSyntax syntaxError
|
||||
@ -783,12 +785,12 @@ fromRepl root details source =
|
||||
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 =
|
||||
finalizeReplArtifacts env@(Env _ root projectType platform _ _ _ _) source modul@(Src.Module _ _ _ imports _ _ _ _ _) depsStatus resultMVars results =
|
||||
let pkg =
|
||||
projectTypeToPkg projectType
|
||||
|
||||
compileInput ifaces =
|
||||
case Compile.compile pkg ifaces modul of
|
||||
case Compile.compile platform 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
|
||||
@ -866,7 +868,7 @@ getRootInfo env path =
|
||||
else return (Left (Exit.BP_PathUnknown path))
|
||||
|
||||
getRootInfoHelp :: Env -> FilePath -> FilePath -> IO (Either Exit.BuildProjectProblem RootInfo)
|
||||
getRootInfoHelp (Env _ _ _ srcDirs _ _ _) path absolutePath =
|
||||
getRootInfoHelp (Env _ _ _ _ srcDirs _ _ _) path absolutePath =
|
||||
let (dirs, file) = FP.splitFileName absolutePath
|
||||
(final, ext) = FP.splitExtension file
|
||||
in if ext /= ".gren"
|
||||
@ -935,7 +937,7 @@ data RootStatus
|
||||
| SOutsideErr Error.Module
|
||||
|
||||
crawlRoot :: Env -> MVar StatusDict -> RootLocation -> IO RootStatus
|
||||
crawlRoot env@(Env _ _ projectType _ buildID _ _) mvar root =
|
||||
crawlRoot env@(Env _ _ projectType _ _ buildID _ _) mvar root =
|
||||
case root of
|
||||
LInside name ->
|
||||
do
|
||||
@ -968,7 +970,7 @@ data RootResult
|
||||
| ROutsideBlocked
|
||||
|
||||
checkRoot :: Env -> ResultDict -> RootStatus -> IO RootResult
|
||||
checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
|
||||
checkRoot env@(Env _ root _ _ _ _ _ _) results rootStatus =
|
||||
case rootStatus of
|
||||
SInside name ->
|
||||
return (RInside name)
|
||||
@ -995,10 +997,10 @@ checkRoot env@(Env _ root _ _ _ _ _) results rootStatus =
|
||||
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 =
|
||||
compileOutside (Env key _ projectType platform _ _ _ _) (Details.Local path time _ _ _ _) source ifaces modul =
|
||||
let pkg = projectTypeToPkg projectType
|
||||
name = Src.getName modul
|
||||
in case Compile.compile pkg ifaces modul of
|
||||
in case Compile.compile platform pkg ifaces modul of
|
||||
Right (Compile.Artifacts canonical annotations objects) ->
|
||||
do
|
||||
Reporting.report key Reporting.BDone
|
||||
@ -1013,7 +1015,7 @@ data Root
|
||||
| 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 =
|
||||
toArtifacts (Env _ root projectType _ _ _ _ _) foreigns results rootResults =
|
||||
case gatherProblemsOrMains results rootResults of
|
||||
Left (NE.List e es) ->
|
||||
Left (Exit.BuildBadModules root e es)
|
||||
|
@ -21,7 +21,7 @@ import BackgroundWriter qualified as BW
|
||||
import Compile qualified
|
||||
import Control.Concurrent (forkIO)
|
||||
import Control.Concurrent.MVar (MVar, newEmptyMVar, newMVar, putMVar, readMVar, takeMVar)
|
||||
import Control.Monad (liftM, liftM2)
|
||||
import Control.Monad (liftM2, liftM3)
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import Data.Either qualified as Either
|
||||
import Data.Map qualified as Map
|
||||
@ -43,6 +43,7 @@ import Gren.Kernel qualified as Kernel
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Outline qualified as Outline
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as P
|
||||
import Gren.Platform qualified as Platform
|
||||
import Gren.Version qualified as V
|
||||
import Json.Encode qualified as E
|
||||
@ -67,8 +68,8 @@ data Details = Details
|
||||
type BuildID = Word64
|
||||
|
||||
data ValidOutline
|
||||
= ValidApp (NE.List Outline.SrcDir)
|
||||
| ValidPkg Pkg.Name [ModuleName.Raw]
|
||||
= ValidApp P.Platform (NE.List Outline.SrcDir)
|
||||
| ValidPkg P.Platform Pkg.Name [ModuleName.Raw]
|
||||
|
||||
-- NOTE: we need two ways to detect if a file must be recompiled:
|
||||
--
|
||||
@ -190,7 +191,7 @@ verifyPkg env time (Outline.PkgOutline pkg _ _ _ exposed direct gren rootPlatfor
|
||||
then do
|
||||
solution <- verifyConstraints env rootPlatform (Map.map (Con.exactly . Con.lowerBound) direct)
|
||||
let exposedList = Outline.flattenExposed exposed
|
||||
verifyDependencies env time (ValidPkg pkg exposedList) solution direct
|
||||
verifyDependencies env time (ValidPkg rootPlatform pkg exposedList) solution direct
|
||||
else Task.throw $ Exit.DetailsBadGrenInPkg gren
|
||||
|
||||
verifyApp :: Env -> File.Time -> Outline.AppOutline -> Task Details
|
||||
@ -200,7 +201,7 @@ verifyApp env time outline@(Outline.AppOutline grenVersion rootPlatform srcDirs
|
||||
stated <- checkAppDeps outline
|
||||
actual <- verifyConstraints env rootPlatform (Map.map Con.exactly stated)
|
||||
if Map.size stated == Map.size actual
|
||||
then verifyDependencies env time (ValidApp srcDirs) actual direct
|
||||
then verifyDependencies env time (ValidApp rootPlatform srcDirs) actual direct
|
||||
else Task.throw Exit.DetailsHandEditedDependencies
|
||||
else Task.throw $ Exit.DetailsBadGrenInAppOutline grenVersion
|
||||
|
||||
@ -346,7 +347,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
do
|
||||
Reporting.report key Reporting.DBroken
|
||||
return $ Left $ Just $ Exit.BD_BadBuild pkg vsn f
|
||||
Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ _)) ->
|
||||
Right (Outline.Pkg (Outline.PkgOutline _ _ _ _ exposed deps _ platform)) ->
|
||||
do
|
||||
allDeps <- readMVar depsMVar
|
||||
directDeps <- traverse readMVar (Map.intersection allDeps deps)
|
||||
@ -374,7 +375,7 @@ build key cache depsMVar pkg (Solver.Details vsn _) f fs =
|
||||
Just statuses ->
|
||||
do
|
||||
rmvar <- newEmptyMVar
|
||||
rmvars <- traverse (fork . compile pkg rmvar) statuses
|
||||
rmvars <- traverse (fork . compile platform pkg rmvar) statuses
|
||||
putMVar rmvar rmvars
|
||||
maybeResults <- traverse readMVar rmvars
|
||||
case sequence maybeResults of
|
||||
@ -535,8 +536,8 @@ data Result
|
||||
| RKernelLocal [Kernel.Chunk]
|
||||
| RKernelForeign
|
||||
|
||||
compile :: Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
|
||||
compile pkg mvar status =
|
||||
compile :: P.Platform -> Pkg.Name -> MVar (Map.Map ModuleName.Raw (MVar (Maybe Result))) -> Status -> IO (Maybe Result)
|
||||
compile platform pkg mvar status =
|
||||
case status of
|
||||
SLocal docsStatus deps modul ->
|
||||
do
|
||||
@ -546,7 +547,7 @@ compile pkg mvar status =
|
||||
Nothing ->
|
||||
return Nothing
|
||||
Just results ->
|
||||
case Compile.compile pkg (Map.mapMaybe getInterface results) modul of
|
||||
case Compile.compile platform pkg (Map.mapMaybe getInterface results) modul of
|
||||
Left _ ->
|
||||
return Nothing
|
||||
Right (Compile.Artifacts canonical annotations objects) ->
|
||||
@ -626,15 +627,15 @@ instance Binary Details where
|
||||
instance Binary ValidOutline where
|
||||
put outline =
|
||||
case outline of
|
||||
ValidApp a -> putWord8 0 >> put a
|
||||
ValidPkg a b -> putWord8 1 >> put a >> put b
|
||||
ValidApp a b -> putWord8 0 >> put a >> put b
|
||||
ValidPkg a b c -> putWord8 1 >> put a >> put b >> put c
|
||||
|
||||
get =
|
||||
do
|
||||
n <- getWord8
|
||||
case n of
|
||||
0 -> liftM ValidApp get
|
||||
1 -> liftM2 ValidPkg get get
|
||||
0 -> liftM2 ValidApp get get
|
||||
1 -> liftM3 ValidPkg get get get
|
||||
_ -> fail "binary encoding of ValidOutline was corrupted"
|
||||
|
||||
instance Binary Local where
|
||||
|
@ -9,6 +9,7 @@ module Gren.Platform
|
||||
)
|
||||
where
|
||||
|
||||
import Data.Binary (Binary, get, getWord8, put, putWord8)
|
||||
import Data.Utf8 qualified as Utf8
|
||||
import Json.Decode qualified as D
|
||||
import Json.Encode qualified as E
|
||||
@ -50,3 +51,21 @@ fromString value =
|
||||
"browser" -> Just Browser
|
||||
"node" -> Just Node
|
||||
_ -> Nothing
|
||||
|
||||
-- BINARY
|
||||
|
||||
instance Binary Platform where
|
||||
put platform =
|
||||
case platform of
|
||||
Common -> putWord8 0
|
||||
Browser -> putWord8 1
|
||||
Node -> putWord8 2
|
||||
|
||||
get =
|
||||
do
|
||||
n <- getWord8
|
||||
case n of
|
||||
0 -> return Common
|
||||
1 -> return Browser
|
||||
2 -> return Node
|
||||
_ -> fail "binary encoding of Platform was corrupted"
|
||||
|
@ -1962,11 +1962,13 @@ data Make
|
||||
| MakeBadDetails Details
|
||||
| MakeAppNeedsFileNames
|
||||
| MakePkgNeedsExposing
|
||||
| MakeMultipleFilesIntoHtml
|
||||
| MakeMultipleFiles
|
||||
| MakeNoMain
|
||||
| MakeNonMainFilesIntoJavaScript ModuleName.Raw [ModuleName.Raw]
|
||||
| MakeCannotBuild BuildProblem
|
||||
| MakeBadGenerate Generate
|
||||
| MakeHtmlOnlyForBrowserPlatform
|
||||
| MakeExeOnlyForNodePlatform
|
||||
|
||||
makeToReport :: Make -> Help.Report
|
||||
makeToReport make =
|
||||
@ -2031,11 +2033,11 @@ makeToReport make =
|
||||
"You can also entries to the \"exposed-modules\" list in your gren.json file, and\
|
||||
\ I will try to compile the relevant files."
|
||||
]
|
||||
MakeMultipleFilesIntoHtml ->
|
||||
MakeMultipleFiles ->
|
||||
Help.report
|
||||
"TOO MANY FILES"
|
||||
Nothing
|
||||
( "When producing an HTML file, I can only handle one file."
|
||||
( "When producing an HTML file or executable, I can only handle one file."
|
||||
)
|
||||
[ D.fillSep
|
||||
[ "Switch",
|
||||
@ -2200,6 +2202,26 @@ makeToReport make =
|
||||
toBuildProblemReport buildProblem
|
||||
MakeBadGenerate generateProblem ->
|
||||
toGenerateReport generateProblem
|
||||
MakeHtmlOnlyForBrowserPlatform ->
|
||||
Help.report
|
||||
"HTML FILES CAN ONLY BE CREATED FOR BROWSER PLATFORM"
|
||||
Nothing
|
||||
( "When producing a HTML file, I require that the project platform is `browser`."
|
||||
)
|
||||
[ D.reflow $
|
||||
"Try changing the `target` value in `gren.json` to `browser`.\
|
||||
\ alternatively, pass a filename ending with `.js` to the compiler."
|
||||
]
|
||||
MakeExeOnlyForNodePlatform ->
|
||||
Help.report
|
||||
"EXECUTABLES CAN ONLY BE CREATED FOR NODE PLATFORM"
|
||||
Nothing
|
||||
( "When producing an executable, I require that the project platform is `node`."
|
||||
)
|
||||
[ D.reflow $
|
||||
"Try changing the `target` value in `gren.json` to `node`.\
|
||||
\ alternatively, pass a filename ending with `.js` to the compiler."
|
||||
]
|
||||
|
||||
-- BUILD PROBLEM
|
||||
|
||||
|
@ -117,7 +117,8 @@ data LocalGraph = LocalGraph
|
||||
}
|
||||
|
||||
data Main
|
||||
= Static
|
||||
= StaticString
|
||||
| StaticVDom
|
||||
| Dynamic
|
||||
{ _message :: Can.Type,
|
||||
_decoder :: Expr
|
||||
@ -339,15 +340,17 @@ instance Binary LocalGraph where
|
||||
instance Binary Main where
|
||||
put main =
|
||||
case main of
|
||||
Static -> putWord8 0
|
||||
Dynamic a b -> putWord8 1 >> put a >> put b
|
||||
StaticString -> putWord8 0
|
||||
StaticVDom -> putWord8 1
|
||||
Dynamic a b -> putWord8 2 >> put a >> put b
|
||||
|
||||
get =
|
||||
do
|
||||
word <- getWord8
|
||||
case word of
|
||||
0 -> return Static
|
||||
1 -> liftM2 Dynamic get get
|
||||
0 -> return StaticString
|
||||
1 -> return StaticVDom
|
||||
2 -> liftM2 Dynamic get get
|
||||
_ -> fail "problem getting Opt.Main binary"
|
||||
|
||||
instance Binary Node where
|
||||
|
@ -13,6 +13,7 @@ import Data.Name qualified as Name
|
||||
import Gren.Interface qualified as I
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Package qualified as Pkg
|
||||
import Gren.Platform qualified as P
|
||||
import Nitpick.PatternMatches qualified as PatternMatches
|
||||
import Optimize.Module qualified as Optimize
|
||||
import Reporting.Error qualified as E
|
||||
@ -30,13 +31,13 @@ data Artifacts = Artifacts
|
||||
_graph :: Opt.LocalGraph
|
||||
}
|
||||
|
||||
compile :: Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
|
||||
compile pkg ifaces modul =
|
||||
compile :: P.Platform -> Pkg.Name -> Map.Map ModuleName.Raw I.Interface -> Src.Module -> Either E.Error Artifacts
|
||||
compile platform pkg ifaces modul =
|
||||
do
|
||||
canonical <- canonicalize pkg ifaces modul
|
||||
annotations <- typeCheck modul canonical
|
||||
() <- nitpick canonical
|
||||
objects <- optimize modul annotations canonical
|
||||
objects <- optimize platform modul annotations canonical
|
||||
return (Artifacts canonical annotations objects)
|
||||
|
||||
-- PHASES
|
||||
@ -65,9 +66,9 @@ nitpick canonical =
|
||||
Left errors ->
|
||||
Left (E.BadPatterns errors)
|
||||
|
||||
optimize :: Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
|
||||
optimize modul annotations canonical =
|
||||
case snd $ R.run $ Optimize.optimize annotations canonical of
|
||||
optimize :: P.Platform -> Src.Module -> Map.Map Name.Name Can.Annotation -> Can.Module -> Either E.Error Opt.LocalGraph
|
||||
optimize platform modul annotations canonical =
|
||||
case snd $ R.run $ Optimize.optimize platform annotations canonical of
|
||||
Right localGraph ->
|
||||
Right localGraph
|
||||
Left errors ->
|
||||
|
@ -3,7 +3,6 @@
|
||||
module Generate.JavaScript
|
||||
( generate,
|
||||
generateForRepl,
|
||||
generateForReplEndpoint,
|
||||
)
|
||||
where
|
||||
|
||||
@ -43,7 +42,7 @@ generate mode (Opt.GlobalGraph graph _) mains =
|
||||
<> perfNote mode
|
||||
<> stateToBuilder state
|
||||
<> toMainExports mode mains
|
||||
<> "}(this));"
|
||||
<> "}(this.module ? this.module.exports : this));"
|
||||
|
||||
addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State
|
||||
addMain mode graph home _ state =
|
||||
@ -55,12 +54,10 @@ perfNote mode =
|
||||
Mode.Prod _ ->
|
||||
""
|
||||
Mode.Dev Nothing ->
|
||||
"console.warn('Compiled in DEV mode. Follow the advice at "
|
||||
<> B.stringUtf8 (D.makeNakedLink "optimize")
|
||||
"console.warn('Compiled in DEV mode. Compile with --optimize "
|
||||
<> " for better performance and smaller assets.');"
|
||||
Mode.Dev (Just _) ->
|
||||
"console.warn('Compiled in DEBUG mode. Follow the advice at "
|
||||
<> B.stringUtf8 (D.makeNakedLink "optimize")
|
||||
"console.warn('Compiled in DEV mode. Compile with --optimize "
|
||||
<> " for better performance and smaller assets.');"
|
||||
|
||||
-- GENERATE FOR REPL
|
||||
@ -100,39 +97,6 @@ print ansi localizer home name tipe =
|
||||
\ _print(' : ' + _type);\n\
|
||||
\}\n"
|
||||
|
||||
-- GENERATE FOR REPL ENDPOINT
|
||||
|
||||
generateForReplEndpoint :: L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Maybe Name.Name -> Can.Annotation -> B.Builder
|
||||
generateForReplEndpoint localizer (Opt.GlobalGraph graph _) home maybeName (Can.Forall _ tipe) =
|
||||
let name = maybe Name.replValueToPrint id maybeName
|
||||
mode = Mode.Dev Nothing
|
||||
debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString")
|
||||
evalState = addGlobal mode graph debugState (Opt.Global home name)
|
||||
in Functions.functions
|
||||
<> stateToBuilder evalState
|
||||
<> postMessage localizer home maybeName tipe
|
||||
|
||||
postMessage :: L.Localizer -> ModuleName.Canonical -> Maybe Name.Name -> Can.Type -> B.Builder
|
||||
postMessage localizer home maybeName tipe =
|
||||
let name = maybe Name.replValueToPrint id maybeName
|
||||
value = JsName.toBuilder (JsName.fromGlobal home name)
|
||||
toString = JsName.toBuilder (JsName.fromKernel Name.debug "toAnsiString")
|
||||
tipeDoc = RT.canToDoc localizer RT.None tipe
|
||||
toName n = "\"" <> Name.toBuilder n <> "\""
|
||||
in "self.postMessage({\n\
|
||||
\ name: "
|
||||
<> maybe "null" toName maybeName
|
||||
<> ",\n\
|
||||
\ value: "
|
||||
<> toString
|
||||
<> "(true, "
|
||||
<> value
|
||||
<> "),\n\
|
||||
\ type: "
|
||||
<> B.stringUtf8 (show (D.toString tipeDoc))
|
||||
<> "\n\
|
||||
\});\n"
|
||||
|
||||
-- GRAPH TRAVERSAL STATE
|
||||
|
||||
data State = State
|
||||
|
@ -749,7 +749,10 @@ pathToJsExpr mode root path =
|
||||
generateMain :: Mode.Mode -> ModuleName.Canonical -> Opt.Main -> JS.Expr
|
||||
generateMain mode home main =
|
||||
case main of
|
||||
Opt.Static ->
|
||||
Opt.StaticString ->
|
||||
JS.Ref (JsName.fromKernel Name.node "log")
|
||||
# JS.Ref (JsName.fromGlobal home "main")
|
||||
Opt.StaticVDom ->
|
||||
JS.Ref (JsName.fromKernel Name.virtualDom "init")
|
||||
# JS.Ref (JsName.fromGlobal home "main")
|
||||
# JS.Int 0
|
||||
|
33
compiler/src/Generate/Node.hs
Normal file
33
compiler/src/Generate/Node.hs
Normal file
@ -0,0 +1,33 @@
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
|
||||
module Generate.Node
|
||||
( sandwich,
|
||||
)
|
||||
where
|
||||
|
||||
import Data.ByteString.Builder qualified as B
|
||||
import Data.Name qualified as Name
|
||||
import Text.RawString.QQ (r)
|
||||
|
||||
-- SANDWICH
|
||||
|
||||
sandwich :: Name.Name -> B.Builder -> B.Builder
|
||||
sandwich moduleName javascript =
|
||||
let name = Name.toBuilder moduleName
|
||||
in [r|#!/usr/bin/env node
|
||||
|
||||
try {
|
||||
|]
|
||||
<> javascript
|
||||
<> [r|
|
||||
|]
|
||||
<> [r|this.Gren.|]
|
||||
<> name
|
||||
<> [r|.init({});
|
||||
}
|
||||
catch (e)
|
||||
{
|
||||
console.error(e);
|
||||
}
|
||||
|]
|
@ -17,6 +17,7 @@ import Data.Map qualified as Map
|
||||
import Data.Name qualified as Name
|
||||
import Data.Set qualified as Set
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Platform qualified as P
|
||||
import Optimize.Expression qualified as Expr
|
||||
import Optimize.Names qualified as Names
|
||||
import Optimize.Port qualified as Port
|
||||
@ -34,9 +35,9 @@ type Result i w a =
|
||||
type Annotations =
|
||||
Map.Map Name.Name Can.Annotation
|
||||
|
||||
optimize :: Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
|
||||
optimize annotations (Can.Module home _ _ decls unions _ _ effects) =
|
||||
addDecls home annotations decls $
|
||||
optimize :: P.Platform -> Annotations -> Can.Module -> Result i [W.Warning] Opt.LocalGraph
|
||||
optimize platform annotations (Can.Module home _ _ decls unions _ _ effects) =
|
||||
addDecls platform home annotations decls $
|
||||
addEffects home effects $
|
||||
addUnions home unions $
|
||||
Opt.LocalGraph Nothing Map.empty Map.empty
|
||||
@ -114,16 +115,16 @@ addToGraph name node fields (Opt.LocalGraph main nodes fieldCounts) =
|
||||
|
||||
-- ADD DECLS
|
||||
|
||||
addDecls :: ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
|
||||
addDecls home annotations decls graph =
|
||||
addDecls :: P.Platform -> ModuleName.Canonical -> Annotations -> Can.Decls -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
|
||||
addDecls platform home annotations decls graph =
|
||||
case decls of
|
||||
Can.Declare def subDecls ->
|
||||
addDecls home annotations subDecls =<< addDef home annotations def graph
|
||||
addDecls platform home annotations subDecls =<< addDef platform home annotations def graph
|
||||
Can.DeclareRec d ds subDecls ->
|
||||
let defs = d : ds
|
||||
in case findMain defs of
|
||||
Nothing ->
|
||||
addDecls home annotations subDecls (addRecDefs home defs graph)
|
||||
addDecls platform home annotations subDecls (addRecDefs home defs graph)
|
||||
Just region ->
|
||||
Result.throw $ E.BadCycle region (defToName d) (map defToName ds)
|
||||
Can.SaveTheEnvironment ->
|
||||
@ -149,19 +150,19 @@ defToName def =
|
||||
|
||||
-- ADD DEFS
|
||||
|
||||
addDef :: ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
|
||||
addDef home annotations def graph =
|
||||
addDef :: P.Platform -> ModuleName.Canonical -> Annotations -> Can.Def -> Opt.LocalGraph -> Result i [W.Warning] Opt.LocalGraph
|
||||
addDef platform home annotations def graph =
|
||||
case def of
|
||||
Can.Def (A.At region name) args body ->
|
||||
do
|
||||
let (Can.Forall _ tipe) = annotations ! name
|
||||
Result.warn $ W.MissingTypeAnnotation region name tipe
|
||||
addDefHelp region annotations home name args body graph
|
||||
addDefHelp platform region annotations home name args body graph
|
||||
Can.TypedDef (A.At region name) _ typedArgs body _ ->
|
||||
addDefHelp region annotations home name (map fst typedArgs) body graph
|
||||
addDefHelp platform region annotations home name (map fst typedArgs) body graph
|
||||
|
||||
addDefHelp :: A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
|
||||
addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
|
||||
addDefHelp :: P.Platform -> A.Region -> Annotations -> ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.LocalGraph -> Result i w Opt.LocalGraph
|
||||
addDefHelp platform region annotations home name args body graph@(Opt.LocalGraph _ nodes fieldCounts) =
|
||||
if name /= Name._main
|
||||
then Result.ok (addDefNode home name args body Set.empty graph)
|
||||
else
|
||||
@ -171,12 +172,18 @@ addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes
|
||||
addDefNode home name args body deps $
|
||||
Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts)
|
||||
in case Type.deepDealias tipe of
|
||||
Can.TType hm nm [_]
|
||||
| hm == ModuleName.virtualDom && nm == Name.node ->
|
||||
Can.TType hm nm []
|
||||
| platform == P.Node && hm == ModuleName.string && nm == Name.string ->
|
||||
Result.ok $
|
||||
addMain $
|
||||
Names.run $
|
||||
Names.registerKernel Name.virtualDom Opt.Static
|
||||
Names.registerKernel Name.node Opt.StaticString
|
||||
Can.TType hm nm [_]
|
||||
| platform == P.Browser && hm == ModuleName.virtualDom && nm == Name.node ->
|
||||
Result.ok $
|
||||
addMain $
|
||||
Names.run $
|
||||
Names.registerKernel Name.virtualDom Opt.StaticVDom
|
||||
Can.TType hm nm [flags, _, message] | hm == ModuleName.platform && nm == Name.program ->
|
||||
case Effects.checkPayload flags of
|
||||
Right () ->
|
||||
@ -187,7 +194,10 @@ addDefHelp region annotations home name args body graph@(Opt.LocalGraph _ nodes
|
||||
Left (subType, invalidPayload) ->
|
||||
Result.throw (E.BadFlags region subType invalidPayload)
|
||||
_ ->
|
||||
Result.throw (E.BadType region tipe)
|
||||
case platform of
|
||||
P.Browser -> Result.throw (E.BadType region tipe ["Html", "Svg", "Program"])
|
||||
P.Node -> Result.throw (E.BadType region tipe ["String", "Program"])
|
||||
P.Common -> Result.throw (E.BadType region tipe [])
|
||||
|
||||
addDefNode :: ModuleName.Canonical -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph
|
||||
addDefNode home name args body mainDeps graph =
|
||||
|
@ -8,6 +8,7 @@ module Reporting.Error.Main
|
||||
where
|
||||
|
||||
import AST.Canonical qualified as Can
|
||||
import Data.List qualified as List
|
||||
import Data.Name qualified as Name
|
||||
import Reporting.Annotation qualified as A
|
||||
import Reporting.Doc qualified as D
|
||||
@ -20,7 +21,7 @@ import Reporting.Report qualified as Report
|
||||
-- ERROR
|
||||
|
||||
data Error
|
||||
= BadType A.Region Can.Type
|
||||
= BadType A.Region Can.Type [String]
|
||||
| BadCycle A.Region Name.Name [Name.Name]
|
||||
| BadFlags A.Region Can.Type E.InvalidPayload
|
||||
|
||||
@ -29,7 +30,7 @@ data Error
|
||||
toReport :: L.Localizer -> Code.Source -> Error -> Report.Report
|
||||
toReport localizer source err =
|
||||
case err of
|
||||
BadType region tipe ->
|
||||
BadType region tipe allowed ->
|
||||
Report.Report "BAD MAIN TYPE" region [] $
|
||||
Code.toSnippet
|
||||
source
|
||||
@ -39,9 +40,7 @@ toReport localizer source err =
|
||||
D.stack
|
||||
[ "The type of `main` value I am seeing is:",
|
||||
D.indent 4 $ D.dullyellow $ RT.canToDoc localizer RT.None tipe,
|
||||
D.reflow $
|
||||
"I only know how to handle Html, Svg, and Programs\
|
||||
\ though. Modify `main` to be one of those types of values!"
|
||||
D.reflow $ "But I only know how to handle these types: " ++ List.intercalate ", " allowed
|
||||
]
|
||||
)
|
||||
BadCycle region name names ->
|
||||
|
@ -134,6 +134,7 @@ Common gren-common
|
||||
Canonicalize.Type
|
||||
Compile
|
||||
Generate.Html
|
||||
Generate.Node
|
||||
Generate.JavaScript
|
||||
Generate.JavaScript.Builder
|
||||
Generate.JavaScript.Expression
|
||||
|
@ -154,9 +154,9 @@ generateDocs (Env maybeRoot _) =
|
||||
Details.load Reporting.silent scope root
|
||||
|
||||
case Details._outline details of
|
||||
Details.ValidApp _ ->
|
||||
Details.ValidApp _ _ ->
|
||||
Task.throw Exit.DiffApplication
|
||||
Details.ValidPkg _ exposed ->
|
||||
Details.ValidPkg _ _ exposed ->
|
||||
case exposed of
|
||||
[] ->
|
||||
Task.throw Exit.DiffNoExposed
|
||||
|
@ -21,8 +21,10 @@ import Directories qualified as Dirs
|
||||
import File qualified
|
||||
import Generate qualified
|
||||
import Generate.Html qualified as Html
|
||||
import Generate.Node qualified as Node
|
||||
import Gren.Details qualified as Details
|
||||
import Gren.ModuleName qualified as ModuleName
|
||||
import Gren.Platform qualified as Platform
|
||||
import Reporting qualified
|
||||
import Reporting.Exit qualified as Exit
|
||||
import Reporting.Task qualified as Task
|
||||
@ -42,7 +44,8 @@ data Flags = Flags
|
||||
}
|
||||
|
||||
data Output
|
||||
= JS FilePath
|
||||
= Exe FilePath
|
||||
| JS FilePath
|
||||
| Html FilePath
|
||||
| DevNull
|
||||
| DevStdOut
|
||||
@ -72,6 +75,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
|
||||
do
|
||||
desiredMode <- getMode debug optimize
|
||||
details <- Task.eio Exit.MakeBadDetails (Details.load style scope root)
|
||||
let platform = getPlatform details
|
||||
case paths of
|
||||
[] ->
|
||||
do
|
||||
@ -82,17 +86,21 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
|
||||
artifacts <- buildPaths style root details (NE.List p ps)
|
||||
case maybeOutput of
|
||||
Nothing ->
|
||||
case getMains artifacts of
|
||||
[] ->
|
||||
case (platform, getMains artifacts) of
|
||||
(_, []) ->
|
||||
return ()
|
||||
[name] ->
|
||||
(Platform.Browser, [name]) ->
|
||||
do
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style "index.html" (Html.sandwich name builder) (NE.List name [])
|
||||
name : names ->
|
||||
(Platform.Node, [name]) ->
|
||||
do
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style "gren.js" builder (NE.List name names)
|
||||
generate style "app" (Node.sandwich name builder) (NE.List name [])
|
||||
(_, name : names) ->
|
||||
do
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style "index.js" builder (NE.List name names)
|
||||
Just DevStdOut ->
|
||||
case getMains artifacts of
|
||||
[] ->
|
||||
@ -103,19 +111,29 @@ runHelp root paths style (Flags debug optimize maybeOutput _ maybeDocs) =
|
||||
Task.io $ B.hPutBuilder IO.stdout builder
|
||||
Just DevNull ->
|
||||
return ()
|
||||
Just (Exe target) ->
|
||||
case platform of
|
||||
Platform.Node -> do
|
||||
name <- hasOneMain artifacts
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style target (Node.sandwich name builder) (NE.List name [])
|
||||
_ -> do
|
||||
Task.throw Exit.MakeExeOnlyForNodePlatform
|
||||
Just (JS target) ->
|
||||
case getNoMains artifacts of
|
||||
[] ->
|
||||
do
|
||||
[] -> do
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style target builder (Build.getRootNames artifacts)
|
||||
name : names ->
|
||||
Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names)
|
||||
Just (Html target) ->
|
||||
do
|
||||
case platform of
|
||||
Platform.Browser -> do
|
||||
name <- hasOneMain artifacts
|
||||
builder <- toBuilder root details desiredMode artifacts
|
||||
generate style target (Html.sandwich name builder) (NE.List name [])
|
||||
_ -> do
|
||||
Task.throw Exit.MakeHtmlOnlyForBrowserPlatform
|
||||
|
||||
-- GET INFORMATION
|
||||
|
||||
@ -136,13 +154,21 @@ getMode debug optimize =
|
||||
getExposed :: Details.Details -> Task (NE.List ModuleName.Raw)
|
||||
getExposed (Details.Details _ validOutline _ _ _ _) =
|
||||
case validOutline of
|
||||
Details.ValidApp _ ->
|
||||
Details.ValidApp _ _ ->
|
||||
Task.throw Exit.MakeAppNeedsFileNames
|
||||
Details.ValidPkg _ exposed ->
|
||||
Details.ValidPkg _ _ exposed ->
|
||||
case exposed of
|
||||
[] -> Task.throw Exit.MakePkgNeedsExposing
|
||||
m : ms -> return (NE.List m ms)
|
||||
|
||||
getPlatform :: Details.Details -> Platform.Platform
|
||||
getPlatform (Details.Details _ validOutline _ _ _ _) = do
|
||||
case validOutline of
|
||||
Details.ValidApp platform _ ->
|
||||
platform
|
||||
Details.ValidPkg platform _ _ ->
|
||||
platform
|
||||
|
||||
-- BUILD PROJECTS
|
||||
|
||||
buildExposed :: Reporting.Style -> FilePath -> Details.Details -> Maybe FilePath -> NE.List ModuleName.Raw -> Task ()
|
||||
@ -188,7 +214,7 @@ hasOneMain :: Build.Artifacts -> Task ModuleName.Raw
|
||||
hasOneMain (Build.Artifacts _ _ roots modules) =
|
||||
case roots of
|
||||
NE.List root [] -> Task.mio Exit.MakeNoMain (return $ getMain modules root)
|
||||
NE.List _ (_ : _) -> Task.throw Exit.MakeMultipleFilesIntoHtml
|
||||
NE.List _ (_ : _) -> Task.throw Exit.MakeMultipleFiles
|
||||
|
||||
-- GET MAINLESS
|
||||
|
||||
@ -258,6 +284,7 @@ parseOutput name
|
||||
| isDevNull name = Just DevNull
|
||||
| hasExt ".html" name = Just (Html name)
|
||||
| hasExt ".js" name = Just (JS name)
|
||||
| noExt name = Just (Exe name)
|
||||
| otherwise = Nothing
|
||||
|
||||
docsFile :: Parser FilePath
|
||||
@ -274,6 +301,10 @@ hasExt :: String -> String -> Bool
|
||||
hasExt ext path =
|
||||
FP.takeExtension path == ext && length path > length ext
|
||||
|
||||
noExt :: String -> Bool
|
||||
noExt path =
|
||||
FP.takeExtension path == ""
|
||||
|
||||
isDevNull :: String -> Bool
|
||||
isDevNull name =
|
||||
name == "/dev/null" || name == "NUL" || name == "$null"
|
||||
|
@ -138,9 +138,9 @@ verifyBuild root =
|
||||
|
||||
exposed <-
|
||||
case outline of
|
||||
Details.ValidApp _ -> Task.throw Exit.PublishApplication
|
||||
Details.ValidPkg _ [] -> Task.throw Exit.PublishNoExposed
|
||||
Details.ValidPkg _ (e : es) -> return (NE.List e es)
|
||||
Details.ValidApp _ _ -> Task.throw Exit.PublishApplication
|
||||
Details.ValidPkg _ _ [] -> Task.throw Exit.PublishNoExposed
|
||||
Details.ValidPkg _ _ (e : es) -> return (NE.List e es)
|
||||
|
||||
Task.eio Exit.PublishBuildProblem $
|
||||
Build.fromExposed Reporting.silent root details Build.KeepDocs exposed
|
||||
|
Loading…
Reference in New Issue
Block a user