diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs index 7efd25f87..332814d83 100644 --- a/builder/src/Generate.hs +++ b/builder/src/Generate.hs @@ -37,7 +37,7 @@ import Prelude hiding (cycle, print) type Task a = Task.Task Exit.Generate a -debug :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder +debug :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult debug root details (Build.Artifacts pkg ifaces roots modules) = do loading <- loadObjects root details modules @@ -48,7 +48,7 @@ debug root details (Build.Artifacts pkg ifaces roots modules) = let mains = gatherMains pkg objects roots return $ JS.generate mode graph mains -dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder +dev :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult dev root details (Build.Artifacts pkg _ roots modules) = do objects <- finalizeObjects =<< loadObjects root details modules @@ -57,7 +57,7 @@ dev root details (Build.Artifacts pkg _ roots modules) = let mains = gatherMains pkg objects roots return $ JS.generate mode graph mains -prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder +prod :: FilePath -> Details.Details -> Build.Artifacts -> Task JS.GeneratedResult prod root details (Build.Artifacts pkg _ roots modules) = do objects <- finalizeObjects =<< loadObjects root details modules diff --git a/builder/src/Gren/Outline.hs b/builder/src/Gren/Outline.hs index 9d87ce4d4..369caf7ae 100644 --- a/builder/src/Gren/Outline.hs +++ b/builder/src/Gren/Outline.hs @@ -20,6 +20,7 @@ module Gren.Outline sourceDirs, platform, dependencyConstraints, + getAllModulePaths, ) where @@ -27,10 +28,13 @@ import AbsoluteSrcDir (AbsoluteSrcDir) import AbsoluteSrcDir qualified import Control.Monad (filterM, liftM) import Data.Binary (Binary, get, getWord8, put, putWord8) +import Data.Function ((&)) import Data.List qualified as List import Data.Map qualified as Map +import Data.Name qualified as Name import Data.NonEmptyList qualified as NE import Data.OneOrMore qualified as OneOrMore +import Directories qualified import File qualified import Foreign.Ptr (minusPtr) import Gren.Constraint qualified as Con @@ -262,6 +266,68 @@ sourceDirs outline = Pkg _ -> NE.singleton (RelativeSrcDir "src") +-- getAllModulePaths + +getAllModulePaths :: FilePath -> IO (Map.Map ModuleName.Canonical FilePath) +getAllModulePaths root = + do + outlineResult <- read root + case outlineResult of + Left _ -> + return Map.empty + Right outline -> + case outline of + App appOutline -> + let deps = Map.union (_app_deps_direct appOutline) (_app_deps_indirect appOutline) + srcDirs = map (toAbsolute root) (NE.toList (_app_source_dirs appOutline)) + in getAllModulePathsHelper Pkg.dummyName srcDirs deps + Pkg pkgOutline -> + let deps = Map.map (PossibleFilePath.mapWith Con.lowerBound) (_pkg_deps pkgOutline) + in getAllModulePathsHelper (_pkg_name pkgOutline) [root "src"] deps + +getAllModulePathsHelper :: Pkg.Name -> [FilePath] -> Map.Map Pkg.Name (PossibleFilePath V.Version) -> IO (Map.Map ModuleName.Canonical FilePath) +getAllModulePathsHelper packageName packageSrcDirs deps = + do + grenFiles <- traverse recursiveFindGrenFiles packageSrcDirs + let asMap = Map.fromList $ map (\(root, fp) -> (ModuleName.Canonical packageName (moduleNameFromFilePath root fp), fp)) (concat grenFiles) + dependencyRoots <- Map.traverseWithKey resolvePackagePaths deps + dependencyMaps <- traverse (\(pkgName, pkgRoot) -> getAllModulePathsHelper pkgName [pkgRoot "src"] Map.empty) dependencyRoots + return $ foldr Map.union asMap dependencyMaps + +recursiveFindGrenFiles :: FilePath -> IO [(FilePath, FilePath)] +recursiveFindGrenFiles root = do + files <- recursiveFindGrenFilesHelp root + return $ map (\f -> (root, f)) files + +recursiveFindGrenFilesHelp :: FilePath -> IO [FilePath] +recursiveFindGrenFilesHelp root = + do + dirContents <- Dir.getDirectoryContents root + let (grenFiles, others) = List.partition (List.isSuffixOf ".gren") dirContents + subDirectories <- filterM (\fp -> Dir.doesDirectoryExist (root fp)) (filter (\fp -> fp /= "." && fp /= "..") others) + filesFromSubDirs <- traverse (recursiveFindGrenFilesHelp . (root )) subDirectories + return $ concat filesFromSubDirs ++ map (\fp -> root fp) grenFiles + +moduleNameFromFilePath :: FilePath -> FilePath -> Name.Name +moduleNameFromFilePath root filePath = + filePath + & drop (List.length root + 1) + & reverse + & drop 5 -- .gren + & reverse + & map (\c -> if c == '/' then '.' else c) + & Name.fromChars + +resolvePackagePaths :: Pkg.Name -> PossibleFilePath V.Version -> IO (Pkg.Name, FilePath) +resolvePackagePaths pkgName versionOrFilePath = + case versionOrFilePath of + PossibleFilePath.Other vsn -> + do + packageCache <- Directories.getPackageCache + return (pkgName, Directories.package packageCache pkgName vsn) + PossibleFilePath.Is filePath -> + return (pkgName, filePath) + -- JSON DECODE type Decoder a = diff --git a/compiler/src/AST/Canonical.hs b/compiler/src/AST/Canonical.hs index 9302f1360..0ae4145be 100644 --- a/compiler/src/AST/Canonical.hs +++ b/compiler/src/AST/Canonical.hs @@ -98,8 +98,8 @@ data Expr_ | Case Expr [CaseBranch] | Accessor Name | Access Expr (A.Located Name) - | Update Expr (Map.Map Name FieldUpdate) - | Record (Map.Map Name Expr) + | Update Expr (Map.Map (A.Located Name) FieldUpdate) + | Record (Map.Map (A.Located Name) Expr) deriving (Show) data CaseBranch diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index 32f8c24f4..d87d8a7d1 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -40,38 +40,38 @@ import Reporting.Annotation qualified as A -- EXPRESSIONS data Expr - = Bool Bool - | Chr ES.String - | Str ES.String - | Int Int - | Float EF.Float - | VarLocal Name - | VarGlobal Global - | VarEnum Global Index.ZeroBased - | VarBox Global - | VarCycle ModuleName.Canonical Name - | VarDebug Name ModuleName.Canonical A.Region (Maybe Name) - | VarKernel Name Name - | Array [Expr] - | Function [Name] Expr - | Call Expr [Expr] + = Bool A.Region Bool + | Chr A.Region ES.String + | Str A.Region ES.String + | Int A.Region Int + | Float A.Region EF.Float + | VarLocal A.Region Name + | VarGlobal A.Region Global + | VarEnum A.Region Global Index.ZeroBased + | VarBox A.Region Global + | VarCycle A.Region ModuleName.Canonical Name + | VarDebug A.Region Name ModuleName.Canonical (Maybe Name) + | VarKernel A.Region Name Name + | Array A.Region [Expr] + | Function [A.Located Name] Expr + | Call A.Region Expr [Expr] | TailCall Name [(Name, Expr)] | If [(Expr, Expr)] Expr | Let Def Expr | Destruct Destructor Expr | Case Name Name (Decider Choice) [(Int, Expr)] - | Accessor Name - | Access Expr Name - | Update Expr (Map.Map Name Expr) - | Record (Map.Map Name Expr) + | Accessor A.Region Name + | Access Expr A.Region Name + | Update A.Region Expr (Map.Map (A.Located Name) Expr) + | Record A.Region (Map.Map (A.Located Name) Expr) data Global = Global ModuleName.Canonical Name -- DEFINITIONS data Def - = Def Name Expr - | TailDef Name [Name] Expr + = Def A.Region Name Expr + | TailDef A.Region Name [A.Located Name] Expr data Destructor = Destructor Name Path @@ -125,8 +125,8 @@ data Main } data Node - = Define Expr (Set.Set Global) - | DefineTailFunc [Name] Expr (Set.Set Global) + = Define A.Region Expr (Set.Set Global) + | DefineTailFunc A.Region [A.Located Name] Expr (Set.Set Global) | Ctor Index.ZeroBased Int | Enum Index.ZeroBased | Box @@ -206,73 +206,73 @@ instance Binary Global where instance Binary Expr where put expr = case expr of - Bool a -> putWord8 0 >> put a - Chr a -> putWord8 1 >> put a - Str a -> putWord8 2 >> put a - Int a -> putWord8 3 >> put a - Float a -> putWord8 4 >> put a - VarLocal a -> putWord8 5 >> put a - VarGlobal a -> putWord8 6 >> put a - VarEnum a b -> putWord8 7 >> put a >> put b - VarBox a -> putWord8 8 >> put a - VarCycle a b -> putWord8 9 >> put a >> put b + Bool a b -> putWord8 0 >> put a >> put b + Chr a b -> putWord8 1 >> put a >> put b + Str a b -> putWord8 2 >> put a >> put b + Int a b -> putWord8 3 >> put a >> put b + Float a b -> putWord8 4 >> put a >> put b + VarLocal a b -> putWord8 5 >> put a >> put b + VarGlobal a b -> putWord8 6 >> put a >> put b + VarEnum a b c -> putWord8 7 >> put a >> put b >> put c + VarBox a b -> putWord8 8 >> put a >> put b + VarCycle a b c -> putWord8 9 >> put a >> put b >> put c VarDebug a b c d -> putWord8 10 >> put a >> put b >> put c >> put d - VarKernel a b -> putWord8 11 >> put a >> put b - Array a -> putWord8 12 >> put a + VarKernel a b c -> putWord8 11 >> put a >> put b >> put c + Array a b -> putWord8 12 >> put a >> put b Function a b -> putWord8 13 >> put a >> put b - Call a b -> putWord8 14 >> put a >> put b + Call a b c -> putWord8 14 >> put a >> put b >> put c TailCall a b -> putWord8 15 >> put a >> put b If a b -> putWord8 16 >> put a >> put b Let a b -> putWord8 17 >> put a >> put b Destruct a b -> putWord8 18 >> put a >> put b Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d - Accessor a -> putWord8 20 >> put a - Access a b -> putWord8 21 >> put a >> put b - Update a b -> putWord8 22 >> put a >> put b - Record a -> putWord8 23 >> put a + Accessor a b -> putWord8 20 >> put a >> put b + Access a b c -> putWord8 21 >> put a >> put b >> put c + Update a b c -> putWord8 22 >> put a >> put b >> put c + Record a b -> putWord8 23 >> put a >> put b get = do word <- getWord8 case word of - 0 -> liftM Bool get - 1 -> liftM Chr get - 2 -> liftM Str get - 3 -> liftM Int get - 4 -> liftM Float get - 5 -> liftM VarLocal get - 6 -> liftM VarGlobal get - 7 -> liftM2 VarEnum get get - 8 -> liftM VarBox get - 9 -> liftM2 VarCycle get get + 0 -> liftM2 Bool get get + 1 -> liftM2 Chr get get + 2 -> liftM2 Str get get + 3 -> liftM2 Int get get + 4 -> liftM2 Float get get + 5 -> liftM2 VarLocal get get + 6 -> liftM2 VarGlobal get get + 7 -> liftM3 VarEnum get get get + 8 -> liftM2 VarBox get get + 9 -> liftM3 VarCycle get get get 10 -> liftM4 VarDebug get get get get - 11 -> liftM2 VarKernel get get - 12 -> liftM Array get + 11 -> liftM3 VarKernel get get get + 12 -> liftM2 Array get get 13 -> liftM2 Function get get - 14 -> liftM2 Call get get + 14 -> liftM3 Call get get get 15 -> liftM2 TailCall get get 16 -> liftM2 If get get 17 -> liftM2 Let get get 18 -> liftM2 Destruct get get 19 -> liftM4 Case get get get get - 20 -> liftM Accessor get - 21 -> liftM2 Access get get - 22 -> liftM2 Update get get - 23 -> liftM Record get + 20 -> liftM2 Accessor get get + 21 -> liftM3 Access get get get + 22 -> liftM3 Update get get get + 23 -> liftM2 Record get get _ -> fail "problem getting Opt.Expr binary" instance Binary Def where put def = case def of - Def a b -> putWord8 0 >> put a >> put b - TailDef a b c -> putWord8 1 >> put a >> put b >> put c + Def a b c -> putWord8 0 >> put a >> put b >> put c + TailDef a b c d -> putWord8 1 >> put a >> put b >> put c >> put d get = do word <- getWord8 case word of - 0 -> liftM2 Def get get - 1 -> liftM3 TailDef get get get + 0 -> liftM3 Def get get get + 1 -> liftM4 TailDef get get get get _ -> fail "problem getting Opt.Def binary" instance Binary Destructor where @@ -356,8 +356,8 @@ instance Binary Main where instance Binary Node where put node = case node of - Define a b -> putWord8 0 >> put a >> put b - DefineTailFunc a b c -> putWord8 1 >> put a >> put b >> put c + Define a b c -> putWord8 0 >> put a >> put b >> put c + DefineTailFunc a b c d -> putWord8 1 >> put a >> put b >> put c >> put d Ctor a b -> putWord8 2 >> put a >> put b Enum a -> putWord8 3 >> put a Box -> putWord8 4 @@ -372,8 +372,8 @@ instance Binary Node where do word <- getWord8 case word of - 0 -> liftM2 Define get get - 1 -> liftM3 DefineTailFunc get get get + 0 -> liftM3 Define get get get + 1 -> liftM4 DefineTailFunc get get get get 2 -> liftM2 Ctor get get 3 -> liftM Enum get 4 -> return Box diff --git a/compiler/src/Canonicalize/Environment/Dups.hs b/compiler/src/Canonicalize/Environment/Dups.hs index 2106e5da3..07f0a67d6 100644 --- a/compiler/src/Canonicalize/Environment/Dups.hs +++ b/compiler/src/Canonicalize/Environment/Dups.hs @@ -1,10 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} - module Canonicalize.Environment.Dups ( detect, + detectLocated, checkFields, + checkLocatedFields, checkFields', + checkLocatedFields', Dict, none, one, @@ -14,7 +14,9 @@ module Canonicalize.Environment.Dups ) where +import Data.Function ((&)) import Data.Map qualified as Map +import Data.Maybe qualified as Maybe import Data.Name qualified as Name import Data.OneOrMore qualified as OneOrMore import Reporting.Annotation qualified as A @@ -40,6 +42,19 @@ detect :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map Name.Name detect toError dict = Map.traverseWithKey (detectHelp toError) dict +detectLocated :: ToError -> Dict a -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) a) +detectLocated toError dict = + let nameLocations = Map.mapMaybe extractLocation dict + in dict + & Map.mapKeys (\k -> A.At (Maybe.fromMaybe A.zero $ Map.lookup k nameLocations) k) + & Map.traverseWithKey (\(A.At _ name) values -> detectHelp toError name values) + +extractLocation :: OneOrMore.OneOrMore (Info a) -> Maybe A.Region +extractLocation oneOrMore = + case oneOrMore of + OneOrMore.One (Info region _) -> Just region + OneOrMore.More _ _ -> Nothing + detectHelp :: ToError -> Name.Name -> OneOrMore.OneOrMore (Info a) -> Result.Result i w Error.Error a detectHelp toError name values = case values of @@ -52,6 +67,10 @@ detectHelp toError name values = -- CHECK FIELDS +checkLocatedFields :: [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) a) +checkLocatedFields fields = + detectLocated Error.DuplicateField (foldr addField none fields) + checkFields :: [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map Name.Name a) checkFields fields = detect Error.DuplicateField (foldr addField none fields) @@ -60,6 +79,10 @@ addField :: (A.Located Name.Name, a, comments) -> Dict a -> Dict a addField (A.At region name, value, _) dups = Map.insertWith OneOrMore.more name (OneOrMore.one (Info region value)) dups +checkLocatedFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map (A.Located Name.Name) b) +checkLocatedFields' toValue fields = + detectLocated Error.DuplicateField (foldr (addField' toValue) none fields) + checkFields' :: (A.Region -> a -> b) -> [(A.Located Name.Name, a, comments)] -> Result.Result i w Error.Error (Map.Map Name.Name b) checkFields' toValue fields = detect Error.DuplicateField (foldr (addField' toValue) none fields) diff --git a/compiler/src/Canonicalize/Expression.hs b/compiler/src/Canonicalize/Expression.hs index a381b3584..7f6691f73 100644 --- a/compiler/src/Canonicalize/Expression.hs +++ b/compiler/src/Canonicalize/Expression.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} - module Canonicalize.Expression ( canonicalize, FreeLocals, @@ -112,16 +109,16 @@ canonicalize env (A.At region expression) = <*> Result.ok field Src.Update baseRecord fields _ -> let makeCanFields = - Dups.checkFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields + Dups.checkLocatedFields' (\r t -> Can.FieldUpdate r <$> canonicalize env t) fields in Can.Update - <$> (canonicalize env baseRecord) + <$> canonicalize env baseRecord <*> (sequenceA =<< makeCanFields) Src.Record fields -> do - fieldDict <- Dups.checkFields fields + fieldDict <- Dups.checkLocatedFields fields Can.Record <$> traverse (canonicalize env) fieldDict Src.Parens _ expr _ -> - A.toValue <$> (canonicalize env expr) + A.toValue <$> canonicalize env expr -- CANONICALIZE IF BRANCH diff --git a/compiler/src/Canonicalize/Type.hs b/compiler/src/Canonicalize/Type.hs index f480387e8..c71067b8a 100644 --- a/compiler/src/Canonicalize/Type.hs +++ b/compiler/src/Canonicalize/Type.hs @@ -1,6 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# OPTIONS_GHC -Wall #-} - module Canonicalize.Type ( toAnnotation, canonicalize, diff --git a/compiler/src/Generate/Html.hs b/compiler/src/Generate/Html.hs index ae29c69c7..762d42feb 100644 --- a/compiler/src/Generate/Html.hs +++ b/compiler/src/Generate/Html.hs @@ -3,6 +3,7 @@ module Generate.Html ( sandwich, + leadingLines, ) where @@ -10,7 +11,8 @@ import Data.ByteString.Builder qualified as B import Data.Name qualified as Name import Text.RawString.QQ (r) --- SANDWICH +leadingLines :: Int +leadingLines = 2 sandwich :: Name.Name -> B.Builder -> B.Builder sandwich moduleName javascript = diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 865121b9c..09db94e56 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -1,7 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} module Generate.JavaScript - ( generate, + ( GeneratedResult (..), + generate, generateForRepl, ) where @@ -9,6 +10,7 @@ where import AST.Canonical qualified as Can import AST.Optimized qualified as Opt import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy.Char8 qualified as BLazy import Data.Index qualified as Index import Data.List qualified as List import Data.Map ((!)) @@ -21,8 +23,10 @@ import Generate.JavaScript.Expression qualified as Expr import Generate.JavaScript.Functions qualified as Functions import Generate.JavaScript.Name qualified as JsName import Generate.Mode qualified as Mode +import Generate.SourceMap qualified as SourceMap import Gren.Kernel qualified as K import Gren.ModuleName qualified as ModuleName +import Reporting.Annotation qualified as A import Reporting.Doc qualified as D import Reporting.Render.Type qualified as RT import Reporting.Render.Type.Localizer qualified as L @@ -34,38 +38,44 @@ type Graph = Map.Map Opt.Global Opt.Node type Mains = Map.Map ModuleName.Canonical Opt.Main -generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder +data GeneratedResult = GeneratedResult + { _source :: B.Builder, + _sourceMap :: SourceMap.SourceMap + } + +prelude :: B.Builder +prelude = + "(function(scope){\n'use strict';" + <> Functions.functions + +firstGeneratedLineNumber :: Int +firstGeneratedLineNumber = + (fromIntegral $ BLazy.count '\n' $ B.toLazyByteString prelude) + 1 + +generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> GeneratedResult generate mode (Opt.GlobalGraph graph _) mains = - let state = Map.foldrWithKey (addMain mode graph) emptyState mains - in "(function(scope){\n'use strict';" - <> Functions.functions - <> perfNote mode - <> stateToBuilder state - <> toMainExports mode mains - <> "}(this.module ? this.module.exports : this));" + let state = Map.foldrWithKey (addMain mode graph) (emptyState firstGeneratedLineNumber) mains + builder = + prelude + <> stateToBuilder state + <> toMainExports mode mains + <> "}(this.module ? this.module.exports : this));" + sourceMap = SourceMap.wrap $ stateToMappings state + in GeneratedResult + { _source = builder, + _sourceMap = sourceMap + } addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State addMain mode graph home _ state = addGlobal mode graph state (Opt.Global home "main") -perfNote :: Mode.Mode -> B.Builder -perfNote mode = - case mode of - Mode.Prod _ -> - "" - Mode.Dev Nothing -> - "console.warn('Compiled in DEV mode. Compile with --optimize " - <> " for better performance and smaller assets.');" - Mode.Dev (Just _) -> - "console.warn('Compiled in DEV mode. Compile with --optimize " - <> " for better performance and smaller assets.');" - -- GENERATE FOR REPL generateForRepl :: Bool -> L.Localizer -> Opt.GlobalGraph -> ModuleName.Canonical -> Name.Name -> Can.Annotation -> B.Builder generateForRepl ansi localizer (Opt.GlobalGraph graph _) home name (Can.Forall _ tipe) = let mode = Mode.Dev Nothing - debugState = addGlobal mode graph emptyState (Opt.Global ModuleName.debug "toString") + debugState = addGlobal mode graph (emptyState 0) (Opt.Global ModuleName.debug "toString") evalState = addGlobal mode graph debugState (Opt.Global home name) in "process.on('uncaughtException', function(err) { process.stderr.write(err.toString() + '\\n'); process.exit(1); });" <> Functions.functions @@ -100,48 +110,47 @@ print ansi localizer home name tipe = -- GRAPH TRAVERSAL STATE data State = State - { _revKernels :: [B.Builder], - _revBuilders :: [B.Builder], - _seenGlobals :: Set.Set Opt.Global + { _seenGlobals :: Set.Set Opt.Global, + _builder :: JS.Builder } -emptyState :: State -emptyState = - State mempty [] Set.empty +emptyState :: Int -> State +emptyState startingLine = + State Set.empty (JS.emptyBuilder startingLine) stateToBuilder :: State -> B.Builder -stateToBuilder (State revKernels revBuilders _) = - prependBuilders revKernels (prependBuilders revBuilders mempty) +stateToBuilder (State _ builder) = + JS._code builder -prependBuilders :: [B.Builder] -> B.Builder -> B.Builder -prependBuilders revBuilders monolith = - List.foldl' (\m b -> b <> m) monolith revBuilders +stateToMappings :: State -> [JS.Mapping] +stateToMappings (State _ builder) = + JS._mappings builder -- ADD DEPENDENCIES addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State -addGlobal mode graph state@(State revKernels builders seen) global = +addGlobal mode graph state@(State seen builder) global = if Set.member global seen then state else addGlobalHelp mode graph global $ - State revKernels builders (Set.insert global seen) + State (Set.insert global seen) builder addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State -addGlobalHelp mode graph global state = +addGlobalHelp mode graph global@(Opt.Global home _) state = let addDeps deps someState = Set.foldl' (addGlobal mode graph) someState deps in case graph ! global of - Opt.Define expr deps -> + Opt.Define region expr deps -> addStmt (addDeps deps state) - ( var global (Expr.generate mode expr) + ( trackedVar region global (Expr.generate mode home expr) ) - Opt.DefineTailFunc argNames body deps -> + Opt.DefineTailFunc region argNames body deps -> addStmt (addDeps deps state) ( let (Opt.Global _ name) = global - in var global (Expr.generateTailDef mode name argNames body) + in trackedVar region global (Expr.generateTailDef mode home name argNames body) ) Opt.Ctor index arity -> addStmt @@ -160,7 +169,7 @@ addGlobalHelp mode graph global state = Opt.Kernel chunks deps -> if isDebugger global && not (Mode.isDebug mode) then state - else addKernel (addDeps deps state) (generateKernel mode chunks) + else addDeps deps (addKernel state (generateKernel mode chunks)) Opt.Enum index -> addStmt state @@ -183,21 +192,21 @@ addGlobalHelp mode graph global state = ) addStmt :: State -> JS.Stmt -> State -addStmt state stmt = - addBuilder state (JS.stmtToBuilder stmt) - -addBuilder :: State -> B.Builder -> State -addBuilder (State revKernels revBuilders seen) builder = - State revKernels (builder : revBuilders) seen +addStmt (State seen builder) stmt = + State seen (JS.stmtToBuilder stmt builder) addKernel :: State -> B.Builder -> State -addKernel (State revKernels revBuilders seen) kernel = - State (kernel : revKernels) revBuilders seen +addKernel (State seen builder) kernel = + State seen (JS.addByteString kernel builder) var :: Opt.Global -> Expr.Code -> JS.Stmt var (Opt.Global home name) code = JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr code) +trackedVar :: A.Region -> Opt.Global -> Expr.Code -> JS.Stmt +trackedVar (A.Region startPos _) (Opt.Global home name) code = + JS.TrackedVar home startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) (Expr.codeToExpr code) + isDebugger :: Opt.Global -> Bool isDebugger (Opt.Global (ModuleName.Canonical _ home) _) = home == Name.debugger @@ -232,15 +241,15 @@ generateCycle mode (Opt.Global home _) names values functions = generateCycleFunc :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt generateCycleFunc mode home def = case def of - Opt.Def name expr -> - JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode expr)) - Opt.TailDef name args expr -> - JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode name args expr)) + Opt.Def _ name expr -> + JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode home expr)) + Opt.TailDef _ name args expr -> + JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generateTailDef mode home name args expr)) generateSafeCycle :: Mode.Mode -> ModuleName.Canonical -> (Name.Name, Opt.Expr) -> JS.Stmt generateSafeCycle mode home (name, expr) = JS.FunctionStmt (JsName.fromCycle home name) [] $ - Expr.codeToStmtList (Expr.generate mode expr) + Expr.codeToStmtList (Expr.generate mode home expr) generateRealCycle :: ModuleName.Canonical -> (Name.Name, expr) -> JS.Stmt generateRealCycle home (name, _) = @@ -329,7 +338,7 @@ generatePort mode (Opt.Global home name) makePort converter = JS.Call (JS.Ref (JsName.fromKernel Name.platform makePort)) [ JS.String (Name.toBuilder name), - Expr.codeToExpr (Expr.generate mode converter) + Expr.codeToExpr (Expr.generate mode home converter) ] -- GENERATE MANAGER @@ -399,7 +408,7 @@ generateExports mode (Trie maybeMain subs) = "{" Just (home, main) -> "{'init':" - <> JS.exprToBuilder (Expr.generateMain mode home main) + <> JS._code (JS.exprToBuilder (Expr.generateMain mode home main) (JS.emptyBuilder 0)) <> end in case Map.toList subs of [] -> diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index b56eef623..6f9c95710 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -2,8 +2,12 @@ {-# OPTIONS_GHC -Wall #-} module Generate.JavaScript.Builder - ( stmtToBuilder, + ( Builder (..), + Mapping (..), + emptyBuilder, + stmtToBuilder, exprToBuilder, + addByteString, Expr (..), LValue (..), Stmt (..), @@ -19,46 +23,47 @@ where -- how all the types should fit together. import Data.ByteString qualified as BS -import Data.ByteString.Builder as B -import Data.List qualified as List +import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy.Char8 qualified as BSLazy +import Data.Function ((&)) +import Data.Word (Word16) import Generate.JavaScript.Name (Name) import Generate.JavaScript.Name qualified as Name +import Gren.ModuleName qualified as ModuleName import Json.Encode qualified as Json +import Reporting.Annotation qualified as A import Prelude hiding (lines) -- EXPRESSIONS --- NOTE: I tried making this create a B.Builder directly. --- --- The hope was that it'd allocate less and speed things up, but it seemed --- to be neutral for perf. --- --- The downside is that Generate.JavaScript.Expression inspects the --- structure of Expr and Stmt on some occassions to try to strip out --- unnecessary closures. I think these closures are already avoided --- by other logic in code gen these days, but I am not 100% certain. --- --- For this to be worth it, I think it would be necessary to avoid --- returning tuples when generating expressions. --- data Expr - = String Builder - | Float Builder + = String B.Builder + | TrackedString ModuleName.Canonical A.Position B.Builder + | Float B.Builder + | TrackedFloat ModuleName.Canonical A.Position B.Builder | Int Int + | TrackedInt ModuleName.Canonical A.Position Int | Bool Bool + | TrackedBool ModuleName.Canonical A.Position Bool | Null | Json Json.Value | Array [Expr] + | TrackedArray ModuleName.Canonical A.Region [Expr] | Object [(Name, Expr)] + | TrackedObject ModuleName.Canonical A.Region [(A.Located Name, Expr)] | Ref Name + | TrackedRef ModuleName.Canonical A.Position Name Name | Access Expr Name -- foo.bar + | TrackedAccess Expr ModuleName.Canonical A.Position Name | Index Expr Expr -- foo[bar] | Prefix PrefixOp Expr | Infix InfixOp Expr Expr | If Expr Expr Expr | Assign LValue Expr | Call Expr [Expr] + | TrackedNormalCall ModuleName.Canonical A.Position Expr Expr [Expr] | Function (Maybe Name) [Name] [Stmt] + | TrackedFunction ModuleName.Canonical [A.Located Name] [Stmt] data LValue = LRef Name @@ -81,6 +86,7 @@ data Stmt | Throw Expr | Return Expr | Var Name Expr + | TrackedVar ModuleName.Canonical A.Position Name Name Expr | Vars [(Name, Expr)] | FunctionStmt Name [Name] [Stmt] @@ -116,20 +122,158 @@ data PrefixOp | PrefixNegate -- - | PrefixComplement -- ~ +-- BUILDER + +data Builder = Builder + { _code :: B.Builder, + _currentLine :: Word16, + _currentCol :: Word16, + _mappings :: [Mapping] + } + +data Mapping = Mapping + { _m_src_line :: Word16, + _m_src_col :: Word16, + _m_src_module :: ModuleName.Canonical, + _m_src_name :: Maybe Name, + _m_gen_line :: Word16, + _m_gen_col :: Word16 + } + +emptyBuilder :: Int -> Builder +emptyBuilder currentLine = + Builder + { _code = mempty, + _currentLine = fromIntegral currentLine, + _currentCol = 1, + _mappings = [] + } + +addAscii :: String -> Builder -> Builder +addAscii code (Builder _code _currLine _currCol _mappings) = + Builder + { _code = _code <> B.string7 code, + _currentLine = _currLine, + _currentCol = _currCol + fromIntegral (length code), + _mappings = _mappings + } + +addByteString :: B.Builder -> Builder -> Builder +addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = + let lazyByteString = B.toLazyByteString bsBuilder + bsSize = BSLazy.length lazyByteString + bsLines = BSLazy.count '\n' lazyByteString + in if bsLines == 0 + then + Builder + { _code = _code <> bsBuilder, + _currentLine = _currLine, + _currentCol = _currCol + fromIntegral bsSize, + _mappings = _mappings + } + else + Builder + { _code = _code <> bsBuilder, + _currentLine = _currLine + fromIntegral bsLines, + _currentCol = 1, + _mappings = _mappings + } + +addTrackedByteString :: ModuleName.Canonical -> A.Position -> B.Builder -> Builder -> Builder +addTrackedByteString moduleName (A.Position line col) bsBuilder (Builder _code _currLine _currCol _mappings) = + let lazyByteString = B.toLazyByteString bsBuilder + bsSize = BSLazy.length lazyByteString + bsLines = BSLazy.count '\n' lazyByteString + newMappings = + ( Mapping + { _m_src_line = line, + _m_src_col = col, + _m_src_module = moduleName, + _m_src_name = Nothing, + _m_gen_line = _currLine, + _m_gen_col = _currCol + } + ) + : _mappings + in if bsLines == 0 + then + Builder + { _code = _code <> bsBuilder, + _currentLine = _currLine, + _currentCol = _currCol + fromIntegral bsSize, + _mappings = newMappings + } + else + Builder + { _code = _code <> bsBuilder, + _currentLine = _currLine + fromIntegral bsLines, + _currentCol = 1, + _mappings = newMappings + } + +addName :: ModuleName.Canonical -> A.Position -> Name -> Name -> Builder -> Builder +addName moduleName (A.Position line col) name genName (Builder _code _currLine _currCol _mappings) = + let nameBuilder = Name.toBuilder genName + size = BSLazy.length $ B.toLazyByteString nameBuilder + in Builder + { _code = _code <> nameBuilder, + _currentLine = _currLine, + _currentCol = _currCol + fromIntegral size, + _mappings = + ( Mapping + { _m_src_line = line, + _m_src_col = col, + _m_src_module = moduleName, + _m_src_name = Just name, + _m_gen_line = _currLine, + _m_gen_col = _currCol + } + ) + : _mappings + } + +addTrackedDot :: ModuleName.Canonical -> A.Position -> Builder -> Builder +addTrackedDot moduleName (A.Position line col) (Builder _code _currLine _currCol _mappings) = + Builder + { _code = _code <> B.string7 ".", + _currentLine = _currLine, + _currentCol = _currCol + 1, + _mappings = + ( Mapping + { _m_src_line = line, + _m_src_col = col, + _m_src_module = moduleName, + _m_src_name = Nothing, + _m_gen_line = _currLine, + _m_gen_col = _currCol + } + ) + : _mappings + } + +addLine :: Builder -> Builder +addLine (Builder _code _currLine _currCol _mappings) = + Builder + { _code = _code <> B.char7 '\n', + _currentLine = _currLine + 1, + _currentCol = 1, + _mappings = _mappings + } + -- ENCODE -stmtToBuilder :: Stmt -> Builder -stmtToBuilder stmts = - fromStmt levelZero stmts +stmtToBuilder :: Stmt -> Builder -> Builder +stmtToBuilder stmt builder = + fromStmt levelZero stmt builder -exprToBuilder :: Expr -> Builder -exprToBuilder expr = - snd $ fromExpr levelZero Whatever expr +exprToBuilder :: Expr -> Builder -> Builder +exprToBuilder expr builder = + fromExpr levelZero Whatever expr builder -- INDENT LEVEL data Level - = Level Builder Level + = Level B.Builder Level levelZero :: Level levelZero = @@ -143,309 +287,436 @@ makeLevel level oldTabs = else BS.replicate (BS.length oldTabs * 2) 0x09 {-\t-} in Level (B.byteString (BS.take level tabs)) (makeLevel (level + 1) tabs) --- HELPERS - -commaSep :: [Builder] -> Builder -commaSep builders = - mconcat (List.intersperse ", " builders) - -commaNewlineSep :: Level -> [Builder] -> Builder -commaNewlineSep (Level _ (Level deeperIndent _)) builders = - mconcat (List.intersperse (",\n" <> deeperIndent) builders) - -- STATEMENTS -fromStmtBlock :: Level -> [Stmt] -> Builder -fromStmtBlock level stmts = - mconcat (map (fromStmt level) stmts) +fromStmtBlock :: Level -> [Stmt] -> Builder -> Builder +fromStmtBlock level stmts builder = + foldl (\accBuilder stmt -> fromStmt level stmt accBuilder) builder stmts -fromStmt :: Level -> Stmt -> Builder -fromStmt level@(Level indent nextLevel) statement = +fromStmt :: Level -> Stmt -> Builder -> Builder +fromStmt level@(Level indent nextLevel) statement builder = case statement of Block stmts -> - fromStmtBlock level stmts + fromStmtBlock level stmts builder EmptyStmt -> - mempty + builder ExprStmt expr -> - indent <> snd (fromExpr level Whatever expr) <> ";\n" + builder + & addByteString indent + & fromExpr level Whatever expr + & addAscii ";" + & addLine IfStmt condition thenStmt elseStmt -> - mconcat - [ indent, - "if (", - snd (fromExpr level Whatever condition), - ") {\n", - fromStmt nextLevel thenStmt, - indent, - "} else {\n", - fromStmt nextLevel elseStmt, - indent, - "}\n" - ] + builder + & addByteString indent + & addAscii "if (" + & fromExpr level Whatever condition + & addAscii ") {" + & addLine + & fromStmt nextLevel thenStmt + & addByteString indent + & addAscii "} else {" + & addLine + & fromStmt nextLevel elseStmt + & addByteString indent + & addAscii "}" + & addLine Switch expr clauses -> - mconcat - [ indent, - "switch (", - snd (fromExpr level Whatever expr), - ") {\n", - mconcat (map (fromClause nextLevel) clauses), - indent, - "}\n" - ] + builder + & addByteString indent + & addAscii "switch (" + & fromExpr level Whatever expr + & addAscii ") {" + & addLine + & fromClauses nextLevel clauses + & addByteString indent + & addAscii "}" + & addLine While expr stmt -> - mconcat - [ indent, - "while (", - snd (fromExpr level Whatever expr), - ") {\n", - fromStmt nextLevel stmt, - indent, - "}\n" - ] + builder + & addByteString indent + & addAscii "while (" + & fromExpr level Whatever expr + & addAscii ") {" + & addLine + & fromStmt nextLevel stmt + & addByteString indent + & addAscii "}" + & addLine Break Nothing -> - indent <> "break;\n" + builder + & addByteString indent + & addAscii "break;" + & addLine Break (Just label) -> - indent <> "break " <> Name.toBuilder label <> ";\n" + builder + & addByteString indent + & addAscii "break " + & addByteString (Name.toBuilder label) + & addAscii ";" + & addLine Continue Nothing -> - indent <> "continue;\n" + builder + & addByteString indent + & addAscii "continue;" + & addLine Continue (Just label) -> - indent <> "continue " <> Name.toBuilder label <> ";\n" + builder + & addByteString indent + & addAscii "continue " + & addByteString (Name.toBuilder label) + & addAscii ";" + & addLine Labelled label stmt -> - mconcat - [ indent, - Name.toBuilder label, - ":\n", - fromStmt level stmt - ] + builder + & addByteString indent + & addByteString (Name.toBuilder label) + & addAscii ":" + & addLine + & fromStmt level stmt Try tryStmt errorName catchStmt -> - mconcat - [ indent, - "try {\n", - fromStmt nextLevel tryStmt, - indent, - "} catch (", - Name.toBuilder errorName, - ") {\n", - fromStmt nextLevel catchStmt, - indent, - "}\n" - ] + builder + & addByteString indent + & addAscii "try {" + & addLine + & fromStmt nextLevel tryStmt + & addByteString indent + & addAscii "} catch (" + & addByteString (Name.toBuilder errorName) + & addAscii ") {" + & addLine + & fromStmt nextLevel catchStmt + & addByteString indent + & addAscii "}" + & addLine Throw expr -> - indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";" + builder + & addByteString indent + & addAscii "throw " + & fromExpr level Whatever expr + & addAscii ";" Return expr -> - indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n" + builder + & addByteString indent + & addAscii "return " + & fromExpr level Whatever expr + & addAscii ";" + & addLine Var name expr -> - indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n" + builder + & addByteString indent + & addAscii "var " + & addByteString (Name.toBuilder name) + & addAscii " = " + & fromExpr level Whatever expr + & addAscii ";" + & addLine + TrackedVar moduleName pos name genName expr -> + builder + & addByteString indent + & addAscii "var " + & addName moduleName pos name genName + & addAscii " = " + & fromExpr level Whatever expr + & addAscii ";" + & addLine Vars [] -> - mempty + builder Vars vars -> - indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n" + builder + & addByteString indent + & addAscii "var " + & commaNewlineSepExpr level (varToBuilder level) vars + & addAscii ";" + & addLine FunctionStmt name args stmts -> - indent - <> "function " - <> Name.toBuilder name - <> "(" - <> commaSep (map Name.toBuilder args) - <> ") {\n" - <> fromStmtBlock nextLevel stmts - <> indent - <> "}\n" + builder + & addByteString indent + & addAscii "function " + & addByteString (Name.toBuilder name) + & addAscii "(" + & commaSepExpr (addByteString . Name.toBuilder) args + & addAscii ") {" + & addLine + & fromStmtBlock nextLevel stmts + & addByteString indent + & addAscii "}" + & addLine -- SWITCH CLAUSES -fromClause :: Level -> Case -> Builder -fromClause level@(Level indent nextLevel) clause = +fromClause :: Level -> Case -> Builder -> Builder +fromClause level@(Level indent nextLevel) clause builder = case clause of Case expr stmts -> - indent - <> "case " - <> snd (fromExpr level Whatever expr) - <> ":\n" - <> fromStmtBlock nextLevel stmts + builder + & addByteString indent + & addAscii "case " + & fromExpr level Whatever expr + & addAscii ":" + & addLine + & fromStmtBlock nextLevel stmts Default stmts -> - indent - <> "default:\n" - <> fromStmtBlock nextLevel stmts + builder + & addByteString indent + & addAscii "default:" + & addLine + & fromStmtBlock nextLevel stmts + +fromClauses :: Level -> [Case] -> Builder -> Builder +fromClauses level clauses builder = + case clauses of + [] -> + builder + first : rest -> + fromClauses level rest (fromClause level first builder) -- VAR DECLS -varToBuilder :: Level -> (Name, Expr) -> Builder -varToBuilder level (name, expr) = - Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) +varToBuilder :: Level -> (Name, Expr) -> Builder -> Builder +varToBuilder level (name, expr) builder = + builder + & addByteString (Name.toBuilder name) + & addAscii " = " + & fromExpr level Whatever expr -- EXPRESSIONS -data Lines = One | Many deriving (Eq) - -merge :: Lines -> Lines -> Lines -merge a b = - if a == Many || b == Many then Many else One - -linesMap :: (a -> (Lines, b)) -> [a] -> (Bool, [b]) -linesMap func xs = - let pairs = map func xs - in ( any ((==) Many . fst) pairs, - map snd pairs - ) +commaSepExpr :: (a -> Builder -> Builder) -> [a] -> Builder -> Builder +commaSepExpr fn exprs builder = + case exprs of + [] -> + builder + [first] -> + fn first builder + first : rest -> + commaSepExpr fn rest (addAscii ", " (fn first builder)) + +commaNewlineSepExpr :: Level -> (a -> Builder -> Builder) -> [a] -> Builder -> Builder +commaNewlineSepExpr level@(Level indent _) fn exprs builder = + case exprs of + [] -> + builder + [first] -> + fn first builder + first : rest -> + commaNewlineSepExpr level fn rest (addByteString indent (addLine (addAscii "," (fn first builder)))) data Grouping = Atomic | Whatever -parensFor :: Grouping -> Builder -> Builder -parensFor grouping builder = +parensFor :: Grouping -> Builder -> (Builder -> Builder) -> Builder +parensFor grouping builder fillContent = case grouping of Atomic -> - "(" <> builder <> ")" - Whatever -> builder + & addAscii "(" + & fillContent + & addAscii ")" + Whatever -> + fillContent builder -fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder) -fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression = +fromExpr :: Level -> Grouping -> Expr -> Builder -> Builder +fromExpr level@(Level indent nextLevel) grouping expression builder = case expression of String string -> - (One, "'" <> string <> "'") + addByteString ("'" <> string <> "'") builder + TrackedString moduleName position string -> + addTrackedByteString moduleName position ("'" <> string <> "'") builder Float float -> - (One, float) + addByteString float builder + TrackedFloat moduleName position float -> + addTrackedByteString moduleName position float builder Int n -> - (One, B.intDec n) + addByteString (B.intDec n) builder + TrackedInt moduleName position n -> + addTrackedByteString moduleName position (B.intDec n) builder Bool bool -> - (One, if bool then "true" else "false") + addAscii (if bool then "true" else "false") builder + TrackedBool moduleName position bool -> + addTrackedByteString moduleName position (if bool then "true" else "false") builder Null -> - (One, "null") + addAscii "null" builder Json json -> - (One, Json.encodeUgly json) + addByteString (Json.encodeUgly json) builder Array exprs -> - (,) Many $ - let (anyMany, builders) = linesMap (fromExpr level Whatever) exprs - in if anyMany - then - "[\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" - <> indent - <> "]" - else "[" <> commaSep builders <> "]" + builder + & addAscii "[ " + & commaSepExpr (fromExpr level Whatever) exprs + & addAscii " ]" + TrackedArray moduleName (A.Region start (A.Position endLine endCol)) exprs -> + builder + & addTrackedByteString moduleName start "[ " + & commaSepExpr (fromExpr level Whatever) exprs + & addAscii " " + & addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "]" Object fields -> - (,) Many $ - let (anyMany, builders) = linesMap (fromField nextLevel) fields - in if anyMany - then - "{\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" - <> indent - <> "}" - else "{" <> commaSep builders <> "}" + builder + & addAscii "{ " + & commaSepExpr (fromField level) fields + & addAscii " }" + TrackedObject moduleName (A.Region start (A.Position endLine endCol)) fields -> + builder + & addTrackedByteString moduleName start "{ " + & commaSepExpr (trackedFromField level moduleName) fields + & addAscii " " + & addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "}" Ref name -> - (One, Name.toBuilder name) + addByteString (Name.toBuilder name) builder + TrackedRef position moduleName name generatedName -> + addName position moduleName name generatedName builder Access expr field -> - makeDot level expr field + makeDot level expr field builder + TrackedAccess expr moduleName position@(A.Position fieldLine fieldCol) field -> + builder + & fromExpr level Atomic expr + & addTrackedDot moduleName (A.Position fieldLine (fieldCol - 1)) + & addName moduleName position field field Index expr bracketedExpr -> - makeBracketed level expr bracketedExpr + makeBracketed level expr bracketedExpr builder Prefix op expr -> - let (lines, builder) = fromExpr level Atomic expr - in ( lines, - parensFor grouping (fromPrefix op <> builder) - ) + parensFor grouping builder $ \b -> + b + & fromPrefix op + & fromExpr level Atomic expr Infix op leftExpr rightExpr -> - let (leftLines, left) = fromExpr level Atomic leftExpr - (rightLines, right) = fromExpr level Atomic rightExpr - in ( merge leftLines rightLines, - parensFor grouping (left <> fromInfix op <> right) - ) + parensFor grouping builder $ \b -> + b + & fromExpr level Atomic leftExpr + & fromInfix op + & fromExpr level Atomic rightExpr If condExpr thenExpr elseExpr -> - let condB = snd (fromExpr level Atomic condExpr) - thenB = snd (fromExpr level Atomic thenExpr) - elseB = snd (fromExpr level Atomic elseExpr) - in ( Many, - parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB) - ) + parensFor grouping builder $ \b -> + b + & fromExpr level Atomic condExpr + & addAscii " ? " + & fromExpr level Atomic thenExpr + & addAscii " : " + & fromExpr level Atomic elseExpr Assign lValue expr -> - let (leftLines, left) = fromLValue level lValue - (rightLines, right) = fromExpr level Whatever expr - in ( merge leftLines rightLines, - parensFor grouping (left <> " = " <> right) - ) + parensFor grouping builder $ \b -> + b + & fromLValue level lValue + & addAscii " = " + & fromExpr level Whatever expr Call function args -> - (,) Many $ - let (_, funcB) = fromExpr level Atomic function - (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args - in if anyMany - then funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")" - else funcB <> "(" <> commaSep argsB <> ")" + builder + & fromExpr level Atomic function + & addAscii "(" + & commaSepExpr (fromExpr nextLevel Whatever) args + & addAscii ")" + TrackedNormalCall position moduleName helper function args -> + let trackedHelper = + case (trackedNameFromExpr function, helper) of + (Just functionName, Ref helperName) -> + TrackedRef position moduleName functionName helperName + _ -> + helper + in builder + & fromExpr level Atomic trackedHelper + & addAscii "(" + & commaSepExpr (fromExpr nextLevel Whatever) (function : args) + & addAscii ")" Function maybeName args stmts -> - (,) Many $ - "function " - <> maybe mempty Name.toBuilder maybeName - <> "(" - <> commaSep (map Name.toBuilder args) - <> ") {\n" - <> fromStmtBlock nextLevel stmts - <> indent - <> "}" + builder + & addAscii "function " + & addByteString (maybe mempty Name.toBuilder maybeName) + & addAscii "(" + & commaSepExpr (addByteString . Name.toBuilder) args + & addAscii ") {" + & addLine + & fromStmtBlock nextLevel stmts + & addByteString indent + & addAscii "}" + TrackedFunction moduleName args stmts -> + builder + & addAscii "function" + & addAscii "(" + & commaSepExpr (\(A.At (A.Region start _) name) -> addName moduleName start name name) args + & addAscii ") {" + & addLine + & fromStmtBlock nextLevel stmts + & addByteString indent + & addAscii "}" + +trackedNameFromExpr :: Expr -> Maybe Name +trackedNameFromExpr expr = + case expr of + TrackedRef _ _ name _ -> Just name + _ -> Nothing -- FIELDS -fromField :: Level -> (Name, Expr) -> (Lines, Builder) -fromField level (field, expr) = - let (lines, builder) = fromExpr level Whatever expr - in ( lines, - Name.toBuilder field <> ": " <> builder - ) +fromField :: Level -> (Name, Expr) -> Builder -> Builder +fromField level (field, expr) builder = + builder + & addByteString (Name.toBuilder field) + & addAscii ": " + & fromExpr level Whatever expr + +trackedFromField :: Level -> ModuleName.Canonical -> (A.Located Name, Expr) -> Builder -> Builder +trackedFromField level moduleName (A.At (A.Region start end) field, expr) builder = + builder + & addName moduleName start field field + & addTrackedByteString moduleName end ": " + & fromExpr level Whatever expr -- VALUES -fromLValue :: Level -> LValue -> (Lines, Builder) -fromLValue level lValue = +fromLValue :: Level -> LValue -> Builder -> Builder +fromLValue level lValue builder = case lValue of LRef name -> - (One, Name.toBuilder name) + addByteString (Name.toBuilder name) builder LDot expr field -> - makeDot level expr field + makeDot level expr field builder LBracket expr bracketedExpr -> - makeBracketed level expr bracketedExpr - -makeDot :: Level -> Expr -> Name -> (Lines, Builder) -makeDot level expr field = - let (lines, builder) = fromExpr level Atomic expr - in (lines, builder <> "." <> Name.toBuilder field) - -makeBracketed :: Level -> Expr -> Expr -> (Lines, Builder) -makeBracketed level expr bracketedExpr = - let (lines, builder) = fromExpr level Atomic expr - (bracketedLines, bracketedBuilder) = fromExpr level Whatever bracketedExpr - in ( merge lines bracketedLines, - builder <> "[" <> bracketedBuilder <> "]" - ) + makeBracketed level expr bracketedExpr builder + +makeDot :: Level -> Expr -> Name -> Builder -> Builder +makeDot level expr field builder = + builder + & fromExpr level Atomic expr + & addAscii "." + & addByteString (Name.toBuilder field) + +makeBracketed :: Level -> Expr -> Expr -> Builder -> Builder +makeBracketed level expr bracketedExpr builder = + builder + & fromExpr level Atomic expr + & addAscii "[" + & fromExpr level Whatever bracketedExpr + & addAscii "]" -- OPERATORS -fromPrefix :: PrefixOp -> Builder +fromPrefix :: PrefixOp -> Builder -> Builder fromPrefix op = - case op of - PrefixNot -> "!" - PrefixNegate -> "-" - PrefixComplement -> "~" + addAscii $ + case op of + PrefixNot -> "!" + PrefixNegate -> "-" + PrefixComplement -> "~" -fromInfix :: InfixOp -> Builder +fromInfix :: InfixOp -> Builder -> Builder fromInfix op = - case op of - OpAdd -> " + " - OpSub -> " - " - OpMul -> " * " - OpDiv -> " / " - OpMod -> " % " - OpEq -> " === " - OpNe -> " !== " - OpLt -> " < " - OpLe -> " <= " - OpGt -> " > " - OpGe -> " >= " - OpAnd -> " && " - OpOr -> " || " - OpBitwiseAnd -> " & " - OpBitwiseXor -> " ^ " - OpBitwiseOr -> " | " - OpLShift -> " << " - OpSpRShift -> " >> " - OpZfRShift -> " >>> " + addAscii $ + case op of + OpAdd -> " + " + OpSub -> " - " + OpMul -> " * " + OpDiv -> " / " + OpMod -> " % " + OpEq -> " === " + OpNe -> " !== " + OpLt -> " < " + OpLe -> " <= " + OpGt -> " > " + OpGe -> " >= " + OpAnd -> " && " + OpOr -> " || " + OpBitwiseAnd -> " & " + OpBitwiseXor -> " ^ " + OpBitwiseOr -> " | " + OpLShift -> " << " + OpSpRShift -> " >> " + OpZfRShift -> " >>> " diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index db485111f..bd4aa8480 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -19,6 +19,7 @@ import Data.IntMap qualified as IntMap import Data.List qualified as List import Data.Map ((!)) import Data.Map qualified as Map +import Data.Maybe qualified as Maybe import Data.Name qualified as Name import Data.Utf8 qualified as Utf8 import Generate.JavaScript.Builder qualified as JS @@ -36,69 +37,73 @@ import Reporting.Annotation qualified as A -- EXPRESSIONS -generateJsExpr :: Mode.Mode -> Opt.Expr -> JS.Expr -generateJsExpr mode expression = - codeToExpr (generate mode expression) +generateJsExpr :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> JS.Expr +generateJsExpr mode parentModule expression = + codeToExpr (generate mode parentModule expression) -generate :: Mode.Mode -> Opt.Expr -> Code -generate mode expression = +generate :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> Code +generate mode parentModule expression = case expression of - Opt.Bool bool -> - JsExpr $ JS.Bool bool - Opt.Chr char -> + Opt.Bool (A.Region start _) bool -> + JsExpr $ JS.TrackedBool parentModule start bool + Opt.Chr (A.Region start _) char -> JsExpr $ case mode of Mode.Dev _ -> - JS.Call toChar [JS.String (Utf8.toBuilder char)] + JS.Call toChar [JS.TrackedString parentModule start (Utf8.toBuilder char)] Mode.Prod _ -> - JS.String (Utf8.toBuilder char) - Opt.Str string -> - JsExpr $ JS.String (Utf8.toBuilder string) - Opt.Int int -> - JsExpr $ JS.Int int - Opt.Float float -> - JsExpr $ JS.Float (Utf8.toBuilder float) - Opt.VarLocal name -> - JsExpr $ JS.Ref (JsName.fromLocal name) - Opt.VarGlobal (Opt.Global home name) -> - JsExpr $ JS.Ref (JsName.fromGlobal home name) - Opt.VarEnum (Opt.Global home name) index -> + JS.TrackedString parentModule start (Utf8.toBuilder char) + Opt.Str (A.Region start _) string -> + JsExpr $ JS.TrackedString parentModule start (Utf8.toBuilder string) + Opt.Int (A.Region start _) int -> + JsExpr $ JS.TrackedInt parentModule start int + Opt.Float (A.Region start _) float -> + JsExpr $ JS.TrackedFloat parentModule start (Utf8.toBuilder float) + Opt.VarLocal (A.Region startPos _) name -> + JsExpr $ JS.TrackedRef parentModule startPos (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) + Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> + JsExpr $ JS.TrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + Opt.VarEnum (A.Region startPos _) (Opt.Global home name) index -> case mode of Mode.Dev _ -> - JsExpr $ JS.Ref (JsName.fromGlobal home name) + JsExpr $ JS.TrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) Mode.Prod _ -> JsExpr $ JS.Int (Index.toMachine index) - Opt.VarBox (Opt.Global home name) -> + Opt.VarBox (A.Region startPos _) (Opt.Global home name) -> JsExpr $ - JS.Ref $ - case mode of - Mode.Dev _ -> JsName.fromGlobal home name - Mode.Prod _ -> JsName.fromGlobal ModuleName.basics Name.identity - Opt.VarCycle home name -> - JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) [] - Opt.VarDebug name home region unhandledValueName -> + case mode of + Mode.Dev _ -> JS.TrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + Mode.Prod _ -> JS.Ref $ JsName.fromGlobal ModuleName.basics Name.identity + Opt.VarCycle (A.Region startPos _) home name -> + JsExpr $ JS.Call (JS.TrackedRef parentModule startPos (JsName.fromGlobalHumanReadable home name) (JsName.fromCycle home name)) [] + Opt.VarDebug region name home unhandledValueName -> JsExpr $ generateDebug name home region unhandledValueName - Opt.VarKernel home name -> - JsExpr $ JS.Ref (JsName.fromKernel home name) - Opt.Array entries -> - JsExpr $ JS.Array $ map (generateJsExpr mode) entries + Opt.VarKernel (A.Region startPos _) home name -> + JsExpr $ JS.TrackedRef parentModule startPos (JsName.fromKernel home name) (JsName.fromKernel home name) + Opt.Array region entries -> + let generatedEntries = map (generateJsExpr mode parentModule) entries + in JsExpr $ + if region == A.zero + then JS.Array generatedEntries + else JS.TrackedArray parentModule region generatedEntries Opt.Function args body -> - generateFunction (map JsName.fromLocal args) (generate mode body) - Opt.Call func args -> - JsExpr $ generateCall mode func args + let argNames = map (\(A.At region name) -> A.At region (JsName.fromLocal name)) args + in generateTrackedFunction parentModule argNames (generate mode parentModule body) + Opt.Call (A.Region startPos _) func args -> + JsExpr $ generateCall mode parentModule startPos func args Opt.TailCall name args -> - JsBlock $ generateTailCall mode name args + JsBlock $ generateTailCall mode parentModule name args Opt.If branches final -> - generateIf mode branches final + generateIf mode parentModule branches final Opt.Let def body -> JsBlock $ - generateDef mode def : codeToStmtList (generate mode body) + generateDef mode parentModule def : codeToStmtList (generate mode parentModule body) Opt.Destruct (Opt.Destructor name path) body -> let pathDef = JS.Var (JsName.fromLocal name) (generatePath mode path) - in JsBlock $ pathDef : codeToStmtList (generate mode body) + in JsBlock $ pathDef : codeToStmtList (generate mode parentModule body) Opt.Case label root decider jumps -> - JsBlock $ generateCase mode label root decider jumps - Opt.Accessor field -> + JsBlock $ generateCase mode parentModule label root decider jumps + Opt.Accessor _ field -> JsExpr $ JS.Function Nothing @@ -106,17 +111,17 @@ generate mode expression = [ JS.Return $ JS.Access (JS.Ref JsName.dollar) (generateField mode field) ] - Opt.Access record field -> - JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field) - Opt.Update record fields -> + Opt.Access record (A.Region startPos _) field -> + JsExpr $ JS.TrackedAccess (generateJsExpr mode parentModule record) parentModule startPos (generateField mode field) + Opt.Update region record fields -> JsExpr $ JS.Call (JS.Ref (JsName.fromKernel Name.utils "update")) - [ generateJsExpr mode record, - generateRecord mode fields + [ generateJsExpr mode parentModule record, + generateRecord mode parentModule region fields ] - Opt.Record fields -> - JsExpr $ generateRecord mode fields + Opt.Record region fields -> + JsExpr $ generateRecord mode parentModule region fields -- CODE CHUNKS @@ -186,11 +191,11 @@ ctorToInt home name index = -- RECORDS -generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr -generateRecord mode fields = - let toPair (field, value) = - (generateField mode field, generateJsExpr mode value) - in JS.Object (map toPair (Map.toList fields)) +generateRecord :: Mode.Mode -> ModuleName.Canonical -> A.Region -> Map.Map (A.Located Name.Name) Opt.Expr -> JS.Expr +generateRecord mode parentModule region fields = + let toPair (A.At fieldRegion field, value) = + (A.At fieldRegion $ generateField mode field, generateJsExpr mode parentModule value) + in JS.TrackedObject parentModule region (map toPair (Map.toList fields)) generateField :: Mode.Mode -> Name.Name -> JsName.Name generateField mode name = @@ -252,6 +257,29 @@ generateFunction args body = codeToStmtList code in foldr addArg body args +generateTrackedFunction :: ModuleName.Canonical -> [A.Located JsName.Name] -> Code -> Code +generateTrackedFunction parentModule args body = + case IntMap.lookup (length args) funcHelpers of + Just helper -> + JsExpr $ + JS.Call + helper + [ JS.TrackedFunction parentModule args $ + codeToStmtList body + ] + Nothing -> + case args of + [_] -> + JsExpr $ + JS.TrackedFunction parentModule args $ + codeToStmtList body + _ -> + let addArg arg code = + JsExpr $ + JS.Function Nothing [arg] $ + codeToStmtList code + in foldr addArg body (map A.toValue args) + funcHelpers :: IntMap.IntMap JS.Expr funcHelpers = IntMap.fromList $ @@ -259,40 +287,46 @@ funcHelpers = -- CALLS -generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCall mode func args = +generateCall :: Mode.Mode -> ModuleName.Canonical -> A.Position -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCall mode parentModule pos func args = case func of - Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) + Opt.VarGlobal _ global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> - generateCoreCall mode global args - Opt.VarBox _ -> + generateCoreCall mode parentModule pos global args + Opt.VarBox _ _ -> case mode of Mode.Dev _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule pos func args Mode.Prod _ -> case args of [arg] -> - generateJsExpr mode arg + generateJsExpr mode parentModule arg _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule pos func args _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule pos func args -generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCallHelp mode func args = +generateCallHelp :: Mode.Mode -> ModuleName.Canonical -> A.Position -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCallHelp mode parentModule pos func args = generateNormalCall - (generateJsExpr mode func) - (map (generateJsExpr mode) args) - -generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateGlobalCall home name args = - generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args - -generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr -generateNormalCall func args = + parentModule + pos + (generateJsExpr mode parentModule func) + (map (generateJsExpr mode parentModule) args) + +generateGlobalCall :: ModuleName.Canonical -> A.Position -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateGlobalCall parentModule pos@(A.Position line col) home name args = + let ref = + if line == 0 && col == 0 + then JS.Ref (JsName.fromGlobal home name) + else JS.TrackedRef parentModule pos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + in generateNormalCall parentModule pos ref args + +generateNormalCall :: ModuleName.Canonical -> A.Position -> JS.Expr -> [JS.Expr] -> JS.Expr +generateNormalCall parentModule pos func args = case IntMap.lookup (length args) callHelpers of Just helper -> - JS.Call helper (func : args) + JS.TrackedNormalCall parentModule pos helper func args Nothing -> List.foldl' (\f a -> JS.Call f [a]) func args @@ -303,25 +337,25 @@ callHelpers = -- CORE CALLS -generateCoreCall :: Mode.Mode -> Opt.Global -> [Opt.Expr] -> JS.Expr -generateCoreCall mode (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = +generateCoreCall :: Mode.Mode -> ModuleName.Canonical -> A.Position -> Opt.Global -> [Opt.Expr] -> JS.Expr +generateCoreCall mode parentModule pos (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = if moduleName == Name.basics - then generateBasicsCall mode home name args + then generateBasicsCall mode parentModule pos home name args else if moduleName == Name.bitwise - then generateBitwiseCall home name (map (generateJsExpr mode) args) + then generateBitwiseCall parentModule pos home name (map (generateJsExpr mode parentModule) args) else if moduleName == Name.math - then generateMathCall home name (map (generateJsExpr mode) args) - else generateGlobalCall home name (map (generateJsExpr mode) args) + then generateMathCall parentModule pos home name (map (generateJsExpr mode parentModule) args) + else generateGlobalCall parentModule pos home name (map (generateJsExpr mode parentModule) args) -generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateBitwiseCall home name args = +generateBitwiseCall :: ModuleName.Canonical -> A.Position -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateBitwiseCall parentModule pos home name args = case args of [arg] -> case name of "complement" -> JS.Prefix JS.PrefixComplement arg - _ -> generateGlobalCall home name args + _ -> generateGlobalCall parentModule pos home name args [left, right] -> case name of "and" -> JS.Infix JS.OpBitwiseAnd left right @@ -330,30 +364,30 @@ generateBitwiseCall home name args = "shiftLeftBy" -> JS.Infix JS.OpLShift right left "shiftRightBy" -> JS.Infix JS.OpSpRShift right left "shiftRightZfBy" -> JS.Infix JS.OpZfRShift right left - _ -> generateGlobalCall home name args + _ -> generateGlobalCall parentModule pos home name args _ -> - generateGlobalCall home name args + generateGlobalCall parentModule pos home name args -generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr -generateBasicsCall mode home name args = +generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> A.Position -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr +generateBasicsCall mode parentModule pos home name args = case args of [grenArg] -> - let arg = generateJsExpr mode grenArg + let arg = generateJsExpr mode parentModule grenArg in case name of "not" -> JS.Prefix JS.PrefixNot arg "negate" -> JS.Prefix JS.PrefixNegate arg "toFloat" -> arg - _ -> generateGlobalCall home name [arg] + _ -> generateGlobalCall parentModule pos home name [arg] [grenLeft, grenRight] -> case name of -- NOTE: removed "composeL" and "composeR" because of this issue: -- https://github.com/gren/compiler/issues/1722 - "append" -> append mode grenLeft grenRight - "apL" -> generateJsExpr mode $ apply grenLeft grenRight - "apR" -> generateJsExpr mode $ apply grenRight grenLeft + "append" -> append mode parentModule grenLeft grenRight + "apL" -> generateJsExpr mode parentModule $ apply grenLeft grenRight + "apR" -> generateJsExpr mode parentModule $ apply grenRight grenLeft _ -> - let left = generateJsExpr mode grenLeft - right = generateJsExpr mode grenRight + let left = generateJsExpr mode parentModule grenLeft + right = generateJsExpr mode parentModule grenRight in case name of "add" -> JS.Infix JS.OpAdd left right "sub" -> JS.Infix JS.OpSub left right @@ -369,23 +403,23 @@ generateBasicsCall mode home name args = "or" -> JS.Infix JS.OpOr left right "and" -> JS.Infix JS.OpAnd left right "xor" -> JS.Infix JS.OpNe left right - _ -> generateGlobalCall home name [left, right] + _ -> generateGlobalCall parentModule pos home name [left, right] _ -> - generateGlobalCall home name (map (generateJsExpr mode) args) + generateGlobalCall parentModule pos home name (map (generateJsExpr mode parentModule) args) -generateMathCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateMathCall home name args = +generateMathCall :: ModuleName.Canonical -> A.Position -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateMathCall parentModule pos home name args = case args of [arg] -> case name of "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0) - _ -> generateGlobalCall home name [arg] + _ -> generateGlobalCall parentModule pos home name [arg] [left, right] -> case name of "remainderBy" -> JS.Infix JS.OpMod right left - _ -> generateGlobalCall home name [left, right] + _ -> generateGlobalCall parentModule pos home name [left, right] _ -> - generateGlobalCall home name args + generateGlobalCall parentModule pos home name args equal :: JS.Expr -> JS.Expr -> JS.Expr equal left right = @@ -428,16 +462,44 @@ isLiteral expr = apply :: Opt.Expr -> Opt.Expr -> Opt.Expr apply func value = case func of - Opt.Accessor field -> - Opt.Access value field - Opt.Call f args -> - Opt.Call f (args ++ [value]) + Opt.Accessor region field -> + Opt.Access value region field + Opt.Call region f args -> + Opt.Call region f (args ++ [value]) _ -> - Opt.Call func [value] + Opt.Call (Maybe.fromMaybe A.zero (exprRegion func)) func [value] -append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr -append mode left right = - let seqs = generateJsExpr mode left : toSeqs mode right +exprRegion :: Opt.Expr -> Maybe A.Region +exprRegion expr = + case expr of + Opt.Bool region _ -> Just region + Opt.Chr region _ -> Just region + Opt.Str region _ -> Just region + Opt.Int region _ -> Just region + Opt.Float region _ -> Just region + Opt.VarLocal region _ -> Just region + Opt.VarGlobal region _ -> Just region + Opt.VarEnum region _ _ -> Just region + Opt.VarBox region _ -> Just region + Opt.VarCycle region _ _ -> Just region + Opt.VarDebug region _ _ _ -> Just region + Opt.VarKernel region _ _ -> Just region + Opt.Array region _ -> Just region + Opt.Function _ _ -> Nothing + Opt.Call region _ _ -> Just region + Opt.TailCall _ _ -> Nothing + Opt.If _ _ -> Nothing + Opt.Let _ _ -> Nothing + Opt.Destruct _ _ -> Nothing + Opt.Case _ _ _ _ -> Nothing + Opt.Accessor region _ -> Just region + Opt.Access _ region _ -> Just region + Opt.Update region _ _ -> Just region + Opt.Record region _ -> Just region + +append :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> Opt.Expr -> JS.Expr +append mode parentModule left right = + let seqs = generateJsExpr mode parentModule left : toSeqs mode parentModule right in if any isStringLiteral seqs then foldr1 (JS.Infix JS.OpAdd) seqs else foldr1 jsAppend seqs @@ -446,14 +508,14 @@ jsAppend :: JS.Expr -> JS.Expr -> JS.Expr jsAppend a b = JS.Call (JS.Ref (JsName.fromKernel Name.utils "ap")) [a, b] -toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr] -toSeqs mode expr = +toSeqs :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [JS.Expr] +toSeqs mode parentModule expr = case expr of - Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right] + Opt.Call _ (Opt.VarGlobal _ (Opt.Global home "append")) [left, right] | home == ModuleName.basics -> - generateJsExpr mode left : toSeqs mode right + generateJsExpr mode parentModule left : toSeqs mode parentModule right _ -> - [generateJsExpr mode expr] + [generateJsExpr mode parentModule expr] isStringLiteral :: JS.Expr -> Bool isStringLiteral expr = @@ -499,10 +561,10 @@ strictNEq left right = -- TAIL CALL -generateTailCall :: Mode.Mode -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt] -generateTailCall mode name args = +generateTailCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [(Name.Name, Opt.Expr)] -> [JS.Stmt] +generateTailCall mode parentModule name args = let toTempVars (argName, arg) = - (JsName.makeTemp argName, generateJsExpr mode arg) + (JsName.makeTemp argName, generateJsExpr mode parentModule arg) toRealVars (argName, _) = JS.ExprStmt $ @@ -513,22 +575,24 @@ generateTailCall mode name args = -- DEFINITIONS -generateDef :: Mode.Mode -> Opt.Def -> JS.Stmt -generateDef mode def = +generateDef :: Mode.Mode -> ModuleName.Canonical -> Opt.Def -> JS.Stmt +generateDef mode parentModule def = case def of - Opt.Def name body -> - JS.Var (JsName.fromLocal name) (generateJsExpr mode body) - Opt.TailDef name argNames body -> - JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body)) - -generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code -generateTailDef mode name argNames body = - generateFunction (map JsName.fromLocal argNames) $ - JsBlock $ + Opt.Def (A.Region start _) name body -> + JS.TrackedVar parentModule start (JsName.fromLocal name) (JsName.fromLocal name) $ + generateJsExpr mode parentModule body + Opt.TailDef (A.Region start _) name argNames body -> + JS.TrackedVar parentModule start (JsName.fromLocal name) (JsName.fromLocal name) $ + codeToExpr (generateTailDef mode parentModule name argNames body) + +generateTailDef :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [A.Located Name.Name] -> Opt.Expr -> Code +generateTailDef mode parentModule name argNames body = + generateTrackedFunction parentModule (map (\(A.At region argName) -> A.At region (JsName.fromLocal argName)) argNames) $ + JsBlock [ JS.Labelled (JsName.fromLocal name) $ JS.While (JS.Bool True) $ codeToStmt $ - generate mode body + generate mode parentModule body ] -- PATHS @@ -553,18 +617,18 @@ generatePath mode path = -- GENERATE IFS -generateIf :: Mode.Mode -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code -generateIf mode givenBranches givenFinal = +generateIf :: Mode.Mode -> ModuleName.Canonical -> [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Code +generateIf mode parentModule givenBranches givenFinal = let (branches, final) = crushIfs givenBranches givenFinal convertBranch (condition, expr) = - ( generateJsExpr mode condition, - generate mode expr + ( generateJsExpr mode parentModule condition, + generate mode parentModule expr ) branchExprs = map convertBranch branches - finalCode = generate mode final + finalCode = generate mode parentModule final in if isBlock finalCode || any (isBlock . snd) branchExprs then JsBlock [foldr addStmtIf (codeToStmt finalCode) branchExprs] else JsExpr $ foldr addExprIf (codeToExpr finalCode) branchExprs @@ -605,37 +669,37 @@ crushIfsHelp visitedBranches unvisitedBranches final = -- CASE EXPRESSIONS -generateCase :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt] -generateCase mode label root decider jumps = - foldr (goto mode label) (generateDecider mode label root decider) jumps +generateCase :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> [JS.Stmt] +generateCase mode parentModule label root decider jumps = + foldr (goto mode parentModule label) (generateDecider mode parentModule label root decider) jumps -goto :: Mode.Mode -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt] -goto mode label (index, branch) stmts = +goto :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> (Int, Opt.Expr) -> [JS.Stmt] -> [JS.Stmt] +goto mode parentModule label (index, branch) stmts = let labeledDeciderStmt = JS.Labelled (JsName.makeLabel label index) (JS.While (JS.Bool True) (JS.Block stmts)) - in labeledDeciderStmt : codeToStmtList (generate mode branch) + in labeledDeciderStmt : codeToStmtList (generate mode parentModule branch) -generateDecider :: Mode.Mode -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt] -generateDecider mode label root decisionTree = +generateDecider :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> Name.Name -> Opt.Decider Opt.Choice -> [JS.Stmt] +generateDecider mode parentModule label root decisionTree = case decisionTree of Opt.Leaf (Opt.Inline branch) -> - codeToStmtList (generate mode branch) + codeToStmtList (generate mode parentModule branch) Opt.Leaf (Opt.Jump index) -> [JS.Break (Just (JsName.makeLabel label index))] Opt.Chain testChain success failure -> [ JS.IfStmt (List.foldl1' (JS.Infix JS.OpAnd) (map (generateIfTest mode root) testChain)) - (JS.Block $ generateDecider mode label root success) - (JS.Block $ generateDecider mode label root failure) + (JS.Block $ generateDecider mode parentModule label root success) + (JS.Block $ generateDecider mode parentModule label root failure) ] Opt.FanOut path edges fallback -> [ JS.Switch (generateCaseTest mode root path (fst (head edges))) ( foldr - (\edge cases -> generateCaseBranch mode label root edge : cases) - [JS.Default (generateDecider mode label root fallback)] + (\edge cases -> generateCaseBranch mode parentModule label root edge : cases) + [JS.Default (generateDecider mode parentModule label root fallback)] edges ) ] @@ -678,11 +742,11 @@ generateIfTest mode root (path, test) = DT.IsRecord -> error "COMPILER BUG - there should never be tests on a record" -generateCaseBranch :: Mode.Mode -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case -generateCaseBranch mode label root (test, subTree) = +generateCaseBranch :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> Name.Name -> (DT.Test, Opt.Decider Opt.Choice) -> JS.Case +generateCaseBranch mode parentModule label root (test, subTree) = JS.Case (generateCaseValue mode test) - (generateDecider mode label root subTree) + (generateDecider mode parentModule label root subTree) generateCaseValue :: Mode.Mode -> DT.Test -> JS.Expr generateCaseValue mode test = @@ -774,7 +838,7 @@ generateMain mode home main = # JS.Int 0 Opt.Dynamic msgType decoder -> JS.Ref (JsName.fromGlobal home "main") - # generateJsExpr mode decoder + # generateJsExpr mode home decoder # toDebugMetadata mode msgType (#) :: JS.Expr -> JS.Expr -> JS.Expr diff --git a/compiler/src/Generate/JavaScript/Name.hs b/compiler/src/Generate/JavaScript/Name.hs index f01827150..952181052 100644 --- a/compiler/src/Generate/JavaScript/Name.hs +++ b/compiler/src/Generate/JavaScript/Name.hs @@ -7,7 +7,9 @@ module Generate.JavaScript.Name fromIndex, fromInt, fromLocal, + fromLocalHumanReadable, fromGlobal, + fromGlobalHumanReadable, fromCycle, fromKernel, makeF, @@ -48,10 +50,21 @@ fromLocal name = then Name ("_" <> Name.toBuilder name) else Name (Name.toBuilder name) +fromLocalHumanReadable :: Name.Name -> Name +fromLocalHumanReadable name = + Name (Name.toBuilder name) + fromGlobal :: ModuleName.Canonical -> Name.Name -> Name fromGlobal home name = Name $ homeToBuilder home <> usd <> Name.toBuilder name +fromGlobalHumanReadable :: ModuleName.Canonical -> Name.Name -> Name +fromGlobalHumanReadable (ModuleName.Canonical _ moduleName) name = + Name $ + Utf8.toBuilder moduleName + <> "." + <> Name.toBuilder name + fromCycle :: ModuleName.Canonical -> Name.Name -> Name fromCycle home name = Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name @@ -269,3 +282,13 @@ addRenaming keyword maybeBadFields = BadFields $ Map.singleton keyword (unsafeIntToAscii width [] maxName) Just (BadFields renamings) -> BadFields $ Map.insert keyword (unsafeIntToAscii width [] (maxName - Map.size renamings)) renamings + +-- INSTANCES + +instance Ord Name where + compare (Name builder1) (Name builder2) = + compare (B.toLazyByteString builder1) (B.toLazyByteString builder2) + +instance Eq Name where + (==) (Name builder1) (Name builder2) = + (==) (B.toLazyByteString builder1) (B.toLazyByteString builder2) diff --git a/compiler/src/Generate/Node.hs b/compiler/src/Generate/Node.hs index 2c51897d3..839f719ad 100644 --- a/compiler/src/Generate/Node.hs +++ b/compiler/src/Generate/Node.hs @@ -3,6 +3,7 @@ module Generate.Node ( sandwich, + leadingLines, ) where @@ -10,7 +11,8 @@ import Data.ByteString.Builder qualified as B import Data.Name qualified as Name import Text.RawString.QQ (r) --- SANDWICH +leadingLines :: Int +leadingLines = 3 sandwich :: Name.Name -> B.Builder -> B.Builder sandwich moduleName javascript = diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs new file mode 100644 index 000000000..90ec3e27d --- /dev/null +++ b/compiler/src/Generate/SourceMap.hs @@ -0,0 +1,200 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Generate.SourceMap (SourceMap, wrap, generateOnto) where + +import Data.ByteString.Base64 qualified as Base64 +import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy qualified as BLazy +import Data.Function ((&)) +import Data.List as List +import Data.Map.Strict (Map) +import Data.Map.Strict qualified as Map +import Data.Maybe qualified as Maybe +import Data.Ord qualified +import GHC.Word (Word16) +import Generate.JavaScript.Builder qualified as JS +import Generate.JavaScript.Name qualified as JsName +import Generate.VLQ qualified as VLQ +import Gren.ModuleName qualified as ModuleName +import Json.Encode qualified as Json +import Json.String qualified as JStr + +newtype SourceMap = SourceMap [JS.Mapping] + +wrap :: [JS.Mapping] -> SourceMap +wrap = SourceMap + +generateOnto :: Int -> Map.Map ModuleName.Canonical String -> SourceMap -> B.Builder -> B.Builder +generateOnto leadingLines moduleSources (SourceMap mappings) sourceBytes = + sourceBytes + <> "\n" + <> "//# sourceMappingURL=data:application/json;base64," + <> generate leadingLines moduleSources mappings + +generate :: Int -> Map.Map ModuleName.Canonical String -> [JS.Mapping] -> B.Builder +generate leadingLines moduleSources mappings = + mappings + & map (\mapping -> mapping {JS._m_gen_line = JS._m_gen_line mapping + fromIntegral leadingLines}) + & parseMappings + & mappingsToJson moduleSources + & Json.encode + & B.toLazyByteString + & BLazy.toStrict + & Base64.encode + & B.byteString + +data Mappings = Mappings + { _m_sources :: OrderedListBuilder ModuleName.Canonical, + _m_names :: OrderedListBuilder JsName.Name, + _m_segment_accounting :: SegmentAccounting, + _m_vlqs :: B.Builder + } + +data SegmentAccounting = SegmentAccounting + { _sa_prev_col :: Maybe Word16, + _sa_prev_source_idx :: Maybe Int, + _sa_prev_source_line :: Maybe Int, + _sa_prev_source_col :: Maybe Int, + _sa_prev_name_idx :: Maybe Int + } + +parseMappings :: [JS.Mapping] -> Mappings +parseMappings mappings = + let mappingMap = foldr (\mapping acc -> Map.alter (mappingMapUpdater mapping) (JS._m_gen_line mapping) acc) Map.empty mappings + in parseMappingsHelp 1 (fst $ Map.findMax mappingMap) mappingMap $ + Mappings + { _m_sources = emptyOrderedListBuilder, + _m_names = emptyOrderedListBuilder, + _m_segment_accounting = + SegmentAccounting + { _sa_prev_col = Nothing, + _sa_prev_source_idx = Nothing, + _sa_prev_source_line = Nothing, + _sa_prev_source_col = Nothing, + _sa_prev_name_idx = Nothing + }, + _m_vlqs = "" + } + +mappingMapUpdater :: JS.Mapping -> Maybe [JS.Mapping] -> Maybe [JS.Mapping] +mappingMapUpdater toInsert maybeVal = + case maybeVal of + Nothing -> + Just [toInsert] + Just existing -> + Just $ toInsert : existing + +parseMappingsHelp :: Word16 -> Word16 -> Map Word16 [JS.Mapping] -> Mappings -> Mappings +parseMappingsHelp currentLine lastLine mappingMap acc = + if currentLine >= lastLine + then acc + else case Map.lookup currentLine mappingMap of + Nothing -> + parseMappingsHelp (currentLine + 1) lastLine mappingMap $ + prepareForNewLine acc + Just segments -> + let sortedSegments = List.sortOn (Data.Ord.Down . JS._m_gen_col) segments + in parseMappingsHelp (currentLine + 1) lastLine mappingMap $ + prepareForNewLine $ + foldr encodeSegment acc sortedSegments + +prepareForNewLine :: Mappings -> Mappings +prepareForNewLine (Mappings srcs nms sa vlqs) = + Mappings + srcs + nms + (sa {_sa_prev_col = Nothing}) + (vlqs <> ";") + +encodeSegment :: JS.Mapping -> Mappings -> Mappings +encodeSegment segment (Mappings srcs nms sa vlqs) = + let newSources = insertIntoOrderedListBuilder (JS._m_src_module segment) srcs + genCol = JS._m_gen_col segment - 1 + moduleIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module segment) newSources + sourceLine = fromIntegral (JS._m_src_line segment) - 1 + sourceCol = fromIntegral (JS._m_src_col segment) - 1 + genColDelta = fromIntegral genCol - fromIntegral (Maybe.fromMaybe 0 (_sa_prev_col sa)) + moduleIdxDelta = moduleIdx - Maybe.fromMaybe 0 (_sa_prev_source_idx sa) + sourceLineDelta = sourceLine - fromIntegral (Maybe.fromMaybe 0 (_sa_prev_source_line sa)) + sourceColDelta = sourceCol - fromIntegral (Maybe.fromMaybe 0 (_sa_prev_source_col sa)) + updatedSa = + SegmentAccounting + { _sa_prev_col = Just genCol, + _sa_prev_source_idx = Just moduleIdx, + _sa_prev_source_line = Just sourceLine, + _sa_prev_source_col = Just sourceCol, + _sa_prev_name_idx = _sa_prev_name_idx sa + } + vlqPrefix = + if Maybe.isNothing (_sa_prev_col sa) + then "" + else "," + in case JS._m_src_name segment of + Just segmentName -> + let newNames = insertIntoOrderedListBuilder segmentName nms + nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder segmentName newNames + nameIdxDelta = nameIdx - Maybe.fromMaybe 0 (_sa_prev_name_idx sa) + in Mappings newSources newNames (updatedSa {_sa_prev_name_idx = Just nameIdx}) $ + vlqs + <> vlqPrefix + <> B.string8 (VLQ.encode genColDelta) + <> B.string8 (VLQ.encode moduleIdxDelta) + <> B.string8 (VLQ.encode sourceLineDelta) + <> B.string8 (VLQ.encode sourceColDelta) + <> B.string8 (VLQ.encode nameIdxDelta) + Nothing -> + Mappings newSources nms updatedSa $ + vlqs + <> vlqPrefix + <> B.string8 (VLQ.encode genColDelta) + <> B.string8 (VLQ.encode moduleIdxDelta) + <> B.string8 (VLQ.encode sourceLineDelta) + <> B.string8 (VLQ.encode sourceColDelta) + +-- Array builder + +data OrderedListBuilder a = OrderedListBuilder + { _ab_nextIndex :: Int, + _ab_values :: Map.Map a Int + } + +emptyOrderedListBuilder :: OrderedListBuilder a +emptyOrderedListBuilder = + OrderedListBuilder + { _ab_nextIndex = 0, + _ab_values = Map.empty + } + +insertIntoOrderedListBuilder :: Ord a => a -> OrderedListBuilder a -> OrderedListBuilder a +insertIntoOrderedListBuilder value builder@(OrderedListBuilder nextIndex values) = + case Map.lookup value values of + Just _ -> + builder + Nothing -> + OrderedListBuilder + { _ab_nextIndex = nextIndex + 1, + _ab_values = Map.insert value nextIndex values + } + +lookupIndexOrderedListBuilder :: Ord a => a -> OrderedListBuilder a -> Maybe Int +lookupIndexOrderedListBuilder value (OrderedListBuilder _ values) = + Map.lookup value values + +orderedListBuilderToList :: OrderedListBuilder a -> [a] +orderedListBuilderToList (OrderedListBuilder _ values) = + values + & Map.toList + & map (\(val, idx) -> (idx, val)) + & Map.fromList + & Map.elems + +mappingsToJson :: Map.Map ModuleName.Canonical String -> Mappings -> Json.Value +mappingsToJson moduleSources (Mappings sources names _sa vlqs) = + let moduleNames = orderedListBuilderToList sources + in Json.object + [ (JStr.fromChars "version", Json.int 3), + (JStr.fromChars "sources", Json.array $ map (ModuleName.encode . ModuleName._module) moduleNames), + (JStr.fromChars "sourcesContent", Json.array $ map (\moduleName -> Maybe.maybe Json.null Json.chars $ Map.lookup moduleName moduleSources) moduleNames), + (JStr.fromChars "names", Json.array $ map (\jsName -> Json.String ("\"" <> JsName.toBuilder jsName <> "\"")) $ orderedListBuilderToList names), + (JStr.fromChars "mappings", Json.String ("\"" <> vlqs <> "\"")) + ] diff --git a/compiler/src/Generate/VLQ.hs b/compiler/src/Generate/VLQ.hs new file mode 100644 index 000000000..7fc7369b9 --- /dev/null +++ b/compiler/src/Generate/VLQ.hs @@ -0,0 +1,52 @@ +module Generate.VLQ + ( encode, + ) +where + +import Data.Bits ((.&.), (.|.)) +import Data.Bits qualified as Bit +import Data.Foldable.WithIndex (ifoldr) +import Data.Function ((&)) +import Data.List qualified as List +import Data.Map (Map, (!)) +import Data.Map qualified as Map + +{- Ported from the Elm package Janiczek/elm-vlq +-} + +-- Int is converted to 32-bit representation before encoding +encode :: Int -> String +encode num = + let numWithSign = + if num < 0 + then ((negate num .&. usableBits) `Bit.shiftL` 1) .|. 1 + else (num .&. usableBits) `Bit.shiftL` 1 + in encodeHelp numWithSign "" + +usableBits :: Int +usableBits = + 0xFFFFFFFF `Bit.shiftR` 1 + +encodeHelp :: Int -> String -> String +encodeHelp num acc = + let clamped = + num .&. 31 + + newNum = + num `Bit.shiftR` 5 + + newClamped = + if newNum > 0 + then clamped .|. 32 + else clamped + + newAcc = + base64Table ! newClamped : acc + in if newNum > 0 + then encodeHelp newNum newAcc + else List.reverse newAcc + +base64Table :: Map Int Char +base64Table = + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='" + & ifoldr Map.insert Map.empty diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 96889dcf3..662d74086 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -15,8 +15,8 @@ hasDebugUses (Opt.LocalGraph _ graph _) = nodeHasDebug :: Opt.Node -> Bool nodeHasDebug node = case node of - Opt.Define expr _ -> hasDebug expr - Opt.DefineTailFunc _ expr _ -> hasDebug expr + Opt.Define _ expr _ -> hasDebug expr + Opt.DefineTailFunc _ _ expr _ -> hasDebug expr Opt.Ctor _ _ -> False Opt.Enum _ -> False Opt.Box -> False @@ -30,36 +30,36 @@ nodeHasDebug node = hasDebug :: Opt.Expr -> Bool hasDebug expression = case expression of - Opt.Bool _ -> False - Opt.Chr _ -> False - Opt.Str _ -> False - Opt.Int _ -> False - Opt.Float _ -> False - Opt.VarLocal _ -> False - Opt.VarGlobal _ -> False - Opt.VarEnum _ _ -> False - Opt.VarBox _ -> False - Opt.VarCycle _ _ -> False + Opt.Bool _ _ -> False + Opt.Chr _ _ -> False + Opt.Str _ _ -> False + Opt.Int _ _ -> False + Opt.Float _ _ -> False + Opt.VarLocal _ _ -> False + Opt.VarGlobal _ _ -> False + Opt.VarEnum _ _ _ -> False + Opt.VarBox _ _ -> False + Opt.VarCycle _ _ _ -> False Opt.VarDebug _ _ _ _ -> True - Opt.VarKernel _ _ -> False - Opt.Array exprs -> any hasDebug exprs + Opt.VarKernel _ _ _ -> False + Opt.Array _ exprs -> any hasDebug exprs Opt.Function _ expr -> hasDebug expr - Opt.Call e es -> hasDebug e || any hasDebug es + Opt.Call _ e es -> hasDebug e || any hasDebug es Opt.TailCall _ args -> any (hasDebug . snd) args Opt.If conds finally -> any (\(c, e) -> hasDebug c || hasDebug e) conds || hasDebug finally Opt.Let def body -> defHasDebug def || hasDebug body Opt.Destruct _ expr -> hasDebug expr Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps - Opt.Accessor _ -> False - Opt.Access r _ -> hasDebug r - Opt.Update r fs -> hasDebug r || any hasDebug fs - Opt.Record fs -> any hasDebug fs + Opt.Accessor _ _ -> False + Opt.Access r _ _ -> hasDebug r + Opt.Update _ r fs -> hasDebug r || any hasDebug fs + Opt.Record _ fs -> any hasDebug fs defHasDebug :: Opt.Def -> Bool defHasDebug def = case def of - Opt.Def _ expr -> hasDebug expr - Opt.TailDef _ _ expr -> hasDebug expr + Opt.Def _ _ expr -> hasDebug expr + Opt.TailDef _ _ _ expr -> hasDebug expr deciderHasDebug :: Opt.Decider Opt.Choice -> Bool deciderHasDebug decider = diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index 33eed1e0a..b783b2bc6 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE OverloadedStrings #-} {-# OPTIONS_GHC -Wall #-} module Optimize.Expression @@ -12,6 +11,7 @@ import AST.Canonical qualified as Can import AST.Optimized qualified as Opt import Control.Monad (foldM) import Data.Index qualified as Index +import Data.Map qualified as Map import Data.Name qualified as Name import Data.Set qualified as Set import Gren.ModuleName qualified as ModuleName @@ -29,50 +29,50 @@ optimize :: Cycle -> Can.Expr -> Names.Tracker Opt.Expr optimize cycle (A.At region expression) = case expression of Can.VarLocal name -> - pure (Opt.VarLocal name) + pure (Opt.VarLocal region name) Can.VarTopLevel home name -> if Set.member name cycle - then pure (Opt.VarCycle home name) - else Names.registerGlobal home name + then pure (Opt.VarCycle region home name) + else Names.registerGlobal region home name Can.VarKernel home name -> - Names.registerKernel home (Opt.VarKernel home name) + Names.registerKernel home (Opt.VarKernel region home name) Can.VarForeign home name _ -> - Names.registerGlobal home name + Names.registerGlobal region home name Can.VarCtor opts home name index _ -> - Names.registerCtor home name index opts + Names.registerCtor region home (A.At region name) index opts Can.VarDebug home name _ -> Names.registerDebug name home region Can.VarOperator _ home name _ -> - Names.registerGlobal home name + Names.registerGlobal region home name Can.Chr chr -> - Names.registerKernel Name.utils (Opt.Chr chr) + Names.registerKernel Name.utils (Opt.Chr region chr) Can.Str str -> - pure (Opt.Str str) + pure (Opt.Str region str) Can.Int int -> - pure (Opt.Int int) + pure (Opt.Int region int) Can.Float float -> - pure (Opt.Float float) + pure (Opt.Float region float) Can.Array entries -> - Names.registerKernel Name.array Opt.Array + Names.registerKernel Name.array (Opt.Array region) <*> traverse (optimize cycle) entries Can.Negate expr -> do - func <- Names.registerGlobal ModuleName.basics Name.negate + func <- Names.registerGlobal region ModuleName.basics Name.negate arg <- optimize cycle expr - pure $ Opt.Call func [arg] + pure $ Opt.Call region func [arg] Can.Binop _ home name _ left right -> do - optFunc <- Names.registerGlobal home name + optFunc <- Names.registerGlobal region home name optLeft <- optimize cycle left optRight <- optimize cycle right - return (Opt.Call optFunc [optLeft, optRight]) + return (Opt.Call region optFunc [optLeft, optRight]) Can.Lambda args body -> do (argNames, destructors) <- destructArgs args obody <- optimize cycle body pure $ Opt.Function argNames (foldr Opt.Destruct obody destructors) Can.Call func args -> - Opt.Call + Opt.Call region <$> optimize cycle func <*> traverse (optimize cycle) args Can.If branches finally -> @@ -97,11 +97,11 @@ optimize cycle (A.At region expression) = foldM (\bod def -> optimizeDef cycle def bod) obody defs Can.LetDestruct pattern expr body -> do - (name, destructs) <- destruct pattern + (A.At nameRegion name, destructs) <- destruct pattern oexpr <- optimize cycle expr obody <- optimize cycle body pure $ - Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs) + Opt.Let (Opt.Def nameRegion name oexpr) (foldr Opt.Destruct obody destructs) Can.Case expr branches -> let optimizeBranch root (Can.CaseBranch pattern branch) = do @@ -112,24 +112,24 @@ optimize cycle (A.At region expression) = temp <- Names.generate oexpr <- optimize cycle expr case oexpr of - Opt.VarLocal root -> + Opt.VarLocal _region root -> Case.optimize temp root <$> traverse (optimizeBranch root) branches _ -> do obranches <- traverse (optimizeBranch temp) branches - return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) + return $ Opt.Let (Opt.Def region temp oexpr) (Case.optimize temp temp obranches) Can.Accessor field -> - Names.registerField field (Opt.Accessor field) - Can.Access record (A.At _ field) -> + Names.registerField field (Opt.Accessor region field) + Can.Access record (A.At fieldPosition field) -> do optRecord <- optimize cycle record - Names.registerField field (Opt.Access optRecord field) + Names.registerField field (Opt.Access optRecord fieldPosition field) Can.Update record updates -> - Names.registerFieldDict updates Opt.Update + Names.registerFieldDict (Map.mapKeys A.toValue updates) (Opt.Update region) <*> optimize cycle record <*> traverse (optimizeUpdate cycle) updates Can.Record fields -> - Names.registerFieldDict fields Opt.Record + Names.registerFieldDict (Map.mapKeys A.toValue fields) (Opt.Record region) <*> traverse (optimize cycle) fields -- UPDATE @@ -143,27 +143,27 @@ optimizeUpdate cycle (Can.FieldUpdate _ expr) = optimizeDef :: Cycle -> Can.Def -> Opt.Expr -> Names.Tracker Opt.Expr optimizeDef cycle def body = case def of - Can.Def (A.At _ name) args expr -> - optimizeDefHelp cycle name args expr body - Can.TypedDef (A.At _ name) _ typedArgs expr _ -> - optimizeDefHelp cycle name (map fst typedArgs) expr body + Can.Def (A.At region name) args expr -> + optimizeDefHelp cycle region name args expr body + Can.TypedDef (A.At region name) _ typedArgs expr _ -> + optimizeDefHelp cycle region name (map fst typedArgs) expr body -optimizeDefHelp :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr -optimizeDefHelp cycle name args expr body = +optimizeDefHelp :: Cycle -> A.Region -> Name.Name -> [Can.Pattern] -> Can.Expr -> Opt.Expr -> Names.Tracker Opt.Expr +optimizeDefHelp cycle region name args expr body = do oexpr <- optimize cycle expr case args of [] -> - pure $ Opt.Let (Opt.Def name oexpr) body + pure $ Opt.Let (Opt.Def region name oexpr) body _ -> do (argNames, destructors) <- destructArgs args let ofunc = Opt.Function argNames (foldr Opt.Destruct oexpr destructors) - pure $ Opt.Let (Opt.Def name ofunc) body + pure $ Opt.Let (Opt.Def region name ofunc) body -- DESTRUCTURING -destructArgs :: [Can.Pattern] -> Names.Tracker ([Name.Name], [Opt.Destructor]) +destructArgs :: [Can.Pattern] -> Names.Tracker ([A.Located Name.Name], [Opt.Destructor]) destructArgs args = do (argNames, destructorLists) <- unzip <$> traverse destruct args @@ -173,20 +173,20 @@ destructCase :: Name.Name -> Can.Pattern -> Names.Tracker [Opt.Destructor] destructCase rootName pattern = reverse <$> destructHelp (Opt.Root rootName) pattern [] -destruct :: Can.Pattern -> Names.Tracker (Name.Name, [Opt.Destructor]) -destruct pattern@(A.At _ ptrn) = +destruct :: Can.Pattern -> Names.Tracker (A.Located Name.Name, [Opt.Destructor]) +destruct pattern@(A.At region ptrn) = case ptrn of Can.PVar name -> - pure (name, []) + pure (A.At region name, []) Can.PAlias subPattern name -> do revDs <- destructHelp (Opt.Root name) subPattern [] - pure (name, reverse revDs) + pure (A.At region name, reverse revDs) _ -> do name <- Names.generate revDs <- destructHelp (Opt.Root name) pattern [] - pure (name, reverse revDs) + pure (A.At region name, reverse revDs) destructHelp :: Opt.Path -> Can.Pattern -> [Opt.Destructor] -> Names.Tracker [Opt.Destructor] destructHelp path (A.At _ pattern) revDs = @@ -200,7 +200,7 @@ destructHelp path (A.At _ pattern) revDs = Opt.Destructor name path : revDs Can.PRecord [] -> pure revDs - Can.PRecord [(A.At _ (Can.PRFieldPattern name fieldPattern))] -> + Can.PRecord [A.At _ (Can.PRFieldPattern name fieldPattern)] -> destructHelp (Opt.Field name path) fieldPattern revDs Can.PRecord fieldPatterns -> case path of @@ -273,20 +273,20 @@ destructCtorArg path revDs (Can.PatternCtorArg index _ arg) = optimizePotentialTailCallDef :: Cycle -> Can.Def -> Names.Tracker Opt.Def optimizePotentialTailCallDef cycle def = case def of - Can.Def (A.At _ name) args expr -> - optimizePotentialTailCall cycle name args expr - Can.TypedDef (A.At _ name) _ typedArgs expr _ -> - optimizePotentialTailCall cycle name (map fst typedArgs) expr + Can.Def (A.At region name) args expr -> + optimizePotentialTailCall cycle region name args expr + Can.TypedDef (A.At region name) _ typedArgs expr _ -> + optimizePotentialTailCall cycle region name (map fst typedArgs) expr -optimizePotentialTailCall :: Cycle -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker Opt.Def -optimizePotentialTailCall cycle name args expr = +optimizePotentialTailCall :: Cycle -> A.Region -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker Opt.Def +optimizePotentialTailCall cycle region name args expr = do (argNames, destructors) <- destructArgs args - toTailDef name argNames destructors + toTailDef region name argNames destructors <$> optimizeTail cycle name argNames expr -optimizeTail :: Cycle -> Name.Name -> [Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr -optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = +optimizeTail :: Cycle -> Name.Name -> [A.Located Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr +optimizeTail cycle rootName argNames locExpr@(A.At region expression) = case expression of Can.Call func args -> do @@ -299,16 +299,16 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = _ -> False if isMatchingName - then case Index.indexedZipWith (\_ a b -> (a, b)) argNames oargs of + then case Index.indexedZipWith (\_ a b -> (A.toValue a, b)) argNames oargs of Index.LengthMatch pairs -> pure $ Opt.TailCall rootName pairs Index.LengthMismatch _ _ -> do ofunc <- optimize cycle func - pure $ Opt.Call ofunc oargs + pure $ Opt.Call region ofunc oargs else do ofunc <- optimize cycle func - pure $ Opt.Call ofunc oargs + pure $ Opt.Call region ofunc oargs Can.If branches finally -> let optimizeBranch (condition, branch) = (,) @@ -331,11 +331,11 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = foldM (\bod def -> optimizeDef cycle def bod) obody defs Can.LetDestruct pattern expr body -> do - (dname, destructors) <- destruct pattern + (A.At dregion dname, destructors) <- destruct pattern oexpr <- optimize cycle expr obody <- optimizeTail cycle rootName argNames body pure $ - Opt.Let (Opt.Def dname oexpr) (foldr Opt.Destruct obody destructors) + Opt.Let (Opt.Def dregion dname oexpr) (foldr Opt.Destruct obody destructors) Can.Case expr branches -> let optimizeBranch root (Can.CaseBranch pattern branch) = do @@ -346,22 +346,22 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = temp <- Names.generate oexpr <- optimize cycle expr case oexpr of - Opt.VarLocal root -> + Opt.VarLocal _region root -> Case.optimize temp root <$> traverse (optimizeBranch root) branches _ -> do obranches <- traverse (optimizeBranch temp) branches - return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) + return $ Opt.Let (Opt.Def region temp oexpr) (Case.optimize temp temp obranches) _ -> optimize cycle locExpr -- DETECT TAIL CALLS -toTailDef :: Name.Name -> [Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def -toTailDef name argNames destructors body = +toTailDef :: A.Region -> Name.Name -> [A.Located Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def +toTailDef region name argNames destructors body = if hasTailCall body - then Opt.TailDef name argNames (foldr Opt.Destruct body destructors) - else Opt.Def name (Opt.Function argNames (foldr Opt.Destruct body destructors)) + then Opt.TailDef region name argNames (foldr Opt.Destruct body destructors) + else Opt.Def region name (Opt.Function argNames (foldr Opt.Destruct body destructors)) hasTailCall :: Opt.Expr -> Bool hasTailCall expression = diff --git a/compiler/src/Optimize/Module.hs b/compiler/src/Optimize/Module.hs index 0f27a0add..2dafc008a 100644 --- a/compiler/src/Optimize/Module.hs +++ b/compiler/src/Optimize/Module.hs @@ -164,12 +164,12 @@ addDef platform home annotations def graph = 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) + then Result.ok (addDefNode home region name args body Set.empty graph) else let (Can.Forall _ tipe) = annotations ! name addMain (deps, fields, main) = - addDefNode home name args body deps $ + addDefNode home region name args body deps $ Opt.LocalGraph (Just main) nodes (Map.unionWith (+) fields fieldCounts) in case Type.deepDealias tipe of Can.TType hm nm [] @@ -199,8 +199,8 @@ addDefHelp platform region annotations home name args body graph@(Opt.LocalGraph 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 = +addDefNode :: ModuleName.Canonical -> A.Region -> Name.Name -> [Can.Pattern] -> Can.Expr -> Set.Set Opt.Global -> Opt.LocalGraph -> Opt.LocalGraph +addDefNode home region name args body mainDeps graph = let (deps, fields, def) = Names.run $ case args of @@ -213,7 +213,7 @@ addDefNode home name args body mainDeps graph = pure $ Opt.Function argNames $ foldr Opt.Destruct obody destructors - in addToGraph (Opt.Global home name) (Opt.Define def (Set.union deps mainDeps)) fields graph + in addToGraph (Opt.Global home name) (Opt.Define region def (Set.union deps mainDeps)) fields graph -- ADD RECURSIVE DEFS @@ -262,13 +262,13 @@ addLink home link def links = addRecDef :: Set.Set Name.Name -> State -> Can.Def -> Names.Tracker State addRecDef cycle state def = case def of - Can.Def (A.At _ name) args body -> - addRecDefHelp cycle state name args body - Can.TypedDef (A.At _ name) _ args body _ -> - addRecDefHelp cycle state name (map fst args) body + Can.Def (A.At region name) args body -> + addRecDefHelp cycle region state name args body + Can.TypedDef (A.At region name) _ args body _ -> + addRecDefHelp cycle region state name (map fst args) body -addRecDefHelp :: Set.Set Name.Name -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State -addRecDefHelp cycle (State values funcs) name args body = +addRecDefHelp :: Set.Set Name.Name -> A.Region -> State -> Name.Name -> [Can.Pattern] -> Can.Expr -> Names.Tracker State +addRecDefHelp cycle region (State values funcs) name args body = case args of [] -> do @@ -276,5 +276,5 @@ addRecDefHelp cycle (State values funcs) name args body = pure $ State ((name, obody) : values) funcs _ : _ -> do - odef <- Expr.optimizePotentialTailCall cycle name args body + odef <- Expr.optimizePotentialTailCall cycle region name args body pure $ State values (odef : funcs) diff --git a/compiler/src/Optimize/Names.hs b/compiler/src/Optimize/Names.hs index f16de1303..1fb85e0bd 100644 --- a/compiler/src/Optimize/Names.hs +++ b/compiler/src/Optimize/Names.hs @@ -55,34 +55,34 @@ registerKernel home value = Tracker $ \uid deps fields ok -> ok uid (Set.insert (Opt.toKernelGlobal home) deps) fields value -registerGlobal :: ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr -registerGlobal home name = +registerGlobal :: A.Region -> ModuleName.Canonical -> Name.Name -> Tracker Opt.Expr +registerGlobal region home name = Tracker $ \uid deps fields ok -> let global = Opt.Global home name - in ok uid (Set.insert global deps) fields (Opt.VarGlobal global) + in ok uid (Set.insert global deps) fields (Opt.VarGlobal region global) registerDebug :: Name.Name -> ModuleName.Canonical -> A.Region -> Tracker Opt.Expr registerDebug name home region = Tracker $ \uid deps fields ok -> let global = Opt.Global ModuleName.debug name - in ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing) + in ok uid (Set.insert global deps) fields (Opt.VarDebug region name home Nothing) -registerCtor :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr -registerCtor home name index opts = +registerCtor :: A.Region -> ModuleName.Canonical -> A.Located Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr +registerCtor region home (A.At _ name) index opts = Tracker $ \uid deps fields ok -> let global = Opt.Global home name newDeps = Set.insert global deps in case opts of Can.Normal -> - ok uid newDeps fields (Opt.VarGlobal global) + ok uid newDeps fields (Opt.VarGlobal region global) Can.Enum -> ok uid newDeps fields $ case name of - "True" | home == ModuleName.basics -> Opt.Bool True - "False" | home == ModuleName.basics -> Opt.Bool False - _ -> Opt.VarEnum global index + "True" | home == ModuleName.basics -> Opt.Bool region True + "False" | home == ModuleName.basics -> Opt.Bool region False + _ -> Opt.VarEnum region global index Can.Unbox -> - ok uid (Set.insert identity newDeps) fields (Opt.VarBox global) + ok uid (Set.insert identity newDeps) fields (Opt.VarBox region global) identity :: Opt.Global identity = diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index 693e70376..21eff5d5e 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -16,6 +16,7 @@ import Data.Map qualified as Map import Data.Name qualified as Name import Gren.ModuleName qualified as ModuleName import Optimize.Names qualified as Names +import Reporting.Annotation qualified as A import Prelude hiding (maybe, null) -- ENCODE @@ -37,7 +38,7 @@ toEncoder tipe = | name == Name.bool -> encode "bool" | name == Name.string -> encode "string" | name == Name.unit -> encode "null" - | name == Name.value -> Names.registerGlobal ModuleName.basics Name.identity + | name == Name.value -> Names.registerGlobal A.zero ModuleName.basics Name.identity [arg] | name == Name.maybe -> encodeMaybe arg | name == Name.array -> encodeArray arg @@ -49,18 +50,18 @@ toEncoder tipe = let encodeField (name, Can.FieldType _ fieldType) = do encoder <- toEncoder fieldType - let value = Opt.Call encoder [Opt.Access (Opt.VarLocal Name.dollar) name] + let value = Opt.Call A.zero encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) A.zero name] return $ - Opt.Record $ + Opt.Record A.zero $ Map.fromList - [ (Name.fromChars "key", Opt.Str (Name.toGrenString name)), - (Name.fromChars "value", value) + [ (A.At A.zero (Name.fromChars "key"), Opt.Str A.zero (Name.toGrenString name)), + (A.At A.zero (Name.fromChars "value"), value) ] in do object <- encode "object" keyValuePairs <- traverse encodeField (Map.toList fields) Names.registerFieldDict fields $ - Opt.Function [Name.dollar] (Opt.Call object [Opt.Array keyValuePairs]) + Opt.Function [A.At A.zero Name.dollar] (Opt.Call A.zero object [Opt.Array A.zero keyValuePairs]) -- ENCODE HELPERS @@ -69,23 +70,23 @@ encodeMaybe tipe = do null <- encode "null" encoder <- toEncoder tipe - destruct <- Names.registerGlobal ModuleName.maybe "destruct" + destruct <- Names.registerGlobal A.zero ModuleName.maybe "destruct" return $ - Opt.Function [Name.dollar] $ - Opt.Call destruct [null, encoder, Opt.VarLocal Name.dollar] + Opt.Function [A.At A.zero Name.dollar] $ + Opt.Call A.zero destruct [null, encoder, Opt.VarLocal A.zero Name.dollar] encodeArray :: Can.Type -> Names.Tracker Opt.Expr encodeArray tipe = do array <- encode "array" encoder <- toEncoder tipe - return $ Opt.Call array [encoder] + return $ Opt.Call A.zero array [encoder] -- FLAGS DECODER toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr -toFlagsDecoder tipe = - toDecoder tipe +toFlagsDecoder = + toDecoder -- DECODE @@ -123,16 +124,16 @@ decodeUnit :: Names.Tracker Opt.Expr decodeUnit = do succeed <- decode "succeed" - unit <- Names.registerGlobal ModuleName.basics Name.unit - return (Opt.Call succeed [unit]) + unit <- Names.registerGlobal A.zero ModuleName.basics Name.unit + return (Opt.Call A.zero succeed [unit]) -- DECODE MAYBE decodeMaybe :: Can.Type -> Names.Tracker Opt.Expr decodeMaybe tipe = do - nothing <- Names.registerGlobal ModuleName.maybe "Nothing" - just <- Names.registerGlobal ModuleName.maybe "Just" + nothing <- Names.registerGlobal A.zero ModuleName.maybe "Nothing" + just <- Names.registerGlobal A.zero ModuleName.maybe "Just" oneOf <- decode "oneOf" null <- decode "null" @@ -141,11 +142,12 @@ decodeMaybe tipe = subDecoder <- toDecoder tipe return $ - Opt.Call + (Opt.Call A.zero) oneOf [ Opt.Array - [ Opt.Call null [nothing], - Opt.Call map_ [just, subDecoder] + A.zero + [ Opt.Call A.zero null [nothing], + Opt.Call A.zero map_ [just, subDecoder] ] ] @@ -156,20 +158,20 @@ decodeArray tipe = do array <- decode "array" decoder <- toDecoder tipe - return $ Opt.Call array [decoder] + return $ Opt.Call A.zero array [decoder] -- DECODE RECORDS decodeRecord :: Map.Map Name.Name Can.FieldType -> Names.Tracker Opt.Expr decodeRecord fields = let toFieldExpr name _ = - Opt.VarLocal name + Opt.VarLocal A.zero name record = - Opt.Record (Map.mapWithKey toFieldExpr fields) + Opt.Record A.zero (Map.mapKeys (A.At A.zero) (Map.mapWithKey toFieldExpr fields)) in do succeed <- decode "succeed" - foldM fieldAndThen (Opt.Call succeed [record]) + foldM fieldAndThen (Opt.Call A.zero succeed [record]) =<< Names.registerFieldDict fields (Map.toList fields) fieldAndThen :: Opt.Expr -> (Name.Name, Can.FieldType) -> Names.Tracker Opt.Expr @@ -179,18 +181,18 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) = field <- decode "field" typeDecoder <- toDecoder tipe return $ - Opt.Call + (Opt.Call A.zero) andThen - [ Opt.Function [key] decoder, - Opt.Call field [Opt.Str (Name.toGrenString key), typeDecoder] + [ Opt.Function [A.At A.zero key] decoder, + Opt.Call A.zero field [Opt.Str A.zero (Name.toGrenString key), typeDecoder] ] -- GLOBALS HELPERS encode :: Name.Name -> Names.Tracker Opt.Expr encode name = - Names.registerGlobal ModuleName.jsonEncode name + Names.registerGlobal A.zero ModuleName.jsonEncode name decode :: Name.Name -> Names.Tracker Opt.Expr decode name = - Names.registerGlobal ModuleName.jsonDecode name + Names.registerGlobal A.zero ModuleName.jsonDecode name diff --git a/compiler/src/Reporting/Annotation.hs b/compiler/src/Reporting/Annotation.hs index 92c247aeb..e8205cb73 100644 --- a/compiler/src/Reporting/Annotation.hs +++ b/compiler/src/Reporting/Annotation.hs @@ -87,3 +87,13 @@ instance Binary Region where instance Binary Position where put (Position a b) = put a >> put b get = liftM2 Position get get + +instance Ord a => Ord (Located a) where + compare (At _ lhs) (At _ rhs) = compare lhs rhs + +instance Eq a => Eq (Located a) where + (==) (At _ lhs) (At _ rhs) = lhs == rhs + +instance (Binary a) => Binary (Located a) where + put (At a b) = put a >> put b + get = liftM2 At get get diff --git a/compiler/src/Type/Constrain/Expression.hs b/compiler/src/Type/Constrain/Expression.hs index bb3f21f18..7c82b25d5 100644 --- a/compiler/src/Type/Constrain/Expression.hs +++ b/compiler/src/Type/Constrain/Expression.hs @@ -336,13 +336,13 @@ constrainCaseBranch rtv (Can.CaseBranch pattern expr) pExpect bExpect = -- CONSTRAIN RECORD -constrainRecord :: RTV -> A.Region -> Map.Map Name.Name Can.Expr -> Expected Type -> IO Constraint +constrainRecord :: RTV -> A.Region -> Map.Map (A.Located Name.Name) Can.Expr -> Expected Type -> IO Constraint constrainRecord rtv region fields expected = do dict <- traverse (constrainField rtv) fields let getType (_, t, _) = t - let recordType = RecordN (Map.map getType dict) EmptyRecordN + let recordType = RecordN (Map.mapKeys A.toValue (Map.map getType dict)) EmptyRecordN let recordCon = CEqual region Record recordType expected let vars = Map.foldr (\(v, _, _) vs -> v : vs) [] dict @@ -360,10 +360,11 @@ constrainField rtv expr = -- CONSTRAIN RECORD UPDATE -constrainUpdate :: RTV -> A.Region -> Can.Expr -> Map.Map Name.Name Can.FieldUpdate -> Expected Type -> IO Constraint -constrainUpdate rtv region expr fields expected = +constrainUpdate :: RTV -> A.Region -> Can.Expr -> Map.Map (A.Located Name.Name) Can.FieldUpdate -> Expected Type -> IO Constraint +constrainUpdate rtv region expr locatedFields expected = do extVar <- mkFlexVar + let fields = Map.mapKeys A.toValue locatedFields fieldDict <- Map.traverseWithKey (constrainUpdateField rtv region) fields recordVar <- mkFlexVar diff --git a/gren.cabal b/gren.cabal index a165101f7..54149d70a 100644 --- a/gren.cabal +++ b/gren.cabal @@ -152,6 +152,8 @@ Common gren-common Generate.JavaScript.Functions Generate.JavaScript.Name Generate.Mode + Generate.SourceMap + Generate.VLQ Nitpick.Debug Nitpick.PatternMatches Optimize.Case @@ -223,7 +225,8 @@ Common gren-common utf8-string, vector, text >= 2 && < 3, - base64-bytestring >= 1.2 && < 2 + base64-bytestring >= 1.2 && < 2, + indexed-traversable Executable gren Import: @@ -254,6 +257,7 @@ Test-Suite gren-tests Helpers.Parse -- tests + Generate.VLQSpec Integration.FormatSpec Parse.AliasSpec Parse.RecordUpdateSpec diff --git a/terminal/src/Main.hs b/terminal/src/Main.hs index 6ae16ef15..817fb2b09 100644 --- a/terminal/src/Main.hs +++ b/terminal/src/Main.hs @@ -149,6 +149,7 @@ make = flags Make.Flags |-- onOff "debug" "Turn on the time-travelling debugger. It allows you to rewind and replay events. The events can be imported/exported into a file, which makes for very precise bug reports!" |-- onOff "optimize" "Turn on optimizations to make code smaller and faster. For example, the compiler renames record fields to be as short as possible and unboxes values to reduce allocation." + |-- onOff "sourcemaps" "Add sourcemaps to the resulting JS file. This let's you debug Gren code in a JS debugger, at the cost of longer compile times and a bigger JS file." |-- flag "output" Make.output "Specify the name of the resulting JS file. For example --output=assets/gren.js to generate the JS at assets/gren.js. You can also use --output=/dev/stdout to output the JS to the terminal, or --output=/dev/null to generate no output at all!" |-- flag "report" Make.reportType "You can say --report=json to get error messages as JSON. This is only really useful if you are an editor plugin. Humans should avoid it!" in Terminal.Command "make" Uncommon details example (zeroOrMore H.grenFile) makeFlags Make.run diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index 29c2c325e..f16d929f0 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -7,6 +7,7 @@ module Make run, reportType, output, + rereadSources, ) where @@ -14,15 +15,20 @@ import AST.Optimized qualified as Opt import BackgroundWriter qualified as BW import Build qualified import Data.ByteString.Builder qualified as B +import Data.Map (Map) import Data.Maybe qualified as Maybe import Data.NonEmptyList qualified as NE import Directories qualified as Dirs import File qualified import Generate qualified import Generate.Html qualified as Html +import Generate.JavaScript qualified as JS import Generate.Node qualified as Node +import Generate.SourceMap (SourceMap) +import Generate.SourceMap qualified as SourceMap import Gren.Details qualified as Details import Gren.ModuleName qualified as ModuleName +import Gren.Outline qualified as Outline import Gren.Platform qualified as Platform import Parse.Module qualified as Parse import Reporting qualified @@ -38,6 +44,7 @@ import Terminal (Parser (..)) data Flags = Flags { _debug :: Bool, _optimize :: Bool, + _sourceMaps :: Bool, _output :: Maybe Output, _report :: Maybe ReportType } @@ -57,17 +64,17 @@ data ReportType type Task a = Task.Task Exit.Make a run :: [FilePath] -> Flags -> IO () -run paths flags@(Flags _ _ maybeOutput report) = +run paths flags@(Flags _ _ _ maybeOutput report) = do style <- getStyle maybeOutput report maybeRoot <- Dirs.findRoot Reporting.attemptWithStyle style Exit.makeToReport $ case maybeRoot of Just root -> runHelp root paths style flags - Nothing -> return $ Left $ Exit.MakeNoOutline + Nothing -> return $ Left Exit.MakeNoOutline runHelp :: FilePath -> [FilePath] -> Reporting.Style -> Flags -> IO (Either Exit.Make ()) -runHelp root paths style (Flags debug optimize maybeOutput _) = +runHelp root paths style (Flags debug optimize withSourceMaps maybeOutput _) = BW.withScope $ \scope -> Dirs.withRootLock root $ Task.run $ @@ -100,47 +107,54 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = return () (Platform.Browser, [name]) -> do - builder <- toBuilder root details desiredMode artifacts - generate style "index.html" (Html.sandwich name builder) (NE.List name []) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root Html.leadingLines sourceMap source + writeToDisk style "index.html" (Html.sandwich name bundle) (NE.List name []) (Platform.Node, [name]) -> do - builder <- toBuilder root details desiredMode artifacts - generate style "app" (Node.sandwich name builder) (NE.List name []) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root Node.leadingLines sourceMap (Node.sandwich name source) + writeToDisk style "app" bundle (NE.List name []) (_, name : names) -> do - builder <- toBuilder root details desiredMode artifacts - generate style "index.js" builder (NE.List name names) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root 0 sourceMap source + writeToDisk style "index.js" bundle (NE.List name names) Just DevStdOut -> case getMains artifacts of [] -> return () _ -> do - builder <- toBuilder root details desiredMode artifacts - Task.io $ B.hPutBuilder IO.stdout builder + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root 0 sourceMap source + Task.io $ B.hPutBuilder IO.stdout bundle 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 []) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root Node.leadingLines sourceMap (Node.sandwich name source) + writeToDisk style target bundle (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) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root 0 sourceMap source + writeToDisk style target bundle (Build.getRootNames artifacts) name : names -> Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) Just (Html target) -> 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 []) + (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts + bundle <- prepareOutput withSourceMaps root Html.leadingLines sourceMap source + writeToDisk style target (Html.sandwich name bundle) (NE.List name []) _ -> do Task.throw Exit.MakeHtmlOnlyForBrowserPlatform @@ -161,6 +175,12 @@ getMode debug optimize = (False, False) -> return Dev (False, True) -> return Prod +rereadSources :: FilePath -> IO (Map ModuleName.Canonical String) +rereadSources root = + do + modulePaths <- Outline.getAllModulePaths root + traverse readFile modulePaths + getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) getExposed (Details.Details _ validOutline _ _ _ _) = case validOutline of @@ -251,22 +271,30 @@ getNoMain modules root = Just _ -> Nothing Nothing -> Just name --- GENERATE +-- WRITE TO DISK -generate :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task () -generate style target builder names = +prepareOutput :: Bool -> FilePath -> Int -> SourceMap -> B.Builder -> Task B.Builder +prepareOutput enabled root leadingLines sourceMap source = + if enabled + then do + moduleSources <- Task.io $ rereadSources root + return $ SourceMap.generateOnto leadingLines moduleSources sourceMap source + else return source + +writeToDisk :: Reporting.Style -> FilePath -> B.Builder -> NE.List ModuleName.Raw -> Task () +writeToDisk style target builder names = Task.io $ do Dir.createDirectoryIfMissing True (FP.takeDirectory target) File.writeBuilder target builder Reporting.reportGenerate style names target --- TO BUILDER +-- GENERATE data DesiredMode = Debug | Dev | Prod -toBuilder :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task B.Builder -toBuilder root details desiredMode artifacts = +generate :: FilePath -> Details.Details -> DesiredMode -> Build.Artifacts -> Task JS.GeneratedResult +generate root details desiredMode artifacts = Task.mapError Exit.MakeBadGenerate $ case desiredMode of Debug -> Generate.debug root details artifacts diff --git a/tests/Generate/VLQSpec.hs b/tests/Generate/VLQSpec.hs new file mode 100644 index 000000000..b9233c00b --- /dev/null +++ b/tests/Generate/VLQSpec.hs @@ -0,0 +1,18 @@ +module Generate.VLQSpec (spec) where + +import Generate.VLQ (encode) +import Test.Hspec (Spec, describe, it, shouldBe) + +spec :: Spec +spec = do + describe "VLQ tests" $ do + it "Encodes from Int to String" $ do + encode 0 `shouldBe` "A" + encode 1 `shouldBe` "C" + encode (-1) `shouldBe` "D" + encode 3 `shouldBe` "G" + encode 123 `shouldBe` "2H" + encode 123456789 `shouldBe` "qxmvrH" + -- limits: + encode (-2147483648) `shouldBe` "B" + encode 2147483647 `shouldBe` "+/////D"