diff --git a/.github/workflows/releases.yml b/.github/workflows/releases.yml index 7aae064b..d9de94c2 100644 --- a/.github/workflows/releases.yml +++ b/.github/workflows/releases.yml @@ -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 diff --git a/.github/workflows/verify.yml b/.github/workflows/verify.yml index c2153163..9dab4e10 100644 --- a/.github/workflows/verify.yml +++ b/.github/workflows/verify.yml @@ -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 diff --git a/README.md b/README.md index ae3dc32d..2a3c25a9 100644 --- a/README.md +++ b/README.md @@ -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. diff --git a/builder/src/Build.hs b/builder/src/Build.hs index 02af0568..61f2d29e 100644 --- a/builder/src/Build.hs +++ b/builder/src/Build.hs @@ -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) diff --git a/builder/src/Gren/Details.hs b/builder/src/Gren/Details.hs index 09e02472..b8d036be 100644 --- a/builder/src/Gren/Details.hs +++ b/builder/src/Gren/Details.hs @@ -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 diff --git a/builder/src/Gren/Platform.hs b/builder/src/Gren/Platform.hs index eb019bdb..4dd2b096 100644 --- a/builder/src/Gren/Platform.hs +++ b/builder/src/Gren/Platform.hs @@ -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" diff --git a/builder/src/Reporting/Exit.hs b/builder/src/Reporting/Exit.hs index d1bf17da..c348dd20 100644 --- a/builder/src/Reporting/Exit.hs +++ b/builder/src/Reporting/Exit.hs @@ -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 diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index cc321b0c..32f8c24f 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -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 diff --git a/compiler/src/Compile.hs b/compiler/src/Compile.hs index 89a48e0c..d4329b13 100644 --- a/compiler/src/Compile.hs +++ b/compiler/src/Compile.hs @@ -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 -> diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 7ec3a914..865121b9 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -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 diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 07418083..0f0ecce4 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -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 diff --git a/compiler/src/Generate/Node.hs b/compiler/src/Generate/Node.hs new file mode 100644 index 00000000..2c51897d --- /dev/null +++ b/compiler/src/Generate/Node.hs @@ -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); +} +|] diff --git a/compiler/src/Optimize/Module.hs b/compiler/src/Optimize/Module.hs index 967017e2..0f27a0ad 100644 --- a/compiler/src/Optimize/Module.hs +++ b/compiler/src/Optimize/Module.hs @@ -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 = diff --git a/compiler/src/Reporting/Error/Main.hs b/compiler/src/Reporting/Error/Main.hs index f4135922..90e38a51 100644 --- a/compiler/src/Reporting/Error/Main.hs +++ b/compiler/src/Reporting/Error/Main.hs @@ -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 -> diff --git a/gren.cabal b/gren.cabal index 7b81ad4d..7b5416d6 100644 --- a/gren.cabal +++ b/gren.cabal @@ -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 diff --git a/terminal/src/Diff.hs b/terminal/src/Diff.hs index fdf8e1e3..96692061 100644 --- a/terminal/src/Diff.hs +++ b/terminal/src/Diff.hs @@ -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 diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index b9878ee5..c051da95 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -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" diff --git a/terminal/src/Publish.hs b/terminal/src/Publish.hs index 92a4568c..62037975 100644 --- a/terminal/src/Publish.hs +++ b/terminal/src/Publish.hs @@ -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