gren-lang/compiler
1
1
Fork 0
mirror of https://github.com/gren-lang/compiler.git synced 2024-08-16 12:00:22 +03:00
Code Issues Actions 1 Packages Projects Releases Wiki Activity

Merge remote-tracking branch 'origin/main' into format

Browse Source
This commit is contained in:
Aaron VonderHaar 2022-09-06 23:53:16 -07:00
commit 643ec67b88
18 changed files with 234 additions and 139 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
.github/workflows/releases.yml vendored
View File

@ -32,7 +32,7 @@ jobs:
id: setup-haskell
with:
ghc-version: '9.2.4'
cabal-version: '3.6'
cabal-version: '3.8.1.0'
- name: Cache
uses: actions/cache@v2

4
.github/workflows/verify.yml vendored
View File

@ -21,7 +21,7 @@ jobs:
id: setup-haskell
with:
ghc-version: '9.2.4'
cabal-version: '3.6'
cabal-version: '3.8.1.0'
- name: Cache
uses: actions/cache@v2
@ -30,7 +30,7 @@ jobs:
key: cabal-${{ runner.os }}-${{ hashFiles('*.cabal') }}
- name: Build
run: cabal build -f dev
run: cabal build -f dev --enable-tests
- name: Tests
run: cabal test -f dev

12
README.md
View File

@ -1,13 +1,15 @@
# Gren
Compiler for the Gren programming language.
Compiler for the Gren, a pure functional programming language that is easy to learn, but powerful in use.
If you wish to install the compiler, you might want to read the [setup instructions](https://gren-lang.org/install).
There are easier ways to install the compiler than compiling the source, you might want to read the [setup instructions](https://gren-lang.org/install).
## Build from source
Then Gren compiler is written in Haskell, so to build from source you need to have GHC 9.2.2 (haskell compiler) and cabal 3.6 (haskell build tool) installed on your system.
Then Gren compiler is written in Haskell, so to build from source you need to have GHC 9.2 (Haskell compiler) and Cabal 3.8 (haskell build tool) installed on your system.
Compiling the project should just be a matter of running `cabal build`, or `cabal install` if you wish to install the compiler on your machine.
You can install these using [ghcup](https://www.haskell.org/ghcup/). By default, ghcup will install an older version of Haskell and Cabal, so you can install and set the required versions using `ghcup tui`.
Read the [CONTRIBUTING.md]() file for some helpful commands for working on the compiler itself.
Compiling and installing the project should just be a matter of `cabal install`, after which you should be able to run the `gren` command from your command line.
Read the `CONTRIBUTING.md` file for some helpful commands for working on the compiler itself.

40
builder/src/Build.hs
View File

@ -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)

29
builder/src/Gren/Details.hs
View File

@ -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

19
builder/src/Gren/Platform.hs
View File

@ -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"

28
builder/src/Reporting/Exit.hs
View File

@ -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

13
compiler/src/AST/Optimized.hs
View File

@ -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
compiler/src/Compile.hs
View File

@ -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 ->

42
compiler/src/Generate/JavaScript.hs
View File

@ -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

5
compiler/src/Generate/JavaScript/Expression.hs
View File

@ -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
View 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);
}
|]

44
compiler/src/Optimize/Module.hs
View File

@ -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 =

9
compiler/src/Reporting/Error/Main.hs
View File

@ -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 ->

5
gren.cabal
View File

@ -138,6 +138,7 @@ Common gren-common
Canonicalize.Type
Compile
Generate.Html
Generate.Node
Generate.JavaScript
Generate.JavaScript.Builder
Generate.JavaScript.Expression
@ -220,6 +221,8 @@ Executable gren
Import:
gren-common
default-language: GHC2021
Main-Is:
Main.hs
@ -227,6 +230,8 @@ Test-Suite gren-tests
Import:
gren-common
default-language: GHC2021
Type:
exitcode-stdio-1.0

4
terminal/src/Diff.hs
View File

@ -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

65
terminal/src/Make.hs
View File

@ -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
builder <- toBuilder root details desiredMode artifacts
generate style target builder (Build.getRootNames artifacts)
[] -> 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
name <- hasOneMain artifacts
builder <- toBuilder root details desiredMode artifacts
generate style target (Html.sandwich name builder) (NE.List name [])
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"

6
terminal/src/Publish.hs
View File

@ -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