From 64ff6031e474e5fa6d3928d1869129dfe78e865d Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 20 Mar 2023 21:22:27 +0100 Subject: [PATCH 01/47] Keep position of primitive types in optimized ast. --- compiler/src/AST/Optimized.hs | 30 +++++++++---------- .../src/Generate/JavaScript/Expression.hs | 10 +++---- compiler/src/Nitpick/Debug.hs | 10 +++---- compiler/src/Optimize/Expression.hs | 12 ++++---- compiler/src/Optimize/Names.hs | 8 ++--- compiler/src/Optimize/Port.hs | 9 +++--- 6 files changed, 40 insertions(+), 39 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index 32f8c24f4..d8737f871 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -40,11 +40,11 @@ import Reporting.Annotation qualified as A -- EXPRESSIONS data Expr - = Bool Bool - | Chr ES.String - | Str ES.String - | Int Int - | Float EF.Float + = Bool A.Region Bool + | Chr A.Region ES.String + | Str A.Region ES.String + | Int A.Region Int + | Float A.Region EF.Float | VarLocal Name | VarGlobal Global | VarEnum Global Index.ZeroBased @@ -206,11 +206,11 @@ 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 + 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 -> putWord8 5 >> put a VarGlobal a -> putWord8 6 >> put a VarEnum a b -> putWord8 7 >> put a >> put b @@ -235,11 +235,11 @@ instance Binary Expr where 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 + 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 -> liftM VarLocal get 6 -> liftM VarGlobal get 7 -> liftM2 VarEnum get get diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index db485111f..449ff467e 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -43,20 +43,20 @@ generateJsExpr mode expression = generate :: Mode.Mode -> Opt.Expr -> Code generate mode expression = case expression of - Opt.Bool bool -> + Opt.Bool _region bool -> JsExpr $ JS.Bool bool - Opt.Chr char -> + Opt.Chr _region char -> JsExpr $ case mode of Mode.Dev _ -> JS.Call toChar [JS.String (Utf8.toBuilder char)] Mode.Prod _ -> JS.String (Utf8.toBuilder char) - Opt.Str string -> + Opt.Str _region string -> JsExpr $ JS.String (Utf8.toBuilder string) - Opt.Int int -> + Opt.Int _region int -> JsExpr $ JS.Int int - Opt.Float float -> + Opt.Float _region float -> JsExpr $ JS.Float (Utf8.toBuilder float) Opt.VarLocal name -> JsExpr $ JS.Ref (JsName.fromLocal name) diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 96889dcf3..dc918d920 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -30,11 +30,11 @@ 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.Bool _ _ -> False + Opt.Chr _ _ -> False + Opt.Str _ _ -> False + Opt.Int _ _ -> False + Opt.Float _ _ -> False Opt.VarLocal _ -> False Opt.VarGlobal _ -> False Opt.VarEnum _ _ -> False diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index 33eed1e0a..a0be3ec05 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -39,19 +39,19 @@ optimize cycle (A.At region expression) = Can.VarForeign home name _ -> Names.registerGlobal home name Can.VarCtor opts home name index _ -> - Names.registerCtor home name index opts + Names.registerCtor region home name index opts Can.VarDebug home name _ -> Names.registerDebug name home region Can.VarOperator _ home name _ -> Names.registerGlobal 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 <*> traverse (optimize cycle) entries @@ -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 diff --git a/compiler/src/Optimize/Names.hs b/compiler/src/Optimize/Names.hs index f16de1303..510a9818e 100644 --- a/compiler/src/Optimize/Names.hs +++ b/compiler/src/Optimize/Names.hs @@ -67,8 +67,8 @@ registerDebug name home region = let global = Opt.Global ModuleName.debug name in ok uid (Set.insert global deps) fields (Opt.VarDebug name home region Nothing) -registerCtor :: ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr -registerCtor home name index opts = +registerCtor :: A.Region -> ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr +registerCtor region home name index opts = Tracker $ \uid deps fields ok -> let global = Opt.Global home name newDeps = Set.insert global deps @@ -78,8 +78,8 @@ registerCtor home name index opts = Can.Enum -> ok uid newDeps fields $ case name of - "True" | home == ModuleName.basics -> Opt.Bool True - "False" | home == ModuleName.basics -> Opt.Bool False + "True" | home == ModuleName.basics -> Opt.Bool region True + "False" | home == ModuleName.basics -> Opt.Bool region False _ -> Opt.VarEnum global index Can.Unbox -> ok uid (Set.insert identity newDeps) fields (Opt.VarBox global) diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index 693e70376..0fd409eaa 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 @@ -53,7 +54,7 @@ toEncoder tipe = return $ Opt.Record $ Map.fromList - [ (Name.fromChars "key", Opt.Str (Name.toGrenString name)), + [ (Name.fromChars "key", Opt.Str A.zero (Name.toGrenString name)), (Name.fromChars "value", value) ] in do @@ -84,8 +85,8 @@ encodeArray tipe = -- FLAGS DECODER toFlagsDecoder :: Can.Type -> Names.Tracker Opt.Expr -toFlagsDecoder tipe = - toDecoder tipe +toFlagsDecoder = + toDecoder -- DECODE @@ -182,7 +183,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) = Opt.Call andThen [ Opt.Function [key] decoder, - Opt.Call field [Opt.Str (Name.toGrenString key), typeDecoder] + Opt.Call field [Opt.Str A.zero (Name.toGrenString key), typeDecoder] ] -- GLOBALS HELPERS From abc665714b7f7243bb1ebff7bfea26c080081774 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 20 Mar 2023 21:43:24 +0100 Subject: [PATCH 02/47] Track position of Var nodes. --- compiler/src/AST/Optimized.hs | 38 +++++++++---------- .../src/Generate/JavaScript/Expression.hs | 20 +++++----- compiler/src/Nitpick/Debug.hs | 12 +++--- compiler/src/Optimize/Expression.hs | 21 +++++----- compiler/src/Optimize/Names.hs | 14 +++---- compiler/src/Optimize/Port.hs | 20 +++++----- 6 files changed, 62 insertions(+), 63 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index d8737f871..f2e134f6b 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -45,13 +45,13 @@ data Expr | Str A.Region ES.String | Int A.Region Int | Float A.Region 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 + | 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 [Expr] | Function [Name] Expr | Call Expr [Expr] @@ -211,13 +211,13 @@ instance Binary Expr where 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 -> 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 + 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 + VarKernel a b c -> putWord8 11 >> put a >> put b >> put c Array a -> putWord8 12 >> put a Function a b -> putWord8 13 >> put a >> put b Call a b -> putWord8 14 >> put a >> put b @@ -240,13 +240,13 @@ instance Binary Expr where 2 -> liftM2 Str get get 3 -> liftM2 Int get get 4 -> liftM2 Float get get - 5 -> liftM VarLocal get - 6 -> liftM VarGlobal get - 7 -> liftM2 VarEnum get get - 8 -> liftM VarBox get - 9 -> liftM2 VarCycle 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 + 11 -> liftM3 VarKernel get get get 12 -> liftM Array get 13 -> liftM2 Function get get 14 -> liftM2 Call get get diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 449ff467e..523224c68 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -58,27 +58,27 @@ generate mode expression = JsExpr $ JS.Int int Opt.Float _region float -> JsExpr $ JS.Float (Utf8.toBuilder float) - Opt.VarLocal name -> + Opt.VarLocal _region name -> JsExpr $ JS.Ref (JsName.fromLocal name) - Opt.VarGlobal (Opt.Global home name) -> + Opt.VarGlobal _region (Opt.Global home name) -> JsExpr $ JS.Ref (JsName.fromGlobal home name) - Opt.VarEnum (Opt.Global home name) index -> + Opt.VarEnum _region (Opt.Global home name) index -> case mode of Mode.Dev _ -> JsExpr $ JS.Ref (JsName.fromGlobal home name) Mode.Prod _ -> JsExpr $ JS.Int (Index.toMachine index) - Opt.VarBox (Opt.Global home name) -> + Opt.VarBox _region (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 -> + Opt.VarCycle _region home name -> JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) [] - Opt.VarDebug name home region unhandledValueName -> + Opt.VarDebug region name home unhandledValueName -> JsExpr $ generateDebug name home region unhandledValueName - Opt.VarKernel home name -> + Opt.VarKernel _region home name -> JsExpr $ JS.Ref (JsName.fromKernel home name) Opt.Array entries -> JsExpr $ JS.Array $ map (generateJsExpr mode) entries @@ -262,10 +262,10 @@ funcHelpers = generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr generateCall mode func args = case func of - Opt.VarGlobal global@(Opt.Global (ModuleName.Canonical pkg _) _) + Opt.VarGlobal _region global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> generateCoreCall mode global args - Opt.VarBox _ -> + Opt.VarBox _ _ -> case mode of Mode.Dev _ -> generateCallHelp mode func args @@ -449,7 +449,7 @@ jsAppend a b = toSeqs :: Mode.Mode -> Opt.Expr -> [JS.Expr] toSeqs mode expr = case expr of - Opt.Call (Opt.VarGlobal (Opt.Global home "append")) [left, right] + Opt.Call (Opt.VarGlobal _region (Opt.Global home "append")) [left, right] | home == ModuleName.basics -> generateJsExpr mode left : toSeqs mode right _ -> diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index dc918d920..1d67ba64e 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -35,13 +35,13 @@ hasDebug expression = 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.VarLocal _ _ -> False + Opt.VarGlobal _ _ -> False + Opt.VarEnum _ _ _ -> False + Opt.VarBox _ _ -> False + Opt.VarCycle _ _ _ -> False Opt.VarDebug _ _ _ _ -> True - Opt.VarKernel _ _ -> False + Opt.VarKernel _ _ _ -> False Opt.Array exprs -> any hasDebug exprs Opt.Function _ expr -> hasDebug expr Opt.Call e es -> hasDebug e || any hasDebug es diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index a0be3ec05..1d6073b57 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 @@ -29,21 +28,21 @@ 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 region home 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 region chr) Can.Str str -> @@ -57,12 +56,12 @@ optimize cycle (A.At region expression) = <*> 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] 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]) @@ -112,7 +111,7 @@ 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 @@ -346,7 +345,7 @@ 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 diff --git a/compiler/src/Optimize/Names.hs b/compiler/src/Optimize/Names.hs index 510a9818e..91c8c43ca 100644 --- a/compiler/src/Optimize/Names.hs +++ b/compiler/src/Optimize/Names.hs @@ -55,17 +55,17 @@ 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 :: A.Region -> ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr registerCtor region home name index opts = @@ -74,15 +74,15 @@ registerCtor region home name index opts = 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 region True "False" | home == ModuleName.basics -> Opt.Bool region False - _ -> Opt.VarEnum global index + _ -> 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 0fd409eaa..3671d6f93 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -38,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 @@ -50,7 +50,7 @@ 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 encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) name] return $ Opt.Record $ Map.fromList @@ -70,10 +70,10 @@ 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.Call destruct [null, encoder, Opt.VarLocal A.zero Name.dollar] encodeArray :: Can.Type -> Names.Tracker Opt.Expr encodeArray tipe = @@ -124,7 +124,7 @@ decodeUnit :: Names.Tracker Opt.Expr decodeUnit = do succeed <- decode "succeed" - unit <- Names.registerGlobal ModuleName.basics Name.unit + unit <- Names.registerGlobal A.zero ModuleName.basics Name.unit return (Opt.Call succeed [unit]) -- DECODE MAYBE @@ -132,8 +132,8 @@ decodeUnit = 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" @@ -164,7 +164,7 @@ decodeArray tipe = 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) @@ -190,8 +190,8 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) = 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 From 9f6bc8b7ec645e529325c328e50acd51e4e26f1e Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 20 Mar 2023 22:05:08 +0100 Subject: [PATCH 03/47] Track position of Var nodes. --- compiler/src/AST/Optimized.hs | 66 +++++++++++++++++------------------ 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index f2e134f6b..d20fe6bd3 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -52,18 +52,18 @@ data Expr | VarCycle A.Region ModuleName.Canonical Name | VarDebug A.Region Name ModuleName.Canonical (Maybe Name) | VarKernel A.Region Name Name - | Array [Expr] - | Function [Name] Expr - | Call Expr [Expr] - | TailCall Name [(Name, Expr)] - | If [(Expr, Expr)] Expr - | Let Def Expr - | Destruct Destructor Expr + | Array A.Region [Expr] + | Function A.Region [Name] Expr + | Call A.Region Expr [Expr] + | TailCall A.Region Name [(Name, Expr)] + | If A.Region [(Expr, Expr)] Expr + | Let A.Region Def Expr + | Destruct A.Region 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 A.Region Expr Name + | Update A.Region Expr (Map.Map Name Expr) + | Record A.Region (Map.Map Name Expr) data Global = Global ModuleName.Canonical Name @@ -218,18 +218,18 @@ instance Binary Expr where 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 c -> putWord8 11 >> put a >> put b >> put c - Array a -> putWord8 12 >> put a - Function a b -> putWord8 13 >> put a >> put b - Call a b -> putWord8 14 >> put a >> put b - 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 + Array a b -> putWord8 12 >> put a >> put b + Function a b c -> putWord8 13 >> put a >> put b >> put c + Call a b c -> putWord8 14 >> put a >> put b >> put c + TailCall a b c -> putWord8 15 >> put a >> put b >> put c + If a b c -> putWord8 16 >> put a >> put b >> put c + Let a b c -> putWord8 17 >> put a >> put b >> put c + Destruct a b c -> putWord8 18 >> put a >> put b >> put c 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 @@ -247,18 +247,18 @@ instance Binary Expr where 9 -> liftM3 VarCycle get get get 10 -> liftM4 VarDebug get get get get 11 -> liftM3 VarKernel get get get - 12 -> liftM Array get - 13 -> liftM2 Function get get - 14 -> liftM2 Call get get - 15 -> liftM2 TailCall get get - 16 -> liftM2 If get get - 17 -> liftM2 Let get get - 18 -> liftM2 Destruct get get + 12 -> liftM2 Array get get + 13 -> liftM3 Function get get get + 14 -> liftM3 Call get get get + 15 -> liftM3 TailCall get get get + 16 -> liftM3 If get get get + 17 -> liftM3 Let get get get + 18 -> liftM3 Destruct get 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 From f4265b6d62093aec33040d0fb95e4c8089ac49ae Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 20 Mar 2023 22:15:46 +0100 Subject: [PATCH 04/47] Revert accidental commit This reverts commit 9f6bc8b7ec645e529325c328e50acd51e4e26f1e. --- compiler/src/AST/Optimized.hs | 66 +++++++++++++++++------------------ 1 file changed, 33 insertions(+), 33 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index d20fe6bd3..f2e134f6b 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -52,18 +52,18 @@ data Expr | 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.Region [Name] Expr - | Call A.Region Expr [Expr] - | TailCall A.Region Name [(Name, Expr)] - | If A.Region [(Expr, Expr)] Expr - | Let A.Region Def Expr - | Destruct A.Region Destructor Expr + | Array [Expr] + | Function [Name] Expr + | Call Expr [Expr] + | TailCall Name [(Name, Expr)] + | If [(Expr, Expr)] Expr + | Let Def Expr + | Destruct Destructor Expr | Case Name Name (Decider Choice) [(Int, Expr)] - | Accessor A.Region Name - | Access A.Region Expr Name - | Update A.Region Expr (Map.Map Name Expr) - | Record A.Region (Map.Map Name Expr) + | Accessor Name + | Access Expr Name + | Update Expr (Map.Map Name Expr) + | Record (Map.Map Name Expr) data Global = Global ModuleName.Canonical Name @@ -218,18 +218,18 @@ instance Binary Expr where 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 c -> putWord8 11 >> put a >> put b >> put c - Array a b -> putWord8 12 >> put a >> put b - Function a b c -> putWord8 13 >> put a >> put b >> put c - Call a b c -> putWord8 14 >> put a >> put b >> put c - TailCall a b c -> putWord8 15 >> put a >> put b >> put c - If a b c -> putWord8 16 >> put a >> put b >> put c - Let a b c -> putWord8 17 >> put a >> put b >> put c - Destruct a b c -> putWord8 18 >> put a >> put b >> put c + Array a -> putWord8 12 >> put a + Function a b -> putWord8 13 >> put a >> put b + Call a b -> putWord8 14 >> put a >> put b + 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 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 + 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 get = do @@ -247,18 +247,18 @@ instance Binary Expr where 9 -> liftM3 VarCycle get get get 10 -> liftM4 VarDebug get get get get 11 -> liftM3 VarKernel get get get - 12 -> liftM2 Array get get - 13 -> liftM3 Function get get get - 14 -> liftM3 Call get get get - 15 -> liftM3 TailCall get get get - 16 -> liftM3 If get get get - 17 -> liftM3 Let get get get - 18 -> liftM3 Destruct get get get + 12 -> liftM Array get + 13 -> liftM2 Function get get + 14 -> liftM2 Call 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 -> liftM2 Accessor get get - 21 -> liftM3 Access get get get - 22 -> liftM3 Update get get get - 23 -> liftM2 Record get get + 20 -> liftM Accessor get + 21 -> liftM2 Access get get + 22 -> liftM2 Update get get + 23 -> liftM Record get _ -> fail "problem getting Opt.Expr binary" instance Binary Def where From b92c9c0713a4b85cb5f95a54c22d6b2828e362bd Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Thu, 23 Mar 2023 20:01:16 +0100 Subject: [PATCH 05/47] Prepare generator for returning source maps. --- builder/src/Generate.hs | 9 ++-- compiler/src/Generate/JavaScript.hs | 69 +++++++++++++++-------------- 2 files changed, 42 insertions(+), 36 deletions(-) diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs index 7efd25f87..a0623a6b9 100644 --- a/builder/src/Generate.hs +++ b/builder/src/Generate.hs @@ -46,7 +46,8 @@ debug root details (Build.Artifacts pkg ifaces roots modules) = let mode = Mode.Dev (Just types) let graph = objectsToGlobalGraph objects let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains + let (JS.GeneratedResult state) = JS.generate mode graph mains + return state dev :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder dev root details (Build.Artifacts pkg _ roots modules) = @@ -55,7 +56,8 @@ dev root details (Build.Artifacts pkg _ roots modules) = let mode = Mode.Dev Nothing let graph = objectsToGlobalGraph objects let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains + let (JS.GeneratedResult state) = JS.generate mode graph mains + return state prod :: FilePath -> Details.Details -> Build.Artifacts -> Task B.Builder prod root details (Build.Artifacts pkg _ roots modules) = @@ -65,7 +67,8 @@ prod root details (Build.Artifacts pkg _ roots modules) = let graph = objectsToGlobalGraph objects let mode = Mode.Prod (Mode.shortenFieldNames graph) let mains = gatherMains pkg objects roots - return $ JS.generate mode graph mains + let (JS.GeneratedResult state) = JS.generate mode graph mains + return state repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name = diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 865121b9c..6de7af3b5 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 ((!)) @@ -34,38 +36,38 @@ type Graph = Map.Map Opt.Global Opt.Node type Mains = Map.Map ModuleName.Canonical Opt.Main -generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> B.Builder +newtype GeneratedResult = GeneratedResult + {_source :: B.Builder} + +prelude :: B.Builder +prelude = + "(function(scope){\n'use strict';" + <> Functions.functions + +firstGeneratedLineNumber :: Int +firstGeneratedLineNumber = + length $ lines $ BLazy.unpack $ B.toLazyByteString prelude + +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));" + in GeneratedResult {_source = builder} 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 @@ -102,15 +104,16 @@ print ansi localizer home name tipe = data State = State { _revKernels :: [B.Builder], _revBuilders :: [B.Builder], - _seenGlobals :: Set.Set Opt.Global + _seenGlobals :: Set.Set Opt.Global, + _mappings :: Int } -emptyState :: State -emptyState = - State mempty [] Set.empty +emptyState :: Int -> State +emptyState startingLine = + State mempty [] Set.empty startingLine stateToBuilder :: State -> B.Builder -stateToBuilder (State revKernels revBuilders _) = +stateToBuilder (State revKernels revBuilders _ _) = prependBuilders revKernels (prependBuilders revBuilders mempty) prependBuilders :: [B.Builder] -> B.Builder -> B.Builder @@ -120,12 +123,12 @@ prependBuilders revBuilders monolith = -- ADD DEPENDENCIES addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State -addGlobal mode graph state@(State revKernels builders seen) global = +addGlobal mode graph state@(State revKernels builders seen mappings) global = if Set.member global seen then state else addGlobalHelp mode graph global $ - State revKernels builders (Set.insert global seen) + State revKernels builders (Set.insert global seen) mappings addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State addGlobalHelp mode graph global state = @@ -187,12 +190,12 @@ addStmt state stmt = addBuilder state (JS.stmtToBuilder stmt) addBuilder :: State -> B.Builder -> State -addBuilder (State revKernels revBuilders seen) builder = - State revKernels (builder : revBuilders) seen +addBuilder (State revKernels revBuilders seen mappings) builder = + State revKernels (builder : revBuilders) seen mappings addKernel :: State -> B.Builder -> State -addKernel (State revKernels revBuilders seen) kernel = - State (kernel : revKernels) revBuilders seen +addKernel (State revKernels revBuilders seen mappings) kernel = + State (kernel : revKernels) revBuilders seen mappings var :: Opt.Global -> Expr.Code -> JS.Stmt var (Opt.Global home name) code = From 849c3a4fec96bdb121173c13ec087ba1357bdd6d Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 27 Mar 2023 19:49:20 +0200 Subject: [PATCH 06/47] Pass around the current line. --- compiler/src/Generate/JavaScript.hs | 22 +++- compiler/src/Generate/JavaScript/Builder.hs | 134 ++++++++++---------- 2 files changed, 82 insertions(+), 74 deletions(-) diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 6de7af3b5..e2396c76a 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -131,23 +131,26 @@ addGlobal mode graph state@(State revKernels builders seen mappings) global = State revKernels builders (Set.insert global seen) mappings addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State -addGlobalHelp mode graph global state = +addGlobalHelp mode graph global state@(State _ _ _ mapping) = let addDeps deps someState = Set.foldl' (addGlobal mode graph) someState deps in case graph ! global of Opt.Define expr deps -> addStmt + mapping (addDeps deps state) ( var global (Expr.generate mode expr) ) Opt.DefineTailFunc argNames body deps -> addStmt + mapping (addDeps deps state) ( let (Opt.Global _ name) = global in var global (Expr.generateTailDef mode name argNames body) ) Opt.Ctor index arity -> addStmt + mapping state ( var global (Expr.generateCtor mode global index arity) ) @@ -155,6 +158,7 @@ addGlobalHelp mode graph global state = addGlobal mode graph state linkedGlobal Opt.Cycle names values functions deps -> addStmt + mapping (addDeps deps state) ( generateCycle mode global names values functions ) @@ -166,28 +170,32 @@ addGlobalHelp mode graph global state = else addKernel (addDeps deps state) (generateKernel mode chunks) Opt.Enum index -> addStmt + mapping state ( generateEnum mode global index ) Opt.Box -> addStmt + mapping (addGlobal mode graph state identity) ( generateBox mode global ) Opt.PortIncoming decoder deps -> addStmt + mapping (addDeps deps state) ( generatePort mode global "incomingPort" decoder ) Opt.PortOutgoing encoder deps -> addStmt + mapping (addDeps deps state) ( generatePort mode global "outgoingPort" encoder ) -addStmt :: State -> JS.Stmt -> State -addStmt state stmt = - addBuilder state (JS.stmtToBuilder stmt) +addStmt :: Int -> State -> JS.Stmt -> State +addStmt line state stmt = + addBuilder state (JS.stmtToBuilder line stmt) addBuilder :: State -> B.Builder -> State addBuilder (State revKernels revBuilders seen mappings) builder = @@ -338,7 +346,7 @@ generatePort mode (Opt.Global home name) makePort converter = -- GENERATE MANAGER generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State -generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state = +generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state@(State _ _ _ mapping) = let managerLVar = JS.LBracket (JS.Ref (JsName.fromKernel Name.platform "effectManagers")) @@ -351,7 +359,7 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) JS.ExprStmt $ JS.Assign managerLVar $ JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args - in addStmt (List.foldl' (addGlobal mode graph) state deps) $ + in addStmt mapping (List.foldl' (addGlobal mode graph) state deps) $ JS.Block (createManager : stmts) generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt @@ -402,7 +410,7 @@ generateExports mode (Trie maybeMain subs) = "{" Just (home, main) -> "{'init':" - <> JS.exprToBuilder (Expr.generateMain mode home main) + <> JS.exprToBuilder 0 (Expr.generateMain mode home main) <> 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..8e70345f4 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -118,13 +118,13 @@ data PrefixOp -- ENCODE -stmtToBuilder :: Stmt -> Builder -stmtToBuilder stmts = - fromStmt levelZero stmts +stmtToBuilder :: Int -> Stmt -> Builder +stmtToBuilder line stmts = + fromStmt line levelZero stmts -exprToBuilder :: Expr -> Builder -exprToBuilder expr = - snd $ fromExpr levelZero Whatever expr +exprToBuilder :: Int -> Expr -> Builder +exprToBuilder line expr = + snd $ fromExpr line levelZero Whatever expr -- INDENT LEVEL @@ -155,29 +155,29 @@ commaNewlineSep (Level _ (Level deeperIndent _)) builders = -- STATEMENTS -fromStmtBlock :: Level -> [Stmt] -> Builder -fromStmtBlock level stmts = - mconcat (map (fromStmt level) stmts) +fromStmtBlock :: Int -> Level -> [Stmt] -> Builder +fromStmtBlock line level stmts = + mconcat (map (fromStmt line level) stmts) -fromStmt :: Level -> Stmt -> Builder -fromStmt level@(Level indent nextLevel) statement = +fromStmt :: Int -> Level -> Stmt -> Builder +fromStmt line level@(Level indent nextLevel) statement = case statement of Block stmts -> - fromStmtBlock level stmts + fromStmtBlock line level stmts EmptyStmt -> mempty ExprStmt expr -> - indent <> snd (fromExpr level Whatever expr) <> ";\n" + indent <> snd (fromExpr line level Whatever expr) <> ";\n" IfStmt condition thenStmt elseStmt -> mconcat [ indent, "if (", - snd (fromExpr level Whatever condition), + snd (fromExpr line level Whatever condition), ") {\n", - fromStmt nextLevel thenStmt, + fromStmt (line + 1) nextLevel thenStmt, indent, "} else {\n", - fromStmt nextLevel elseStmt, + fromStmt (line + 2) nextLevel elseStmt, indent, "}\n" ] @@ -185,9 +185,9 @@ fromStmt level@(Level indent nextLevel) statement = mconcat [ indent, "switch (", - snd (fromExpr level Whatever expr), + snd (fromExpr line level Whatever expr), ") {\n", - mconcat (map (fromClause nextLevel) clauses), + mconcat (map (fromClause (line + 1) nextLevel) clauses), indent, "}\n" ] @@ -195,9 +195,9 @@ fromStmt level@(Level indent nextLevel) statement = mconcat [ indent, "while (", - snd (fromExpr level Whatever expr), + snd (fromExpr line level Whatever expr), ") {\n", - fromStmt nextLevel stmt, + fromStmt (line + 1) nextLevel stmt, indent, "}\n" ] @@ -214,31 +214,31 @@ fromStmt level@(Level indent nextLevel) statement = [ indent, Name.toBuilder label, ":\n", - fromStmt level stmt + fromStmt (line + 1) level stmt ] Try tryStmt errorName catchStmt -> mconcat [ indent, "try {\n", - fromStmt nextLevel tryStmt, + fromStmt (line + 1) nextLevel tryStmt, indent, "} catch (", Name.toBuilder errorName, ") {\n", - fromStmt nextLevel catchStmt, + fromStmt line nextLevel catchStmt, indent, "}\n" ] Throw expr -> - indent <> "throw " <> snd (fromExpr level Whatever expr) <> ";" + indent <> "throw " <> snd (fromExpr line level Whatever expr) <> ";" Return expr -> - indent <> "return " <> snd (fromExpr level Whatever expr) <> ";\n" + indent <> "return " <> snd (fromExpr line level Whatever expr) <> ";\n" Var name expr -> - indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) <> ";\n" + indent <> "var " <> Name.toBuilder name <> " = " <> snd (fromExpr line level Whatever expr) <> ";\n" Vars [] -> mempty Vars vars -> - indent <> "var " <> commaNewlineSep level (map (varToBuilder level) vars) <> ";\n" + indent <> "var " <> commaNewlineSep level (map (varToBuilder line level) vars) <> ";\n" FunctionStmt name args stmts -> indent <> "function " @@ -246,31 +246,31 @@ fromStmt level@(Level indent nextLevel) statement = <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n" - <> fromStmtBlock nextLevel stmts + <> fromStmtBlock (line + 1) nextLevel stmts <> indent <> "}\n" -- SWITCH CLAUSES -fromClause :: Level -> Case -> Builder -fromClause level@(Level indent nextLevel) clause = +fromClause :: Int -> Level -> Case -> Builder +fromClause line level@(Level indent nextLevel) clause = case clause of Case expr stmts -> indent <> "case " - <> snd (fromExpr level Whatever expr) + <> snd (fromExpr line level Whatever expr) <> ":\n" - <> fromStmtBlock nextLevel stmts + <> fromStmtBlock (line + 1) nextLevel stmts Default stmts -> indent <> "default:\n" - <> fromStmtBlock nextLevel stmts + <> fromStmtBlock (line + 1) nextLevel stmts -- VAR DECLS -varToBuilder :: Level -> (Name, Expr) -> Builder -varToBuilder level (name, expr) = - Name.toBuilder name <> " = " <> snd (fromExpr level Whatever expr) +varToBuilder :: Int -> Level -> (Name, Expr) -> Builder +varToBuilder line level (name, expr) = + Name.toBuilder name <> " = " <> snd (fromExpr line level Whatever expr) -- EXPRESSIONS @@ -297,8 +297,8 @@ parensFor grouping builder = Whatever -> builder -fromExpr :: Level -> Grouping -> Expr -> (Lines, Builder) -fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression = +fromExpr :: Int -> Level -> Grouping -> Expr -> (Lines, Builder) +fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression = case expression of String string -> (One, "'" <> string <> "'") @@ -314,7 +314,7 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi (One, Json.encodeUgly json) Array exprs -> (,) Many $ - let (anyMany, builders) = linesMap (fromExpr level Whatever) exprs + let (anyMany, builders) = linesMap (fromExpr line level Whatever) exprs in if anyMany then "[\n" @@ -326,7 +326,7 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi else "[" <> commaSep builders <> "]" Object fields -> (,) Many $ - let (anyMany, builders) = linesMap (fromField nextLevel) fields + let (anyMany, builders) = linesMap (fromField line nextLevel) fields in if anyMany then "{\n" @@ -339,37 +339,37 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi Ref name -> (One, Name.toBuilder name) Access expr field -> - makeDot level expr field + makeDot line level expr field Index expr bracketedExpr -> - makeBracketed level expr bracketedExpr + makeBracketed line level expr bracketedExpr Prefix op expr -> - let (lines, builder) = fromExpr level Atomic expr + let (lines, builder) = fromExpr line level Atomic expr in ( lines, parensFor grouping (fromPrefix op <> builder) ) Infix op leftExpr rightExpr -> - let (leftLines, left) = fromExpr level Atomic leftExpr - (rightLines, right) = fromExpr level Atomic rightExpr + let (leftLines, left) = fromExpr line level Atomic leftExpr + (rightLines, right) = fromExpr line level Atomic rightExpr in ( merge leftLines rightLines, parensFor grouping (left <> fromInfix op <> right) ) If condExpr thenExpr elseExpr -> - let condB = snd (fromExpr level Atomic condExpr) - thenB = snd (fromExpr level Atomic thenExpr) - elseB = snd (fromExpr level Atomic elseExpr) + let condB = snd (fromExpr line level Atomic condExpr) + thenB = snd (fromExpr line level Atomic thenExpr) + elseB = snd (fromExpr line level Atomic elseExpr) in ( Many, parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB) ) Assign lValue expr -> - let (leftLines, left) = fromLValue level lValue - (rightLines, right) = fromExpr level Whatever expr + let (leftLines, left) = fromLValue line level lValue + (rightLines, right) = fromExpr line level Whatever expr in ( merge leftLines rightLines, parensFor grouping (left <> " = " <> right) ) Call function args -> (,) Many $ - let (_, funcB) = fromExpr level Atomic function - (anyMany, argsB) = linesMap (fromExpr nextLevel Whatever) args + let (_, funcB) = fromExpr line level Atomic function + (anyMany, argsB) = linesMap (fromExpr line nextLevel Whatever) args in if anyMany then funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")" else funcB <> "(" <> commaSep argsB <> ")" @@ -380,40 +380,40 @@ fromExpr level@(Level indent nextLevel@(Level deeperIndent _)) grouping expressi <> "(" <> commaSep (map Name.toBuilder args) <> ") {\n" - <> fromStmtBlock nextLevel stmts + <> fromStmtBlock (line + 1) nextLevel stmts <> indent <> "}" -- FIELDS -fromField :: Level -> (Name, Expr) -> (Lines, Builder) -fromField level (field, expr) = - let (lines, builder) = fromExpr level Whatever expr +fromField :: Int -> Level -> (Name, Expr) -> (Lines, Builder) +fromField line level (field, expr) = + let (lines, builder) = fromExpr line level Whatever expr in ( lines, Name.toBuilder field <> ": " <> builder ) -- VALUES -fromLValue :: Level -> LValue -> (Lines, Builder) -fromLValue level lValue = +fromLValue :: Int -> Level -> LValue -> (Lines, Builder) +fromLValue line level lValue = case lValue of LRef name -> (One, Name.toBuilder name) LDot expr field -> - makeDot level expr field + makeDot line level expr field LBracket expr bracketedExpr -> - makeBracketed level expr bracketedExpr + makeBracketed line level expr bracketedExpr -makeDot :: Level -> Expr -> Name -> (Lines, Builder) -makeDot level expr field = - let (lines, builder) = fromExpr level Atomic expr +makeDot :: Int -> Level -> Expr -> Name -> (Lines, Builder) +makeDot line level expr field = + let (lines, builder) = fromExpr line 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 +makeBracketed :: Int -> Level -> Expr -> Expr -> (Lines, Builder) +makeBracketed line level expr bracketedExpr = + let (lines, builder) = fromExpr line level Atomic expr + (bracketedLines, bracketedBuilder) = fromExpr line level Whatever bracketedExpr in ( merge lines bracketedLines, builder <> "[" <> bracketedBuilder <> "]" ) From dcf536950266fefd81fcd67667e368fdf8eb51a5 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 27 Mar 2023 21:38:01 +0200 Subject: [PATCH 07/47] Began re-write of JavaScript/Builder.hs to keep track of positions in generated code. --- compiler/src/Generate/JavaScript/Builder.hs | 83 ++++++++++++++++++--- 1 file changed, 71 insertions(+), 12 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 8e70345f4..d9202b216 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -19,7 +19,8 @@ where -- how all the types should fit together. import Data.ByteString qualified as BS -import Data.ByteString.Builder as B +import Data.ByteString.Builder qualified as B +import Data.ByteString.Lazy.Char8 qualified as BSLazy import Data.List qualified as List import Generate.JavaScript.Name (Name) import Generate.JavaScript.Name qualified as Name @@ -42,8 +43,8 @@ import Prelude hiding (lines) -- returning tuples when generating expressions. -- data Expr - = String Builder - | Float Builder + = String B.Builder + | Float B.Builder | Int Int | Bool Bool | Null @@ -116,6 +117,64 @@ data PrefixOp | PrefixNegate -- - | PrefixComplement -- ~ +-- BUILDER + +data Builder = Builder + { _code :: B.Builder, + _currentLine :: Int, + _currentCol :: Int, + _lines :: Lines, + _mappings :: [Mapping] + } + +data Mapping = Mapping + { _m_line :: Int, + _m_col :: Int + } + +emptyBuilder :: Int -> Builder +emptyBuilder currentLine = + Builder + { _code = mempty, + _currentLine = currentLine, + _currentCol = 1, + _lines = One, + _mappings = [] + } + +addAscii :: String -> Builder -> Builder +addAscii code (Builder _code _currLine _currCol _lines _mappings) = + Builder + { _code = _code <> B.string7 code, + _currentLine = _currLine, + _currentCol = _currCol + length code, + _lines = _lines, + _mappings = _mappings + } + +-- TODO: This is a crutch used during prototyping +-- Should be removed once things stabalizes as it's bad for perf +addByteString :: B.Builder -> Builder -> Builder +addByteString bsBuilder (Builder _code _currLine _currCol _lines _mappings) = + let size = BSLazy.length $ B.toLazyByteString bsBuilder + in Builder + { _code = _code <> bsBuilder, + _currentLine = _currLine, + _currentCol = _currCol + fromIntegral size, + _lines = _lines, + _mappings = _mappings + } + +addLine :: Builder -> Builder +addLine (Builder _code _currLine _currCol _lines _mappings) = + Builder + { _code = _code <> B.char7 '\n', + _currentLine = _currLine + 1, + _currentCol = 1, + _lines = Many, + _mappings = _mappings + } + -- ENCODE stmtToBuilder :: Int -> Stmt -> Builder @@ -297,21 +356,21 @@ parensFor grouping builder = Whatever -> builder -fromExpr :: Int -> Level -> Grouping -> Expr -> (Lines, Builder) -fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression = +fromExpr :: Int -> Level -> Grouping -> Expr -> Builder -> Builder +fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression builder = case expression of String string -> - (One, "'" <> string <> "'") + addByteString ("''" <> string <> "''") builder Float float -> - (One, float) + addByteString float builder Int n -> - (One, B.intDec n) + addByteString (B.intDec n) builder Bool bool -> - (One, if bool then "true" else "false") + addAscii (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 line level Whatever) exprs @@ -337,7 +396,7 @@ fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping exp <> "}" else "{" <> commaSep builders <> "}" Ref name -> - (One, Name.toBuilder name) + addByteString (Name.toBuilder name) builder Access expr field -> makeDot line level expr field Index expr bracketedExpr -> From c52ddf78ba657a95ed5e5a07a811f732456aaea3 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 28 Mar 2023 21:12:54 +0200 Subject: [PATCH 08/47] Finish re-write of fromExpr --- compiler/src/Generate/JavaScript/Builder.hs | 231 ++++++++++---------- 1 file changed, 118 insertions(+), 113 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index d9202b216..2fef6d75f 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -21,6 +21,7 @@ where import Data.ByteString qualified as BS import Data.ByteString.Builder qualified as B import Data.ByteString.Lazy.Char8 qualified as BSLazy +import Data.Function ((&)) import Data.List qualified as List import Generate.JavaScript.Name (Name) import Generate.JavaScript.Name qualified as Name @@ -346,15 +347,28 @@ linesMap func xs = 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)) + 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 :: Int -> Level -> Grouping -> Expr -> Builder -> Builder fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression builder = @@ -372,139 +386,130 @@ fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping exp Json json -> addByteString (Json.encodeUgly json) builder Array exprs -> - (,) Many $ - let (anyMany, builders) = linesMap (fromExpr line level Whatever) exprs - in if anyMany - then - "[\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" - <> indent - <> "]" - else "[" <> commaSep builders <> "]" + builder + & addAscii "[ " + & commaSepExpr (fromExpr line level Whatever) exprs + & addAscii " ]" Object fields -> - (,) Many $ - let (anyMany, builders) = linesMap (fromField line nextLevel) fields - in if anyMany - then - "{\n" - <> deeperIndent - <> commaNewlineSep level builders - <> "\n" - <> indent - <> "}" - else "{" <> commaSep builders <> "}" + builder + & addAscii "{ " + & commaSepExpr (fromField line level) fields + & addAscii " }" Ref name -> addByteString (Name.toBuilder name) builder Access expr field -> - makeDot line level expr field + makeDot line level expr field builder Index expr bracketedExpr -> - makeBracketed line level expr bracketedExpr + makeBracketed line level expr bracketedExpr builder Prefix op expr -> - let (lines, builder) = fromExpr line level Atomic expr - in ( lines, - parensFor grouping (fromPrefix op <> builder) - ) + parensFor grouping builder $ \b -> + b + & fromPrefix op + & fromExpr line level Atomic expr Infix op leftExpr rightExpr -> - let (leftLines, left) = fromExpr line level Atomic leftExpr - (rightLines, right) = fromExpr line level Atomic rightExpr - in ( merge leftLines rightLines, - parensFor grouping (left <> fromInfix op <> right) - ) + parensFor grouping builder $ \b -> + b + & fromExpr line level Atomic leftExpr + & fromInfix op + & fromExpr line level Atomic rightExpr If condExpr thenExpr elseExpr -> - let condB = snd (fromExpr line level Atomic condExpr) - thenB = snd (fromExpr line level Atomic thenExpr) - elseB = snd (fromExpr line level Atomic elseExpr) - in ( Many, - parensFor grouping (condB <> " ? " <> thenB <> " : " <> elseB) - ) + parensFor grouping builder $ \b -> + b + & fromExpr line level Atomic condExpr + & addAscii " ? " + & fromExpr line level Atomic thenExpr + & addAscii " : " + & fromExpr line level Atomic elseExpr Assign lValue expr -> - let (leftLines, left) = fromLValue line level lValue - (rightLines, right) = fromExpr line level Whatever expr - in ( merge leftLines rightLines, - parensFor grouping (left <> " = " <> right) - ) + parensFor grouping builder $ \b -> + b + & fromLValue line level lValue + & addAscii " = " + & fromExpr line level Whatever expr Call function args -> - (,) Many $ - let (_, funcB) = fromExpr line level Atomic function - (anyMany, argsB) = linesMap (fromExpr line nextLevel Whatever) args - in if anyMany - then funcB <> "(\n" <> deeperIndent <> commaNewlineSep level argsB <> ")" - else funcB <> "(" <> commaSep argsB <> ")" + builder + & fromExpr line level Atomic function + & addAscii "(" + & commaSepExpr (fromExpr line nextLevel Whatever) args + & addAscii ")" Function maybeName args stmts -> - (,) Many $ - "function " - <> maybe mempty Name.toBuilder maybeName - <> "(" - <> commaSep (map Name.toBuilder args) - <> ") {\n" - <> fromStmtBlock (line + 1) nextLevel stmts - <> indent - <> "}" + builder + & addAscii "function " + & addByteString (maybe mempty Name.toBuilder maybeName) + & addAscii "(" + & commaSepExpr (\arg -> addByteString (Name.toBuilder arg)) args + & addAscii ") {" + & addLine + & fromStmtBlock (line + 1) nextLevel stmts + & addByteString indent + & addAscii "}" -- FIELDS -fromField :: Int -> Level -> (Name, Expr) -> (Lines, Builder) -fromField line level (field, expr) = - let (lines, builder) = fromExpr line level Whatever expr - in ( lines, - Name.toBuilder field <> ": " <> builder - ) +fromField :: Int -> Level -> (Name, Expr) -> Builder -> Builder +fromField line level (field, expr) builder = + builder + & addByteString (Name.toBuilder field) + & addAscii ": " + & fromExpr line level Whatever expr -- VALUES -fromLValue :: Int -> Level -> LValue -> (Lines, Builder) -fromLValue line level lValue = +fromLValue :: Int -> Level -> LValue -> Builder -> Builder +fromLValue line level lValue builder = case lValue of LRef name -> - (One, Name.toBuilder name) + addByteString (Name.toBuilder name) builder LDot expr field -> - makeDot line level expr field + makeDot line level expr field builder LBracket expr bracketedExpr -> - makeBracketed line level expr bracketedExpr - -makeDot :: Int -> Level -> Expr -> Name -> (Lines, Builder) -makeDot line level expr field = - let (lines, builder) = fromExpr line level Atomic expr - in (lines, builder <> "." <> Name.toBuilder field) - -makeBracketed :: Int -> Level -> Expr -> Expr -> (Lines, Builder) -makeBracketed line level expr bracketedExpr = - let (lines, builder) = fromExpr line level Atomic expr - (bracketedLines, bracketedBuilder) = fromExpr line level Whatever bracketedExpr - in ( merge lines bracketedLines, - builder <> "[" <> bracketedBuilder <> "]" - ) + makeBracketed line level expr bracketedExpr builder + +makeDot :: Int -> Level -> Expr -> Name -> Builder -> Builder +makeDot line level expr field builder = + builder + & fromExpr line level Atomic expr + & addAscii "." + & addByteString (Name.toBuilder field) + +makeBracketed :: Int -> Level -> Expr -> Expr -> Builder -> Builder +makeBracketed line level expr bracketedExpr builder = + builder + & fromExpr line level Atomic expr + & addAscii "[" + & fromExpr line 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 -> " >>> " From aa0cda335835a88b9583503be91e40efa73f382d Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 19 Apr 2023 22:06:44 +0200 Subject: [PATCH 09/47] Finish re-write of JavaScript/Builder.hs --- compiler/src/Generate/JavaScript/Builder.hs | 353 +++++++++++--------- 1 file changed, 196 insertions(+), 157 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 2fef6d75f..4c266f724 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -22,7 +22,6 @@ import Data.ByteString qualified as BS import Data.ByteString.Builder qualified as B import Data.ByteString.Lazy.Char8 qualified as BSLazy import Data.Function ((&)) -import Data.List qualified as List import Generate.JavaScript.Name (Name) import Generate.JavaScript.Name qualified as Name import Json.Encode qualified as Json @@ -30,19 +29,6 @@ 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 B.Builder | Float B.Builder @@ -180,16 +166,16 @@ addLine (Builder _code _currLine _currCol _lines _mappings) = stmtToBuilder :: Int -> Stmt -> Builder stmtToBuilder line stmts = - fromStmt line levelZero stmts + fromStmt levelZero stmts (emptyBuilder line) exprToBuilder :: Int -> Expr -> Builder exprToBuilder line expr = - snd $ fromExpr line levelZero Whatever expr + fromExpr levelZero Whatever expr (emptyBuilder line) -- INDENT LEVEL data Level - = Level Builder Level + = Level B.Builder Level levelZero :: Level levelZero = @@ -203,150 +189,193 @@ 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 :: Int -> Level -> [Stmt] -> Builder -fromStmtBlock line level stmts = - mconcat (map (fromStmt line level) stmts) +fromStmtBlock :: Level -> [Stmt] -> Builder -> Builder +fromStmtBlock level stmts builder = + foldl (\accBuilder stmt -> fromStmt level stmt accBuilder) builder stmts -fromStmt :: Int -> Level -> Stmt -> Builder -fromStmt line level@(Level indent nextLevel) statement = +fromStmt :: Level -> Stmt -> Builder -> Builder +fromStmt level@(Level indent nextLevel) statement builder = case statement of Block stmts -> - fromStmtBlock line level stmts + fromStmtBlock level stmts builder EmptyStmt -> - mempty + builder ExprStmt expr -> - indent <> snd (fromExpr line level Whatever expr) <> ";\n" + builder + & addByteString indent + & fromExpr level Whatever expr + & addAscii ";" + & addLine IfStmt condition thenStmt elseStmt -> - mconcat - [ indent, - "if (", - snd (fromExpr line level Whatever condition), - ") {\n", - fromStmt (line + 1) nextLevel thenStmt, - indent, - "} else {\n", - fromStmt (line + 2) 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 + & addAscii "}" + & addLine Switch expr clauses -> - mconcat - [ indent, - "switch (", - snd (fromExpr line level Whatever expr), - ") {\n", - mconcat (map (fromClause (line + 1) 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 line level Whatever expr), - ") {\n", - fromStmt (line + 1) 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 (line + 1) level stmt - ] + builder + & addByteString indent + & addByteString (Name.toBuilder label) + & addAscii ":" + & addLine + & fromStmt level stmt Try tryStmt errorName catchStmt -> - mconcat - [ indent, - "try {\n", - fromStmt (line + 1) nextLevel tryStmt, - indent, - "} catch (", - Name.toBuilder errorName, - ") {\n", - fromStmt line 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 line level Whatever expr) <> ";" + builder + & addByteString indent + & addAscii "throw " + & fromExpr level Whatever expr + & addAscii ";" Return expr -> - indent <> "return " <> snd (fromExpr line 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 line level Whatever expr) <> ";\n" + builder + & addByteString indent + & addAscii "var " + & addByteString (Name.toBuilder name) + & addAscii " = " + & fromExpr level Whatever expr + & addAscii ";" + & addLine Vars [] -> - mempty + builder Vars vars -> - indent <> "var " <> commaNewlineSep level (map (varToBuilder line 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 (line + 1) 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 :: Int -> Level -> Case -> Builder -fromClause line 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 line level Whatever expr) - <> ":\n" - <> fromStmtBlock (line + 1) nextLevel stmts + builder + & addByteString indent + & addAscii "case " + & fromExpr level Whatever expr + & addAscii ":" + & addLine + & fromStmtBlock nextLevel stmts Default stmts -> - indent - <> "default:\n" - <> fromStmtBlock (line + 1) 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 :: Int -> Level -> (Name, Expr) -> Builder -varToBuilder line level (name, expr) = - Name.toBuilder name <> " = " <> snd (fromExpr line 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 @@ -357,6 +386,16 @@ commaSepExpr fn exprs 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 -> Builder) -> Builder @@ -370,8 +409,8 @@ parensFor grouping builder fillContent = Whatever -> fillContent builder -fromExpr :: Int -> Level -> Grouping -> Expr -> Builder -> Builder -fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping expression builder = +fromExpr :: Level -> Grouping -> Expr -> Builder -> Builder +fromExpr level@(Level indent nextLevel) grouping expression builder = case expression of String string -> addByteString ("''" <> string <> "''") builder @@ -388,96 +427,96 @@ fromExpr line level@(Level indent nextLevel@(Level deeperIndent _)) grouping exp Array exprs -> builder & addAscii "[ " - & commaSepExpr (fromExpr line level Whatever) exprs + & commaSepExpr (fromExpr level Whatever) exprs & addAscii " ]" Object fields -> builder & addAscii "{ " - & commaSepExpr (fromField line level) fields + & commaSepExpr (fromField level) fields & addAscii " }" Ref name -> addByteString (Name.toBuilder name) builder Access expr field -> - makeDot line level expr field builder + makeDot level expr field builder Index expr bracketedExpr -> - makeBracketed line level expr bracketedExpr builder + makeBracketed level expr bracketedExpr builder Prefix op expr -> parensFor grouping builder $ \b -> b & fromPrefix op - & fromExpr line level Atomic expr + & fromExpr level Atomic expr Infix op leftExpr rightExpr -> parensFor grouping builder $ \b -> b - & fromExpr line level Atomic leftExpr + & fromExpr level Atomic leftExpr & fromInfix op - & fromExpr line level Atomic rightExpr + & fromExpr level Atomic rightExpr If condExpr thenExpr elseExpr -> parensFor grouping builder $ \b -> b - & fromExpr line level Atomic condExpr + & fromExpr level Atomic condExpr & addAscii " ? " - & fromExpr line level Atomic thenExpr + & fromExpr level Atomic thenExpr & addAscii " : " - & fromExpr line level Atomic elseExpr + & fromExpr level Atomic elseExpr Assign lValue expr -> parensFor grouping builder $ \b -> b - & fromLValue line level lValue + & fromLValue level lValue & addAscii " = " - & fromExpr line level Whatever expr + & fromExpr level Whatever expr Call function args -> builder - & fromExpr line level Atomic function + & fromExpr level Atomic function & addAscii "(" - & commaSepExpr (fromExpr line nextLevel Whatever) args + & commaSepExpr (fromExpr nextLevel Whatever) args & addAscii ")" Function maybeName args stmts -> builder & addAscii "function " & addByteString (maybe mempty Name.toBuilder maybeName) & addAscii "(" - & commaSepExpr (\arg -> addByteString (Name.toBuilder arg)) args + & commaSepExpr (addByteString . Name.toBuilder) args & addAscii ") {" & addLine - & fromStmtBlock (line + 1) nextLevel stmts + & fromStmtBlock nextLevel stmts & addByteString indent & addAscii "}" -- FIELDS -fromField :: Int -> Level -> (Name, Expr) -> Builder -> Builder -fromField line level (field, expr) builder = +fromField :: Level -> (Name, Expr) -> Builder -> Builder +fromField level (field, expr) builder = builder & addByteString (Name.toBuilder field) & addAscii ": " - & fromExpr line level Whatever expr + & fromExpr level Whatever expr -- VALUES -fromLValue :: Int -> Level -> LValue -> Builder -> Builder -fromLValue line level lValue builder = +fromLValue :: Level -> LValue -> Builder -> Builder +fromLValue level lValue builder = case lValue of LRef name -> addByteString (Name.toBuilder name) builder LDot expr field -> - makeDot line level expr field builder + makeDot level expr field builder LBracket expr bracketedExpr -> - makeBracketed line level expr bracketedExpr builder + makeBracketed level expr bracketedExpr builder -makeDot :: Int -> Level -> Expr -> Name -> Builder -> Builder -makeDot line level expr field builder = +makeDot :: Level -> Expr -> Name -> Builder -> Builder +makeDot level expr field builder = builder - & fromExpr line level Atomic expr + & fromExpr level Atomic expr & addAscii "." & addByteString (Name.toBuilder field) -makeBracketed :: Int -> Level -> Expr -> Expr -> Builder -> Builder -makeBracketed line level expr bracketedExpr builder = +makeBracketed :: Level -> Expr -> Expr -> Builder -> Builder +makeBracketed level expr bracketedExpr builder = builder - & fromExpr line level Atomic expr + & fromExpr level Atomic expr & addAscii "[" - & fromExpr line level Whatever bracketedExpr + & fromExpr level Whatever bracketedExpr & addAscii "]" -- OPERATORS From 3773f9dd2cf1eebfd9e33e2342fad33de94c21f6 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 28 Apr 2023 11:04:04 +0200 Subject: [PATCH 10/47] Finish re-write of Generate/JavaScript Builder --- compiler/src/Generate/JavaScript.hs | 50 +++++++-------------- compiler/src/Generate/JavaScript/Builder.hs | 17 ++++--- 2 files changed, 26 insertions(+), 41 deletions(-) diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index e2396c76a..984682f9a 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -102,55 +102,46 @@ print ansi localizer home name tipe = -- GRAPH TRAVERSAL STATE data State = State - { _revKernels :: [B.Builder], - _revBuilders :: [B.Builder], - _seenGlobals :: Set.Set Opt.Global, - _mappings :: Int + { _seenGlobals :: Set.Set Opt.Global, + _builder :: JS.Builder } emptyState :: Int -> State emptyState startingLine = - State mempty [] Set.empty startingLine + State Set.empty (JS.emptyBuilder startingLine) stateToBuilder :: State -> B.Builder -stateToBuilder (State revKernels revBuilders _ _) = - prependBuilders revKernels (prependBuilders revBuilders mempty) - -prependBuilders :: [B.Builder] -> B.Builder -> B.Builder -prependBuilders revBuilders monolith = - List.foldl' (\m b -> b <> m) monolith revBuilders +stateToBuilder (State _ builder) = + JS._code builder -- ADD DEPENDENCIES addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State -addGlobal mode graph state@(State revKernels builders seen mappings) 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) mappings + State (Set.insert global seen) builder addGlobalHelp :: Mode.Mode -> Graph -> Opt.Global -> State -> State -addGlobalHelp mode graph global state@(State _ _ _ mapping) = +addGlobalHelp mode graph global state = let addDeps deps someState = Set.foldl' (addGlobal mode graph) someState deps in case graph ! global of Opt.Define expr deps -> addStmt - mapping (addDeps deps state) ( var global (Expr.generate mode expr) ) Opt.DefineTailFunc argNames body deps -> addStmt - mapping (addDeps deps state) ( let (Opt.Global _ name) = global in var global (Expr.generateTailDef mode name argNames body) ) Opt.Ctor index arity -> addStmt - mapping state ( var global (Expr.generateCtor mode global index arity) ) @@ -158,7 +149,6 @@ addGlobalHelp mode graph global state@(State _ _ _ mapping) = addGlobal mode graph state linkedGlobal Opt.Cycle names values functions deps -> addStmt - mapping (addDeps deps state) ( generateCycle mode global names values functions ) @@ -170,40 +160,32 @@ addGlobalHelp mode graph global state@(State _ _ _ mapping) = else addKernel (addDeps deps state) (generateKernel mode chunks) Opt.Enum index -> addStmt - mapping state ( generateEnum mode global index ) Opt.Box -> addStmt - mapping (addGlobal mode graph state identity) ( generateBox mode global ) Opt.PortIncoming decoder deps -> addStmt - mapping (addDeps deps state) ( generatePort mode global "incomingPort" decoder ) Opt.PortOutgoing encoder deps -> addStmt - mapping (addDeps deps state) ( generatePort mode global "outgoingPort" encoder ) -addStmt :: Int -> State -> JS.Stmt -> State -addStmt line state stmt = - addBuilder state (JS.stmtToBuilder line stmt) - -addBuilder :: State -> B.Builder -> State -addBuilder (State revKernels revBuilders seen mappings) builder = - State revKernels (builder : revBuilders) seen mappings +addStmt :: State -> JS.Stmt -> State +addStmt (State seen builder) stmt = + State seen (JS.stmtToBuilder stmt builder) addKernel :: State -> B.Builder -> State -addKernel (State revKernels revBuilders seen mappings) kernel = - State (kernel : revKernels) revBuilders seen mappings +addKernel (State seen builder) kernel = + State seen (JS.addByteString kernel builder) var :: Opt.Global -> Expr.Code -> JS.Stmt var (Opt.Global home name) code = @@ -346,7 +328,7 @@ generatePort mode (Opt.Global home name) makePort converter = -- GENERATE MANAGER generateManager :: Mode.Mode -> Graph -> Opt.Global -> Opt.EffectsType -> State -> State -generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state@(State _ _ _ mapping) = +generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) _) effectsType state = let managerLVar = JS.LBracket (JS.Ref (JsName.fromKernel Name.platform "effectManagers")) @@ -359,7 +341,7 @@ generateManager mode graph (Opt.Global home@(ModuleName.Canonical _ moduleName) JS.ExprStmt $ JS.Assign managerLVar $ JS.Call (JS.Ref (JsName.fromKernel Name.platform "createManager")) args - in addStmt mapping (List.foldl' (addGlobal mode graph) state deps) $ + in addStmt (List.foldl' (addGlobal mode graph) state deps) $ JS.Block (createManager : stmts) generateLeaf :: ModuleName.Canonical -> Name.Name -> JS.Stmt @@ -410,7 +392,7 @@ generateExports mode (Trie maybeMain subs) = "{" Just (home, main) -> "{'init':" - <> JS.exprToBuilder 0 (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 4c266f724..1487ac182 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -2,8 +2,11 @@ {-# OPTIONS_GHC -Wall #-} module Generate.JavaScript.Builder - ( stmtToBuilder, + ( Builder (..), + emptyBuilder, + stmtToBuilder, exprToBuilder, + addByteString, Expr (..), LValue (..), Stmt (..), @@ -164,13 +167,13 @@ addLine (Builder _code _currLine _currCol _lines _mappings) = -- ENCODE -stmtToBuilder :: Int -> Stmt -> Builder -stmtToBuilder line stmts = - fromStmt levelZero stmts (emptyBuilder line) +stmtToBuilder :: Stmt -> Builder -> Builder +stmtToBuilder stmt builder = + fromStmt levelZero stmt builder -exprToBuilder :: Int -> Expr -> Builder -exprToBuilder line expr = - fromExpr levelZero Whatever expr (emptyBuilder line) +exprToBuilder :: Expr -> Builder -> Builder +exprToBuilder expr builder = + fromExpr levelZero Whatever expr builder -- INDENT LEVEL From 6076e115e070b4c0c569b818b1a256216b9acc10 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 2 May 2023 21:10:46 +0200 Subject: [PATCH 11/47] Remove unused data type. --- compiler/src/Generate/JavaScript/Builder.hs | 13 +++---------- 1 file changed, 3 insertions(+), 10 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 1487ac182..c183b3c0d 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -113,7 +113,6 @@ data Builder = Builder { _code :: B.Builder, _currentLine :: Int, _currentCol :: Int, - _lines :: Lines, _mappings :: [Mapping] } @@ -128,40 +127,36 @@ emptyBuilder currentLine = { _code = mempty, _currentLine = currentLine, _currentCol = 1, - _lines = One, _mappings = [] } addAscii :: String -> Builder -> Builder -addAscii code (Builder _code _currLine _currCol _lines _mappings) = +addAscii code (Builder _code _currLine _currCol _mappings) = Builder { _code = _code <> B.string7 code, _currentLine = _currLine, _currentCol = _currCol + length code, - _lines = _lines, _mappings = _mappings } -- TODO: This is a crutch used during prototyping -- Should be removed once things stabalizes as it's bad for perf addByteString :: B.Builder -> Builder -> Builder -addByteString bsBuilder (Builder _code _currLine _currCol _lines _mappings) = +addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = let size = BSLazy.length $ B.toLazyByteString bsBuilder in Builder { _code = _code <> bsBuilder, _currentLine = _currLine, _currentCol = _currCol + fromIntegral size, - _lines = _lines, _mappings = _mappings } addLine :: Builder -> Builder -addLine (Builder _code _currLine _currCol _lines _mappings) = +addLine (Builder _code _currLine _currCol _mappings) = Builder { _code = _code <> B.char7 '\n', _currentLine = _currLine + 1, _currentCol = 1, - _lines = Many, _mappings = _mappings } @@ -377,8 +372,6 @@ varToBuilder level (name, expr) builder = -- EXPRESSIONS -data Lines = One | Many deriving (Eq) - commaSepExpr :: (a -> Builder -> Builder) -> [a] -> Builder -> Builder commaSepExpr fn exprs builder = case exprs of From edf50aba981780949b09d5b5d4f8480b889540cc Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 2 May 2023 22:12:47 +0200 Subject: [PATCH 12/47] Include inlined source maps when compiling projects. The actual source map generation is not done. --- builder/src/Generate.hs | 15 +++---- compiler/src/Generate/JavaScript.hs | 17 ++++++-- compiler/src/Generate/JavaScript/Builder.hs | 1 + compiler/src/Generate/SourceMap.hs | 22 +++++++++++ gren.cabal | 1 + terminal/src/Make.hs | 44 +++++++++++---------- 6 files changed, 67 insertions(+), 33 deletions(-) create mode 100644 compiler/src/Generate/SourceMap.hs diff --git a/builder/src/Generate.hs b/builder/src/Generate.hs index a0623a6b9..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 @@ -46,20 +46,18 @@ debug root details (Build.Artifacts pkg ifaces roots modules) = let mode = Mode.Dev (Just types) let graph = objectsToGlobalGraph objects let mains = gatherMains pkg objects roots - let (JS.GeneratedResult state) = JS.generate mode graph mains - return state + 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 let mode = Mode.Dev Nothing let graph = objectsToGlobalGraph objects let mains = gatherMains pkg objects roots - let (JS.GeneratedResult state) = JS.generate mode graph mains - return state + 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 @@ -67,8 +65,7 @@ prod root details (Build.Artifacts pkg _ roots modules) = let graph = objectsToGlobalGraph objects let mode = Mode.Prod (Mode.shortenFieldNames graph) let mains = gatherMains pkg objects roots - let (JS.GeneratedResult state) = JS.generate mode graph mains - return state + return $ JS.generate mode graph mains repl :: FilePath -> Details.Details -> Bool -> Build.ReplArtifacts -> N.Name -> Task B.Builder repl root details ansi (Build.ReplArtifacts home modules localizer annotations) name = diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 984682f9a..f05126e1a 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -23,6 +23,7 @@ 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.Doc qualified as D @@ -36,8 +37,10 @@ type Graph = Map.Map Opt.Global Opt.Node type Mains = Map.Map ModuleName.Canonical Opt.Main -newtype GeneratedResult = GeneratedResult - {_source :: B.Builder} +data GeneratedResult = GeneratedResult + { _source :: B.Builder, + _sourceMap :: SourceMap.SourceMap + } prelude :: B.Builder prelude = @@ -56,7 +59,11 @@ generate mode (Opt.GlobalGraph graph _) mains = <> stateToBuilder state <> toMainExports mode mains <> "}(this.module ? this.module.exports : this));" - in GeneratedResult {_source = builder} + sourceMap = SourceMap.generate $ stateToMappings state + in GeneratedResult + { _source = builder, + _sourceMap = sourceMap + } addMain :: Mode.Mode -> Graph -> ModuleName.Canonical -> Opt.Main -> State -> State addMain mode graph home _ state = @@ -114,6 +121,10 @@ stateToBuilder :: State -> B.Builder stateToBuilder (State _ builder) = JS._code builder +stateToMappings :: State -> [JS.Mapping] +stateToMappings (State _ builder) = + JS._mappings builder + -- ADD DEPENDENCIES addGlobal :: Mode.Mode -> Graph -> State -> Opt.Global -> State diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index c183b3c0d..227b1e9e5 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -3,6 +3,7 @@ module Generate.JavaScript.Builder ( Builder (..), + Mapping (..), emptyBuilder, stmtToBuilder, exprToBuilder, diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs new file mode 100644 index 000000000..55d4fd3b1 --- /dev/null +++ b/compiler/src/Generate/SourceMap.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Generate.SourceMap (SourceMap, generate, sandwhich, toBytes) where + +import Data.ByteString.Builder qualified as B +import Generate.JavaScript.Builder qualified as JS + +newtype SourceMap = SourceMap B.Builder + +generate :: [JS.Mapping] -> SourceMap +generate _ = SourceMap $ B.char7 '\0' + +sandwhich :: SourceMap -> B.Builder -> B.Builder +sandwhich (SourceMap mapBytes) sourceBytes = + sourceBytes + <> "\n" + <> "//# sourceMappingURL=data:application/json;base64," + <> mapBytes + +toBytes :: SourceMap -> B.Builder +toBytes (SourceMap bytes) = + bytes diff --git a/gren.cabal b/gren.cabal index a165101f7..04187d81f 100644 --- a/gren.cabal +++ b/gren.cabal @@ -152,6 +152,7 @@ Common gren-common Generate.JavaScript.Functions Generate.JavaScript.Name Generate.Mode + Generate.SourceMap Nitpick.Debug Nitpick.PatternMatches Optimize.Case diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index 29c2c325e..a7020eb6e 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -20,7 +20,9 @@ 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 qualified as SourceMap import Gren.Details qualified as Details import Gren.ModuleName qualified as ModuleName import Gren.Platform qualified as Platform @@ -64,7 +66,7 @@ run paths flags@(Flags _ _ maybeOutput report) = 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 _) = @@ -100,47 +102,47 @@ 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 + writeToDisk style "index.html" (Html.sandwich name (SourceMap.sandwhich sourceMap source)) (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 + writeToDisk style "app" (SourceMap.sandwhich sourceMap (Node.sandwich name source)) (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 + writeToDisk style "index.js" (SourceMap.sandwhich sourceMap source) (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 + Task.io $ B.hPutBuilder IO.stdout (SourceMap.sandwhich sourceMap source) 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 + writeToDisk style target (SourceMap.sandwhich sourceMap (Node.sandwich name source)) (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 + writeToDisk style target (SourceMap.sandwhich sourceMap source) (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 + writeToDisk style target (Html.sandwich name (SourceMap.sandwhich sourceMap source)) (NE.List name []) _ -> do Task.throw Exit.MakeHtmlOnlyForBrowserPlatform @@ -251,22 +253,22 @@ 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 = +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 From ceddabc5625e060227c95e465a76578145fcf074 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 2 May 2023 22:25:07 +0200 Subject: [PATCH 13/47] Fix code generation bugs from re-write. --- compiler/src/Generate/JavaScript/Builder.hs | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 227b1e9e5..5413fcd9d 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -219,6 +219,7 @@ fromStmt level@(Level indent nextLevel) statement builder = & addAscii "} else {" & addLine & fromStmt nextLevel elseStmt + & addByteString indent & addAscii "}" & addLine Switch expr clauses -> @@ -410,7 +411,7 @@ fromExpr :: Level -> Grouping -> Expr -> Builder -> Builder fromExpr level@(Level indent nextLevel) grouping expression builder = case expression of String string -> - addByteString ("''" <> string <> "''") builder + addByteString ("'" <> string <> "'") builder Float float -> addByteString float builder Int n -> From c824975eb1804bd8b5d7be5b7ff378c2cfd2b18e Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 12 May 2023 23:30:00 +0200 Subject: [PATCH 14/47] Correctly generate the source map object (without contents) --- compiler/src/Generate/SourceMap.hs | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 55d4fd3b1..e466a26ac 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -2,13 +2,31 @@ module Generate.SourceMap (SourceMap, generate, sandwhich, toBytes) 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 Generate.JavaScript.Builder qualified as JS +import Json.Encode qualified as Json +import Json.String qualified as JStr newtype SourceMap = SourceMap B.Builder generate :: [JS.Mapping] -> SourceMap -generate _ = SourceMap $ B.char7 '\0' +generate _ = + Json.object + [ (JStr.fromChars "version", Json.int 3), + (JStr.fromChars "sources", Json.array []), + (JStr.fromChars "sourcesContent", Json.array []), + (JStr.fromChars "names", Json.array []), + (JStr.fromChars "mappings", Json.chars "") + ] + & Json.encodeUgly + & B.toLazyByteString + & BLazy.toStrict + & Base64.encode + & B.byteString + & SourceMap sandwhich :: SourceMap -> B.Builder -> B.Builder sandwhich (SourceMap mapBytes) sourceBytes = From 67302dc0d5459988cfdeeddc0325ed178332d7e1 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Sat, 13 May 2023 14:17:46 +0200 Subject: [PATCH 15/47] Track global variables when generating sourcemaps. --- compiler/src/Generate/JavaScript/Builder.hs | 43 ++++++++++++-- .../src/Generate/JavaScript/Expression.hs | 4 +- compiler/src/Generate/SourceMap.hs | 58 ++++++++++++++++--- 3 files changed, 88 insertions(+), 17 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 5413fcd9d..d150caa99 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -26,9 +26,12 @@ import Data.ByteString qualified as BS 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 @@ -43,6 +46,7 @@ data Expr | Array [Expr] | Object [(Name, Expr)] | Ref Name + | TrackedRef A.Position ModuleName.Canonical Name Name | Access Expr Name -- foo.bar | Index Expr Expr -- foo[bar] | Prefix PrefixOp Expr @@ -112,21 +116,25 @@ data PrefixOp data Builder = Builder { _code :: B.Builder, - _currentLine :: Int, - _currentCol :: Int, + _currentLine :: Word16, + _currentCol :: Word16, _mappings :: [Mapping] } data Mapping = Mapping - { _m_line :: Int, - _m_col :: Int + { _m_src_line :: Word16, + _m_src_col :: Word16, + _m_src_module :: ModuleName.Canonical, + _m_src_name :: Name, + _m_gen_line :: Word16, + _m_gen_col :: Word16 } emptyBuilder :: Int -> Builder emptyBuilder currentLine = Builder { _code = mempty, - _currentLine = currentLine, + _currentLine = fromIntegral currentLine, _currentCol = 1, _mappings = [] } @@ -136,7 +144,7 @@ addAscii code (Builder _code _currLine _currCol _mappings) = Builder { _code = _code <> B.string7 code, _currentLine = _currLine, - _currentCol = _currCol + length code, + _currentCol = _currCol + fromIntegral (length code), _mappings = _mappings } @@ -152,6 +160,27 @@ addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = _mappings = _mappings } +addName :: A.Position -> ModuleName.Canonical -> Name -> Name -> Builder -> Builder +addName (A.Position line col) moduleName 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 = name, + _m_gen_line = _currLine, + _m_gen_col = _currCol + } + ) + : _mappings + } + addLine :: Builder -> Builder addLine (Builder _code _currLine _currCol _mappings) = Builder @@ -434,6 +463,8 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & addAscii " }" Ref name -> addByteString (Name.toBuilder name) builder + TrackedRef position moduleName name generatedName -> + addName position moduleName name generatedName builder Access expr field -> makeDot level expr field builder Index expr bracketedExpr -> diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 523224c68..fba15bee4 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -60,8 +60,8 @@ generate mode expression = JsExpr $ JS.Float (Utf8.toBuilder float) Opt.VarLocal _region name -> JsExpr $ JS.Ref (JsName.fromLocal name) - Opt.VarGlobal _region (Opt.Global home name) -> - JsExpr $ JS.Ref (JsName.fromGlobal home name) + Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> + JsExpr $ JS.TrackedRef startPos home (JsName.fromLocal name) (JsName.fromGlobal home name) Opt.VarEnum _region (Opt.Global home name) index -> case mode of Mode.Dev _ -> diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index e466a26ac..554e3d7c9 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -7,27 +7,67 @@ import Data.ByteString.Builder qualified as B import Data.ByteString.Lazy qualified as BLazy import Data.Function ((&)) import Generate.JavaScript.Builder qualified as JS +import Generate.JavaScript.Name qualified as JsName +import Gren.ModuleName qualified as ModuleName import Json.Encode qualified as Json import Json.String qualified as JStr newtype SourceMap = SourceMap B.Builder generate :: [JS.Mapping] -> SourceMap -generate _ = - Json.object - [ (JStr.fromChars "version", Json.int 3), - (JStr.fromChars "sources", Json.array []), - (JStr.fromChars "sourcesContent", Json.array []), - (JStr.fromChars "names", Json.array []), - (JStr.fromChars "mappings", Json.chars "") - ] - & Json.encodeUgly +generate mappings = + mappings + & parseMappings + & mappingsToJson + & Json.encode & B.toLazyByteString & BLazy.toStrict & Base64.encode & B.byteString & SourceMap +data Mappings = Mappings + { _m_sources :: [String], + _m_names :: [String], + _m_vlqs :: [Json.Value] + } + +parseMappings :: [JS.Mapping] -> Mappings +parseMappings mappings = + parseMappingsHelp mappings $ + Mappings + { _m_sources = [], + _m_names = [], + _m_vlqs = [] + } + +parseMappingsHelp :: [JS.Mapping] -> Mappings -> Mappings +parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = + case mappings of + [] -> acc + first : rest -> + parseMappingsHelp rest $ + Mappings srcs nms $ + Json.object + [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), + (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), + (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), + (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), + (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), + (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col first) + ] + : vlqs + +mappingsToJson :: Mappings -> Json.Value +mappingsToJson mappings = + Json.object + [ (JStr.fromChars "version", Json.int 3), + (JStr.fromChars "sources", Json.array $ map Json.chars $ _m_sources mappings), + (JStr.fromChars "sourcesContent", Json.array []), + (JStr.fromChars "names", Json.array $ map Json.chars $ _m_names mappings), + (JStr.fromChars "mappings", Json.array $ _m_vlqs mappings) + ] + sandwhich :: SourceMap -> B.Builder -> B.Builder sandwhich (SourceMap mapBytes) sourceBytes = sourceBytes From d7c770ab91c837812fca21583b653d6cfbe3deb2 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Sat, 13 May 2023 19:01:04 +0200 Subject: [PATCH 16/47] Fill sources and names fields of source map. --- compiler/src/Generate/JavaScript/Name.hs | 10 +++ compiler/src/Generate/SourceMap.hs | 84 ++++++++++++++++++------ 2 files changed, 75 insertions(+), 19 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Name.hs b/compiler/src/Generate/JavaScript/Name.hs index f01827150..47d43a980 100644 --- a/compiler/src/Generate/JavaScript/Name.hs +++ b/compiler/src/Generate/JavaScript/Name.hs @@ -269,3 +269,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/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 554e3d7c9..b195ecb5d 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -6,6 +6,9 @@ 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.Map.Strict qualified as Map +import Data.Maybe qualified as Maybe +import Data.Name qualified as Name import Generate.JavaScript.Builder qualified as JS import Generate.JavaScript.Name qualified as JsName import Gren.ModuleName qualified as ModuleName @@ -27,8 +30,8 @@ generate mappings = & SourceMap data Mappings = Mappings - { _m_sources :: [String], - _m_names :: [String], + { _m_sources :: ArrayBuilder Name.Name, + _m_names :: ArrayBuilder JsName.Name, _m_vlqs :: [Json.Value] } @@ -36,8 +39,8 @@ parseMappings :: [JS.Mapping] -> Mappings parseMappings mappings = parseMappingsHelp mappings $ Mappings - { _m_sources = [], - _m_names = [], + { _m_sources = emptyArrayBuilder, + _m_names = emptyArrayBuilder, _m_vlqs = [] } @@ -46,26 +49,69 @@ parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = case mappings of [] -> acc first : rest -> - parseMappingsHelp rest $ - Mappings srcs nms $ - Json.object - [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), - (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), - (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), - (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), - (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), - (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col first) - ] - : vlqs + let newSources = insertIntoArrayBuilder (ModuleName._module $ JS._m_src_module first) srcs + newNames = insertIntoArrayBuilder (JS._m_src_name first) nms + in parseMappingsHelp rest $ + Mappings newSources newNames $ + Json.object + [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), + (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), + (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), + (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexArrayBuilder (ModuleName._module $ JS._m_src_module first) newSources), + (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), + (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexArrayBuilder (JS._m_src_name first) newNames), + (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), + (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col first) + ] + : vlqs + +-- Array builder + +data ArrayBuilder a = ArrayBuilder + { _ab_nextIndex :: Int, + _ab_values :: Map.Map a Int + } + +emptyArrayBuilder :: ArrayBuilder a +emptyArrayBuilder = + ArrayBuilder + { _ab_nextIndex = 0, + _ab_values = Map.empty + } + +insertIntoArrayBuilder :: Ord a => a -> ArrayBuilder a -> ArrayBuilder a +insertIntoArrayBuilder value builder@(ArrayBuilder nextIndex values) = + case Map.lookup value values of + Just _ -> + builder + Nothing -> + ArrayBuilder + { _ab_nextIndex = nextIndex + 1, + _ab_values = Map.insert value nextIndex values + } + +lookupIndexArrayBuilder :: Ord a => a -> ArrayBuilder a -> Maybe Int +lookupIndexArrayBuilder value (ArrayBuilder _ values) = + Map.lookup value values + +arrayBuilderToList :: ArrayBuilder a -> [a] +arrayBuilderToList (ArrayBuilder _ values) = + values + & Map.toList + & map (\(val, idx) -> (idx, val)) + & Map.fromList + & Map.elems + +--- mappingsToJson :: Mappings -> Json.Value -mappingsToJson mappings = +mappingsToJson (Mappings sources names vlqs) = Json.object [ (JStr.fromChars "version", Json.int 3), - (JStr.fromChars "sources", Json.array $ map Json.chars $ _m_sources mappings), + (JStr.fromChars "sources", Json.array $ map ModuleName.encode $ arrayBuilderToList sources), (JStr.fromChars "sourcesContent", Json.array []), - (JStr.fromChars "names", Json.array $ map Json.chars $ _m_names mappings), - (JStr.fromChars "mappings", Json.array $ _m_vlqs mappings) + (JStr.fromChars "names", Json.array $ map (Json.String . JsName.toBuilder) $ arrayBuilderToList names), + (JStr.fromChars "mappings", Json.array vlqs) ] sandwhich :: SourceMap -> B.Builder -> B.Builder From a0273c8e92549a81fa361a74bf691abd72d2c716 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Sun, 14 May 2023 09:34:48 +0200 Subject: [PATCH 17/47] Fix compilation of kernel code. --- compiler/src/Generate/JavaScript.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index f05126e1a..344890824 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -168,7 +168,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 From 42d313426a1c01ca2f33295d5e62ad3179410e1a Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Sun, 14 May 2023 11:27:44 +0200 Subject: [PATCH 18/47] Fix bad line counts when kernel code is involved. --- compiler/src/Generate/JavaScript.hs | 2 +- compiler/src/Generate/JavaScript/Builder.hs | 25 +++++++++++++++------ 2 files changed, 19 insertions(+), 8 deletions(-) diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 344890824..ec9eb1ab0 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -49,7 +49,7 @@ prelude = firstGeneratedLineNumber :: Int firstGeneratedLineNumber = - length $ lines $ BLazy.unpack $ B.toLazyByteString prelude + (fromIntegral $ BLazy.count '\n' $ B.toLazyByteString prelude) + 1 generate :: Mode.Mode -> Opt.GlobalGraph -> Mains -> GeneratedResult generate mode (Opt.GlobalGraph graph _) mains = diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index d150caa99..b0ce64986 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -152,13 +152,24 @@ addAscii code (Builder _code _currLine _currCol _mappings) = -- Should be removed once things stabalizes as it's bad for perf addByteString :: B.Builder -> Builder -> Builder addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = - let size = BSLazy.length $ B.toLazyByteString bsBuilder - in Builder - { _code = _code <> bsBuilder, - _currentLine = _currLine, - _currentCol = _currCol + fromIntegral size, - _mappings = _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 + } addName :: A.Position -> ModuleName.Canonical -> Name -> Name -> Builder -> Builder addName (A.Position line col) moduleName name genName (Builder _code _currLine _currCol _mappings) = From 831995bdd40882ee55965c3d278507d045d500f1 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 15 May 2023 22:24:55 +0200 Subject: [PATCH 19/47] Fix line numbers being off by 2-3 lines. --- compiler/src/Generate/Html.hs | 4 +- compiler/src/Generate/JavaScript.hs | 2 +- compiler/src/Generate/Node.hs | 4 +- compiler/src/Generate/SourceMap.hs | 71 ++++++++++++++--------------- terminal/src/Make.hs | 14 +++--- 5 files changed, 48 insertions(+), 47 deletions(-) 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 ec9eb1ab0..b1dc0614e 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -59,7 +59,7 @@ generate mode (Opt.GlobalGraph graph _) mains = <> stateToBuilder state <> toMainExports mode mains <> "}(this.module ? this.module.exports : this));" - sourceMap = SourceMap.generate $ stateToMappings state + sourceMap = SourceMap.wrap $ stateToMappings state in GeneratedResult { _source = builder, _sourceMap = sourceMap 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 index b195ecb5d..a185d84da 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -1,6 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} -module Generate.SourceMap (SourceMap, generate, sandwhich, toBytes) where +module Generate.SourceMap (SourceMap, wrap, generateOnto) where import Data.ByteString.Base64 qualified as Base64 import Data.ByteString.Builder qualified as B @@ -15,11 +15,22 @@ import Gren.ModuleName qualified as ModuleName import Json.Encode qualified as Json import Json.String qualified as JStr -newtype SourceMap = SourceMap B.Builder +newtype SourceMap = SourceMap [JS.Mapping] -generate :: [JS.Mapping] -> SourceMap -generate mappings = +wrap :: [JS.Mapping] -> SourceMap +wrap mappings = SourceMap mappings + +generateOnto :: Int -> SourceMap -> B.Builder -> B.Builder +generateOnto leadingLines (SourceMap mappings) sourceBytes = + sourceBytes + <> "\n" + <> "//# sourceMappingURL=data:application/json;base64," + <> generate leadingLines mappings + +generate :: Int -> [JS.Mapping] -> B.Builder +generate leadingLines mappings = mappings + & map (\mapping -> mapping {JS._m_gen_line = (JS._m_gen_line mapping) + fromIntegral leadingLines}) & parseMappings & mappingsToJson & Json.encode @@ -27,11 +38,10 @@ generate mappings = & BLazy.toStrict & Base64.encode & B.byteString - & SourceMap data Mappings = Mappings - { _m_sources :: ArrayBuilder Name.Name, - _m_names :: ArrayBuilder JsName.Name, + { _m_sources :: OrderedListBuilder Name.Name, + _m_names :: OrderedListBuilder JsName.Name, _m_vlqs :: [Json.Value] } @@ -39,8 +49,8 @@ parseMappings :: [JS.Mapping] -> Mappings parseMappings mappings = parseMappingsHelp mappings $ Mappings - { _m_sources = emptyArrayBuilder, - _m_names = emptyArrayBuilder, + { _m_sources = emptyOrderedListBuilder, + _m_names = emptyOrderedListBuilder, _m_vlqs = [] } @@ -49,17 +59,17 @@ parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = case mappings of [] -> acc first : rest -> - let newSources = insertIntoArrayBuilder (ModuleName._module $ JS._m_src_module first) srcs - newNames = insertIntoArrayBuilder (JS._m_src_name first) nms + let newSources = insertIntoOrderedListBuilder (ModuleName._module $ JS._m_src_module first) srcs + newNames = insertIntoOrderedListBuilder (JS._m_src_name first) nms in parseMappingsHelp rest $ Mappings newSources newNames $ Json.object [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), - (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexArrayBuilder (ModuleName._module $ JS._m_src_module first) newSources), + (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (ModuleName._module $ JS._m_src_module first) newSources), (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), - (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexArrayBuilder (JS._m_src_name first) newNames), + (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name first) newNames), (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col first) ] @@ -67,43 +77,41 @@ parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = -- Array builder -data ArrayBuilder a = ArrayBuilder +data OrderedListBuilder a = OrderedListBuilder { _ab_nextIndex :: Int, _ab_values :: Map.Map a Int } -emptyArrayBuilder :: ArrayBuilder a -emptyArrayBuilder = - ArrayBuilder +emptyOrderedListBuilder :: OrderedListBuilder a +emptyOrderedListBuilder = + OrderedListBuilder { _ab_nextIndex = 0, _ab_values = Map.empty } -insertIntoArrayBuilder :: Ord a => a -> ArrayBuilder a -> ArrayBuilder a -insertIntoArrayBuilder value builder@(ArrayBuilder nextIndex values) = +insertIntoOrderedListBuilder :: Ord a => a -> OrderedListBuilder a -> OrderedListBuilder a +insertIntoOrderedListBuilder value builder@(OrderedListBuilder nextIndex values) = case Map.lookup value values of Just _ -> builder Nothing -> - ArrayBuilder + OrderedListBuilder { _ab_nextIndex = nextIndex + 1, _ab_values = Map.insert value nextIndex values } -lookupIndexArrayBuilder :: Ord a => a -> ArrayBuilder a -> Maybe Int -lookupIndexArrayBuilder value (ArrayBuilder _ values) = +lookupIndexOrderedListBuilder :: Ord a => a -> OrderedListBuilder a -> Maybe Int +lookupIndexOrderedListBuilder value (OrderedListBuilder _ values) = Map.lookup value values -arrayBuilderToList :: ArrayBuilder a -> [a] -arrayBuilderToList (ArrayBuilder _ values) = +arrayBuilderToList :: OrderedListBuilder a -> [a] +arrayBuilderToList (OrderedListBuilder _ values) = values & Map.toList & map (\(val, idx) -> (idx, val)) & Map.fromList & Map.elems ---- - mappingsToJson :: Mappings -> Json.Value mappingsToJson (Mappings sources names vlqs) = Json.object @@ -113,14 +121,3 @@ mappingsToJson (Mappings sources names vlqs) = (JStr.fromChars "names", Json.array $ map (Json.String . JsName.toBuilder) $ arrayBuilderToList names), (JStr.fromChars "mappings", Json.array vlqs) ] - -sandwhich :: SourceMap -> B.Builder -> B.Builder -sandwhich (SourceMap mapBytes) sourceBytes = - sourceBytes - <> "\n" - <> "//# sourceMappingURL=data:application/json;base64," - <> mapBytes - -toBytes :: SourceMap -> B.Builder -toBytes (SourceMap bytes) = - bytes diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index a7020eb6e..8aad72f51 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -103,15 +103,15 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = (Platform.Browser, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.html" (Html.sandwich name (SourceMap.sandwhich sourceMap source)) (NE.List name []) + writeToDisk style "index.html" (Html.sandwich name (SourceMap.generateOnto Html.leadingLines sourceMap source)) (NE.List name []) (Platform.Node, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "app" (SourceMap.sandwhich sourceMap (Node.sandwich name source)) (NE.List name []) + writeToDisk style "app" (SourceMap.generateOnto Node.leadingLines sourceMap (Node.sandwich name source)) (NE.List name []) (_, name : names) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.js" (SourceMap.sandwhich sourceMap source) (NE.List name names) + writeToDisk style "index.js" (SourceMap.generateOnto 0 sourceMap source) (NE.List name names) Just DevStdOut -> case getMains artifacts of [] -> @@ -119,7 +119,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = _ -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - Task.io $ B.hPutBuilder IO.stdout (SourceMap.sandwhich sourceMap source) + Task.io $ B.hPutBuilder IO.stdout (SourceMap.generateOnto 0 sourceMap source) Just DevNull -> return () Just (Exe target) -> @@ -127,14 +127,14 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Node -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.sandwhich sourceMap (Node.sandwich name source)) (NE.List name []) + writeToDisk style target (SourceMap.generateOnto Node.leadingLines sourceMap (Node.sandwich name source)) (NE.List name []) _ -> do Task.throw Exit.MakeExeOnlyForNodePlatform Just (JS target) -> case getNoMains artifacts of [] -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.sandwhich sourceMap source) (Build.getRootNames artifacts) + writeToDisk style target (SourceMap.generateOnto 0 sourceMap source) (Build.getRootNames artifacts) name : names -> Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) Just (Html target) -> @@ -142,7 +142,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Browser -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (Html.sandwich name (SourceMap.sandwhich sourceMap source)) (NE.List name []) + writeToDisk style target (Html.sandwich name (SourceMap.generateOnto Html.leadingLines sourceMap source)) (NE.List name []) _ -> do Task.throw Exit.MakeHtmlOnlyForBrowserPlatform From 3a71b9beab0038b488fe572e1ad0874a0659da51 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 15 May 2023 22:58:59 +0200 Subject: [PATCH 20/47] Set correct source module of tracked refs. --- compiler/src/Generate/JavaScript.hs | 14 +- .../src/Generate/JavaScript/Expression.hs | 172 +++++++++--------- 2 files changed, 93 insertions(+), 93 deletions(-) diff --git a/compiler/src/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index b1dc0614e..2c391c099 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -136,20 +136,20 @@ addGlobal mode graph state@(State seen builder) global = 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 -> addStmt (addDeps deps state) - ( var global (Expr.generate mode expr) + ( var global (Expr.generate mode home expr) ) Opt.DefineTailFunc argNames body deps -> addStmt (addDeps deps state) ( let (Opt.Global _ name) = global - in var global (Expr.generateTailDef mode name argNames body) + in var global (Expr.generateTailDef mode home name argNames body) ) Opt.Ctor index arity -> addStmt @@ -237,14 +237,14 @@ 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)) + 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 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, _) = @@ -333,7 +333,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 diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index fba15bee4..64c454164 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -36,12 +36,12 @@ 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 _region bool -> JsExpr $ JS.Bool bool @@ -61,7 +61,7 @@ generate mode expression = Opt.VarLocal _region name -> JsExpr $ JS.Ref (JsName.fromLocal name) Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> - JsExpr $ JS.TrackedRef startPos home (JsName.fromLocal name) (JsName.fromGlobal home name) + JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromLocal name) (JsName.fromGlobal home name) Opt.VarEnum _region (Opt.Global home name) index -> case mode of Mode.Dev _ -> @@ -81,23 +81,23 @@ generate mode expression = Opt.VarKernel _region home name -> JsExpr $ JS.Ref (JsName.fromKernel home name) Opt.Array entries -> - JsExpr $ JS.Array $ map (generateJsExpr mode) entries + JsExpr $ JS.Array $ map (generateJsExpr mode parentModule) entries Opt.Function args body -> - generateFunction (map JsName.fromLocal args) (generate mode body) + generateFunction (map JsName.fromLocal args) (generate mode parentModule body) Opt.Call func args -> - JsExpr $ generateCall mode func args + JsExpr $ generateCall mode parentModule 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 + JsBlock $ generateCase mode parentModule label root decider jumps Opt.Accessor field -> JsExpr $ JS.Function @@ -107,16 +107,16 @@ generate mode expression = JS.Access (JS.Ref JsName.dollar) (generateField mode field) ] Opt.Access record field -> - JsExpr $ JS.Access (generateJsExpr mode record) (generateField mode field) + JsExpr $ JS.Access (generateJsExpr mode parentModule record) (generateField mode field) Opt.Update 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 fields ] Opt.Record fields -> - JsExpr $ generateRecord mode fields + JsExpr $ generateRecord mode parentModule fields -- CODE CHUNKS @@ -186,10 +186,10 @@ ctorToInt home name index = -- RECORDS -generateRecord :: Mode.Mode -> Map.Map Name.Name Opt.Expr -> JS.Expr -generateRecord mode fields = +generateRecord :: Mode.Mode -> ModuleName.Canonical -> Map.Map Name.Name Opt.Expr -> JS.Expr +generateRecord mode parentModule fields = let toPair (field, value) = - (generateField mode field, generateJsExpr mode value) + (generateField mode field, generateJsExpr mode parentModule value) in JS.Object (map toPair (Map.toList fields)) generateField :: Mode.Mode -> Name.Name -> JsName.Name @@ -259,30 +259,30 @@ funcHelpers = -- CALLS -generateCall :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCall mode func args = +generateCall :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCall mode parentModule func args = case func of Opt.VarGlobal _region global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> - generateCoreCall mode global args + generateCoreCall mode parentModule global args Opt.VarBox _ _ -> case mode of Mode.Dev _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule func args Mode.Prod _ -> case args of [arg] -> - generateJsExpr mode arg + generateJsExpr mode parentModule arg _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule func args _ -> - generateCallHelp mode func args + generateCallHelp mode parentModule func args -generateCallHelp :: Mode.Mode -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCallHelp mode func args = +generateCallHelp :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCallHelp mode parentModule func args = generateNormalCall - (generateJsExpr mode func) - (map (generateJsExpr mode) args) + (generateJsExpr mode parentModule func) + (map (generateJsExpr mode parentModule) args) generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr generateGlobalCall home name args = @@ -303,17 +303,17 @@ 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 -> Opt.Global -> [Opt.Expr] -> JS.Expr +generateCoreCall mode parentModule (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = if moduleName == Name.basics - then generateBasicsCall mode home name args + then generateBasicsCall mode parentModule home name args else if moduleName == Name.bitwise - then generateBitwiseCall home name (map (generateJsExpr mode) args) + then generateBitwiseCall 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 home name (map (generateJsExpr mode parentModule) args) + else generateGlobalCall home name (map (generateJsExpr mode parentModule) args) generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr generateBitwiseCall home name args = @@ -334,11 +334,11 @@ generateBitwiseCall home name args = _ -> generateGlobalCall home name args -generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr -generateBasicsCall mode home name args = +generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr +generateBasicsCall mode parentModule 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 @@ -348,12 +348,12 @@ generateBasicsCall mode home name args = 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 @@ -371,7 +371,7 @@ generateBasicsCall mode home name args = "xor" -> JS.Infix JS.OpNe left right _ -> generateGlobalCall home name [left, right] _ -> - generateGlobalCall home name (map (generateJsExpr mode) args) + generateGlobalCall home name (map (generateJsExpr mode parentModule) args) generateMathCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr generateMathCall home name args = @@ -435,9 +435,9 @@ apply func value = _ -> Opt.Call func [value] -append :: Mode.Mode -> Opt.Expr -> Opt.Expr -> JS.Expr -append mode left right = - let seqs = generateJsExpr mode left : toSeqs mode right +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 +446,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 _region (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 +499,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 +513,22 @@ 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) + JS.Var (JsName.fromLocal name) (generateJsExpr mode parentModule body) Opt.TailDef name argNames body -> - JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode name argNames body)) + JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode parentModule name argNames body)) -generateTailDef :: Mode.Mode -> Name.Name -> [Name.Name] -> Opt.Expr -> Code -generateTailDef mode name argNames body = +generateTailDef :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Name.Name] -> Opt.Expr -> Code +generateTailDef mode parentModule name argNames body = generateFunction (map JsName.fromLocal argNames) $ JsBlock $ [ JS.Labelled (JsName.fromLocal name) $ JS.While (JS.Bool True) $ codeToStmt $ - generate mode body + generate mode parentModule body ] -- PATHS @@ -553,18 +553,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 +605,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 +678,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 +774,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 From b1518c89fca0b4518f5bc8d34c0505d272c6cacb Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 22 May 2023 21:15:27 +0200 Subject: [PATCH 21/47] Sort mappings by line. --- compiler/src/Generate/SourceMap.hs | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index a185d84da..4f92ba8b7 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -6,6 +6,7 @@ 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 qualified as Map import Data.Maybe qualified as Maybe import Data.Name qualified as Name @@ -18,7 +19,7 @@ import Json.String qualified as JStr newtype SourceMap = SourceMap [JS.Mapping] wrap :: [JS.Mapping] -> SourceMap -wrap mappings = SourceMap mappings +wrap = SourceMap generateOnto :: Int -> SourceMap -> B.Builder -> B.Builder generateOnto leadingLines (SourceMap mappings) sourceBytes = @@ -30,7 +31,7 @@ generateOnto leadingLines (SourceMap mappings) sourceBytes = generate :: Int -> [JS.Mapping] -> B.Builder generate leadingLines mappings = mappings - & map (\mapping -> mapping {JS._m_gen_line = (JS._m_gen_line mapping) + fromIntegral leadingLines}) + & map (\mapping -> mapping {JS._m_gen_line = JS._m_gen_line mapping + fromIntegral leadingLines}) & parseMappings & mappingsToJson & Json.encode @@ -47,7 +48,7 @@ data Mappings = Mappings parseMappings :: [JS.Mapping] -> Mappings parseMappings mappings = - parseMappingsHelp mappings $ + parseMappingsHelp (List.sortBy (\a b -> JS._m_gen_line b `compare` JS._m_gen_line a) mappings) $ Mappings { _m_sources = emptyOrderedListBuilder, _m_names = emptyOrderedListBuilder, From 3c4439511d7bae56f9b2aac5cd07f9b6435ef551 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 22 May 2023 22:20:11 +0200 Subject: [PATCH 22/47] Add function calls to source maps. --- compiler/src/AST/Optimized.hs | 6 +- compiler/src/Generate/JavaScript/Builder.hs | 19 ++++ .../src/Generate/JavaScript/Expression.hs | 86 ++++++++++--------- compiler/src/Nitpick/Debug.hs | 2 +- compiler/src/Optimize/Expression.hs | 12 +-- compiler/src/Optimize/Port.hs | 24 +++--- 6 files changed, 85 insertions(+), 64 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index f2e134f6b..dafb942ef 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -54,7 +54,7 @@ data Expr | VarKernel A.Region Name Name | Array [Expr] | Function [Name] Expr - | Call Expr [Expr] + | Call A.Region Expr [Expr] | TailCall Name [(Name, Expr)] | If [(Expr, Expr)] Expr | Let Def Expr @@ -220,7 +220,7 @@ instance Binary Expr where VarKernel a b c -> putWord8 11 >> put a >> put b >> put c Array a -> putWord8 12 >> put a 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 @@ -249,7 +249,7 @@ instance Binary Expr where 11 -> liftM3 VarKernel get get get 12 -> liftM Array 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 diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index b0ce64986..56a901091 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -54,6 +54,7 @@ data Expr | If Expr Expr Expr | Assign LValue Expr | Call Expr [Expr] + | TrackedNormalCall A.Position ModuleName.Canonical Expr Expr [Expr] | Function (Maybe Name) [Name] [Stmt] data LValue @@ -511,6 +512,18 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & 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 -> builder & addAscii "function " @@ -523,6 +536,12 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & addByteString indent & addAscii "}" +trackedNameFromExpr :: Expr -> Maybe Name +trackedNameFromExpr expr = + case expr of + TrackedRef _ _ name _ -> Just name + _ -> Nothing + -- FIELDS fromField :: Level -> (Name, Expr) -> Builder -> Builder diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 64c454164..afc9f7fab 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -84,8 +84,8 @@ generate mode parentModule expression = JsExpr $ JS.Array $ map (generateJsExpr mode parentModule) entries Opt.Function args body -> generateFunction (map JsName.fromLocal args) (generate mode parentModule body) - Opt.Call func args -> - JsExpr $ generateCall mode parentModule func args + Opt.Call (A.Region startPos _) func args -> + JsExpr $ generateCall mode startPos parentModule func args Opt.TailCall name args -> JsBlock $ generateTailCall mode parentModule name args Opt.If branches final -> @@ -259,40 +259,42 @@ funcHelpers = -- CALLS -generateCall :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCall mode parentModule func args = +generateCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCall mode pos parentModule func args = case func of - Opt.VarGlobal _region global@(Opt.Global (ModuleName.Canonical pkg _) _) + Opt.VarGlobal _ global@(Opt.Global (ModuleName.Canonical pkg _) _) | pkg == Pkg.core -> - generateCoreCall mode parentModule global args + generateCoreCall mode pos parentModule global args Opt.VarBox _ _ -> case mode of Mode.Dev _ -> - generateCallHelp mode parentModule func args + generateCallHelp mode pos parentModule func args Mode.Prod _ -> case args of [arg] -> generateJsExpr mode parentModule arg _ -> - generateCallHelp mode parentModule func args + generateCallHelp mode pos parentModule func args _ -> - generateCallHelp mode parentModule func args + generateCallHelp mode pos parentModule func args -generateCallHelp :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCallHelp mode parentModule func args = +generateCallHelp :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCallHelp mode pos parentModule func args = generateNormalCall + pos + parentModule (generateJsExpr mode parentModule func) (map (generateJsExpr mode parentModule) args) -generateGlobalCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateGlobalCall home name args = - generateNormalCall (JS.Ref (JsName.fromGlobal home name)) args +generateGlobalCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateGlobalCall pos parentModule home name args = + generateNormalCall pos parentModule (JS.Ref (JsName.fromGlobal home name)) args -generateNormalCall :: JS.Expr -> [JS.Expr] -> JS.Expr -generateNormalCall func args = +generateNormalCall :: A.Position -> ModuleName.Canonical -> JS.Expr -> [JS.Expr] -> JS.Expr +generateNormalCall pos parentModule func args = case IntMap.lookup (length args) callHelpers of Just helper -> - JS.Call helper (func : args) + JS.TrackedNormalCall pos parentModule helper func args Nothing -> List.foldl' (\f a -> JS.Call f [a]) func args @@ -303,25 +305,25 @@ callHelpers = -- CORE CALLS -generateCoreCall :: Mode.Mode -> ModuleName.Canonical -> Opt.Global -> [Opt.Expr] -> JS.Expr -generateCoreCall mode parentModule (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = +generateCoreCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Global -> [Opt.Expr] -> JS.Expr +generateCoreCall mode pos parentModule (Opt.Global home@(ModuleName.Canonical _ moduleName) name) args = if moduleName == Name.basics - then generateBasicsCall mode parentModule home name args + then generateBasicsCall mode pos parentModule home name args else if moduleName == Name.bitwise - then generateBitwiseCall home name (map (generateJsExpr mode parentModule) args) + then generateBitwiseCall pos parentModule home name (map (generateJsExpr mode parentModule) args) else if moduleName == Name.math - then generateMathCall home name (map (generateJsExpr mode parentModule) args) - else generateGlobalCall home name (map (generateJsExpr mode parentModule) args) + then generateMathCall pos parentModule home name (map (generateJsExpr mode parentModule) args) + else generateGlobalCall pos parentModule home name (map (generateJsExpr mode parentModule) args) -generateBitwiseCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateBitwiseCall home name args = +generateBitwiseCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateBitwiseCall pos parentModule home name args = case args of [arg] -> case name of "complement" -> JS.Prefix JS.PrefixComplement arg - _ -> generateGlobalCall home name args + _ -> generateGlobalCall pos parentModule home name args [left, right] -> case name of "and" -> JS.Infix JS.OpBitwiseAnd left right @@ -330,12 +332,12 @@ 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 pos parentModule home name args _ -> - generateGlobalCall home name args + generateGlobalCall pos parentModule home name args -generateBasicsCall :: Mode.Mode -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr -generateBasicsCall mode parentModule home name args = +generateBasicsCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr +generateBasicsCall mode pos parentModule home name args = case args of [grenArg] -> let arg = generateJsExpr mode parentModule grenArg @@ -343,7 +345,7 @@ generateBasicsCall mode parentModule home name args = "not" -> JS.Prefix JS.PrefixNot arg "negate" -> JS.Prefix JS.PrefixNegate arg "toFloat" -> arg - _ -> generateGlobalCall home name [arg] + _ -> generateGlobalCall pos parentModule home name [arg] [grenLeft, grenRight] -> case name of -- NOTE: removed "composeL" and "composeR" because of this issue: @@ -369,23 +371,23 @@ generateBasicsCall mode parentModule 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 pos parentModule home name [left, right] _ -> - generateGlobalCall home name (map (generateJsExpr mode parentModule) args) + generateGlobalCall pos parentModule home name (map (generateJsExpr mode parentModule) args) -generateMathCall :: ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateMathCall home name args = +generateMathCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr +generateMathCall pos parentModule home name args = case args of [arg] -> case name of "truncate" -> JS.Infix JS.OpBitwiseOr arg (JS.Int 0) - _ -> generateGlobalCall home name [arg] + _ -> generateGlobalCall pos parentModule home name [arg] [left, right] -> case name of "remainderBy" -> JS.Infix JS.OpMod right left - _ -> generateGlobalCall home name [left, right] + _ -> generateGlobalCall pos parentModule home name [left, right] _ -> - generateGlobalCall home name args + generateGlobalCall pos parentModule home name args equal :: JS.Expr -> JS.Expr -> JS.Expr equal left right = @@ -430,10 +432,10 @@ apply func value = case func of Opt.Accessor field -> Opt.Access value field - Opt.Call f args -> - Opt.Call f (args ++ [value]) + Opt.Call region f args -> + Opt.Call region f (args ++ [value]) _ -> - Opt.Call func [value] + Opt.Call A.zero func [value] append :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> Opt.Expr -> JS.Expr append mode parentModule left right = @@ -449,7 +451,7 @@ jsAppend a b = toSeqs :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> [JS.Expr] toSeqs mode parentModule expr = case expr of - Opt.Call (Opt.VarGlobal _region (Opt.Global home "append")) [left, right] + Opt.Call _ (Opt.VarGlobal _ (Opt.Global home "append")) [left, right] | home == ModuleName.basics -> generateJsExpr mode parentModule left : toSeqs mode parentModule right _ -> diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 1d67ba64e..667491c69 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -44,7 +44,7 @@ hasDebug expression = 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 diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index 1d6073b57..d15f7bb92 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -58,20 +58,20 @@ optimize cycle (A.At region expression) = do 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 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 -> @@ -285,7 +285,7 @@ optimizePotentialTailCall cycle name args expr = <$> 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 rootName argNames locExpr@(A.At region expression) = case expression of Can.Call func args -> do @@ -304,10 +304,10 @@ optimizeTail cycle rootName argNames locExpr@(A.At _ expression) = 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) = (,) diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index 3671d6f93..c5abdb4c3 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -50,7 +50,7 @@ toEncoder tipe = let encodeField (name, Can.FieldType _ fieldType) = do encoder <- toEncoder fieldType - let value = Opt.Call encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) name] + let value = Opt.Call A.zero encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) name] return $ Opt.Record $ Map.fromList @@ -61,7 +61,7 @@ toEncoder tipe = object <- encode "object" keyValuePairs <- traverse encodeField (Map.toList fields) Names.registerFieldDict fields $ - Opt.Function [Name.dollar] (Opt.Call object [Opt.Array keyValuePairs]) + Opt.Function [Name.dollar] (Opt.Call A.zero object [Opt.Array keyValuePairs]) -- ENCODE HELPERS @@ -73,14 +73,14 @@ encodeMaybe tipe = destruct <- Names.registerGlobal A.zero ModuleName.maybe "destruct" return $ Opt.Function [Name.dollar] $ - Opt.Call destruct [null, encoder, Opt.VarLocal 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 @@ -125,7 +125,7 @@ decodeUnit = do succeed <- decode "succeed" unit <- Names.registerGlobal A.zero ModuleName.basics Name.unit - return (Opt.Call succeed [unit]) + return (Opt.Call A.zero succeed [unit]) -- DECODE MAYBE @@ -142,11 +142,11 @@ decodeMaybe tipe = subDecoder <- toDecoder tipe return $ - Opt.Call + (Opt.Call A.zero) oneOf [ Opt.Array - [ Opt.Call null [nothing], - Opt.Call map_ [just, subDecoder] + [ Opt.Call A.zero null [nothing], + Opt.Call A.zero map_ [just, subDecoder] ] ] @@ -157,7 +157,7 @@ decodeArray tipe = do array <- decode "array" decoder <- toDecoder tipe - return $ Opt.Call array [decoder] + return $ Opt.Call A.zero array [decoder] -- DECODE RECORDS @@ -170,7 +170,7 @@ decodeRecord fields = Opt.Record (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 @@ -180,10 +180,10 @@ 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 A.zero (Name.toGrenString key), typeDecoder] + Opt.Call A.zero field [Opt.Str A.zero (Name.toGrenString key), typeDecoder] ] -- GLOBALS HELPERS From 9cf0e214b5d52aa87b75a682f4a9909f5c0d1776 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 22 May 2023 22:35:02 +0200 Subject: [PATCH 23/47] Add more references to source maps, and format names to include source module, when available. --- compiler/src/Generate/JavaScript/Expression.hs | 6 +++--- compiler/src/Generate/JavaScript/Name.hs | 13 +++++++++++++ 2 files changed, 16 insertions(+), 3 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index afc9f7fab..25a565045 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -58,10 +58,10 @@ generate mode parentModule expression = JsExpr $ JS.Int int Opt.Float _region float -> JsExpr $ JS.Float (Utf8.toBuilder float) - Opt.VarLocal _region name -> - JsExpr $ JS.Ref (JsName.fromLocal name) + Opt.VarLocal (A.Region startPos _) name -> + JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> - JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromLocal name) (JsName.fromGlobal home name) + JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) Opt.VarEnum _region (Opt.Global home name) index -> case mode of Mode.Dev _ -> diff --git a/compiler/src/Generate/JavaScript/Name.hs b/compiler/src/Generate/JavaScript/Name.hs index 47d43a980..bb4c0f600 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 _ mod) name = + Name $ + Utf8.toBuilder mod + <> "." + <> Name.toBuilder name + fromCycle :: ModuleName.Canonical -> Name.Name -> Name fromCycle home name = Name $ homeToBuilder home <> "$cyclic$" <> Name.toBuilder name From 75ddba194d93270c5fa729653e835f71a01d3b2b Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 22 May 2023 22:36:28 +0200 Subject: [PATCH 24/47] Fix compiler warning. --- compiler/src/Generate/JavaScript/Name.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Name.hs b/compiler/src/Generate/JavaScript/Name.hs index bb4c0f600..952181052 100644 --- a/compiler/src/Generate/JavaScript/Name.hs +++ b/compiler/src/Generate/JavaScript/Name.hs @@ -59,9 +59,9 @@ fromGlobal home name = Name $ homeToBuilder home <> usd <> Name.toBuilder name fromGlobalHumanReadable :: ModuleName.Canonical -> Name.Name -> Name -fromGlobalHumanReadable (ModuleName.Canonical _ mod) name = +fromGlobalHumanReadable (ModuleName.Canonical _ moduleName) name = Name $ - Utf8.toBuilder mod + Utf8.toBuilder moduleName <> "." <> Name.toBuilder name From f6853ededaf137841f68cd3803b8902a85439d42 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 23 May 2023 18:42:18 +0200 Subject: [PATCH 25/47] Insert project sources into source map. --- compiler/src/Generate/SourceMap.hs | 55 +++++++++++++++--------------- terminal/src/Make.hs | 21 ++++++++---- 2 files changed, 42 insertions(+), 34 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 4f92ba8b7..13219fd21 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -9,7 +9,6 @@ import Data.Function ((&)) import Data.List as List import Data.Map.Strict qualified as Map import Data.Maybe qualified as Maybe -import Data.Name qualified as Name import Generate.JavaScript.Builder qualified as JS import Generate.JavaScript.Name qualified as JsName import Gren.ModuleName qualified as ModuleName @@ -21,19 +20,19 @@ newtype SourceMap = SourceMap [JS.Mapping] wrap :: [JS.Mapping] -> SourceMap wrap = SourceMap -generateOnto :: Int -> SourceMap -> B.Builder -> B.Builder -generateOnto leadingLines (SourceMap mappings) sourceBytes = +generateOnto :: Int -> Map.Map ModuleName.Raw String -> SourceMap -> B.Builder -> B.Builder +generateOnto leadingLines moduleSources (SourceMap mappings) sourceBytes = sourceBytes <> "\n" <> "//# sourceMappingURL=data:application/json;base64," - <> generate leadingLines mappings + <> generate leadingLines moduleSources mappings -generate :: Int -> [JS.Mapping] -> B.Builder -generate leadingLines mappings = +generate :: Int -> Map.Map ModuleName.Raw 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 + & mappingsToJson moduleSources & Json.encode & B.toLazyByteString & BLazy.toStrict @@ -41,26 +40,27 @@ generate leadingLines mappings = & B.byteString data Mappings = Mappings - { _m_sources :: OrderedListBuilder Name.Name, + { _m_sources :: OrderedListBuilder ModuleName.Canonical, _m_names :: OrderedListBuilder JsName.Name, _m_vlqs :: [Json.Value] } parseMappings :: [JS.Mapping] -> Mappings parseMappings mappings = - parseMappingsHelp (List.sortBy (\a b -> JS._m_gen_line b `compare` JS._m_gen_line a) mappings) $ - Mappings - { _m_sources = emptyOrderedListBuilder, - _m_names = emptyOrderedListBuilder, - _m_vlqs = [] - } + let sortedMappings = List.sortBy (\a b -> JS._m_gen_line b `compare` JS._m_gen_line a) mappings + in parseMappingsHelp sortedMappings $ + Mappings + { _m_sources = emptyOrderedListBuilder, + _m_names = emptyOrderedListBuilder, + _m_vlqs = [] + } parseMappingsHelp :: [JS.Mapping] -> Mappings -> Mappings parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = case mappings of [] -> acc first : rest -> - let newSources = insertIntoOrderedListBuilder (ModuleName._module $ JS._m_src_module first) srcs + let newSources = insertIntoOrderedListBuilder (JS._m_src_module first) srcs newNames = insertIntoOrderedListBuilder (JS._m_src_name first) nms in parseMappingsHelp rest $ Mappings newSources newNames $ @@ -68,7 +68,7 @@ parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), - (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (ModuleName._module $ JS._m_src_module first) newSources), + (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module first) newSources), (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name first) newNames), (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), @@ -105,20 +105,21 @@ lookupIndexOrderedListBuilder :: Ord a => a -> OrderedListBuilder a -> Maybe Int lookupIndexOrderedListBuilder value (OrderedListBuilder _ values) = Map.lookup value values -arrayBuilderToList :: OrderedListBuilder a -> [a] -arrayBuilderToList (OrderedListBuilder _ values) = +orderedListBuilderToList :: OrderedListBuilder a -> [a] +orderedListBuilderToList (OrderedListBuilder _ values) = values & Map.toList & map (\(val, idx) -> (idx, val)) & Map.fromList & Map.elems -mappingsToJson :: Mappings -> Json.Value -mappingsToJson (Mappings sources names vlqs) = - Json.object - [ (JStr.fromChars "version", Json.int 3), - (JStr.fromChars "sources", Json.array $ map ModuleName.encode $ arrayBuilderToList sources), - (JStr.fromChars "sourcesContent", Json.array []), - (JStr.fromChars "names", Json.array $ map (Json.String . JsName.toBuilder) $ arrayBuilderToList names), - (JStr.fromChars "mappings", Json.array vlqs) - ] +mappingsToJson :: Map.Map ModuleName.Raw String -> Mappings -> Json.Value +mappingsToJson moduleSources (Mappings sources names 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._module moduleName) moduleSources) moduleNames), + (JStr.fromChars "names", Json.array $ map (Json.String . JsName.toBuilder) $ orderedListBuilderToList names), + (JStr.fromChars "mappings", Json.array vlqs) + ] diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index 8aad72f51..07a702e6f 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -14,6 +14,7 @@ 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 @@ -76,6 +77,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = do desiredMode <- getMode debug optimize details <- Task.eio Exit.MakeBadDetails (Details.load style scope root) + moduleSources <- rereadSources details let platform = getPlatform details let projectType = getProjectType details case (projectType, maybeOutput) of @@ -103,15 +105,15 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = (Platform.Browser, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.html" (Html.sandwich name (SourceMap.generateOnto Html.leadingLines sourceMap source)) (NE.List name []) + writeToDisk style "index.html" (Html.sandwich name (SourceMap.generateOnto Html.leadingLines moduleSources sourceMap source)) (NE.List name []) (Platform.Node, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "app" (SourceMap.generateOnto Node.leadingLines sourceMap (Node.sandwich name source)) (NE.List name []) + writeToDisk style "app" (SourceMap.generateOnto Node.leadingLines moduleSources sourceMap (Node.sandwich name source)) (NE.List name []) (_, name : names) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.js" (SourceMap.generateOnto 0 sourceMap source) (NE.List name names) + writeToDisk style "index.js" (SourceMap.generateOnto 0 moduleSources sourceMap source) (NE.List name names) Just DevStdOut -> case getMains artifacts of [] -> @@ -119,7 +121,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = _ -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - Task.io $ B.hPutBuilder IO.stdout (SourceMap.generateOnto 0 sourceMap source) + Task.io $ B.hPutBuilder IO.stdout (SourceMap.generateOnto 0 moduleSources sourceMap source) Just DevNull -> return () Just (Exe target) -> @@ -127,14 +129,14 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Node -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.generateOnto Node.leadingLines sourceMap (Node.sandwich name source)) (NE.List name []) + writeToDisk style target (SourceMap.generateOnto Node.leadingLines moduleSources sourceMap (Node.sandwich name source)) (NE.List name []) _ -> do Task.throw Exit.MakeExeOnlyForNodePlatform Just (JS target) -> case getNoMains artifacts of [] -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.generateOnto 0 sourceMap source) (Build.getRootNames artifacts) + writeToDisk style target (SourceMap.generateOnto 0 moduleSources sourceMap source) (Build.getRootNames artifacts) name : names -> Task.throw (Exit.MakeNonMainFilesIntoJavaScript name names) Just (Html target) -> @@ -142,7 +144,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Browser -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (Html.sandwich name (SourceMap.generateOnto Html.leadingLines sourceMap source)) (NE.List name []) + writeToDisk style target (Html.sandwich name (SourceMap.generateOnto Html.leadingLines moduleSources sourceMap source)) (NE.List name []) _ -> do Task.throw Exit.MakeHtmlOnlyForBrowserPlatform @@ -163,6 +165,11 @@ getMode debug optimize = (False, False) -> return Dev (False, True) -> return Prod +rereadSources :: Details.Details -> Task (Map ModuleName.Raw String) +rereadSources details = + let locals = Details._locals details + in Task.io $ traverse (readFile . Details._path) locals + getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) getExposed (Details.Details _ validOutline _ _ _ _) = case validOutline of From 56dc275d6f0bc8fbacbf629d30efd43eed89c2a9 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 24 May 2023 15:31:04 +0200 Subject: [PATCH 26/47] Setup test suite for encoding VLQs --- compiler/src/Generate/VLQ.hs | 7 +++++++ gren.cabal | 2 ++ tests/Generate/VLQSpec.hs | 19 +++++++++++++++++++ 3 files changed, 28 insertions(+) create mode 100644 compiler/src/Generate/VLQ.hs create mode 100644 tests/Generate/VLQSpec.hs diff --git a/compiler/src/Generate/VLQ.hs b/compiler/src/Generate/VLQ.hs new file mode 100644 index 000000000..ba880137b --- /dev/null +++ b/compiler/src/Generate/VLQ.hs @@ -0,0 +1,7 @@ +module Generate.VLQ + ( encode + ) where + +encode :: Int -> String +encode _num = + "" \ No newline at end of file diff --git a/gren.cabal b/gren.cabal index 04187d81f..1ac18f7fc 100644 --- a/gren.cabal +++ b/gren.cabal @@ -153,6 +153,7 @@ Common gren-common Generate.JavaScript.Name Generate.Mode Generate.SourceMap + Generate.VLQ Nitpick.Debug Nitpick.PatternMatches Optimize.Case @@ -255,6 +256,7 @@ Test-Suite gren-tests Helpers.Parse -- tests + Generate.VLQSpec Integration.FormatSpec Parse.AliasSpec Parse.RecordUpdateSpec diff --git a/tests/Generate/VLQSpec.hs b/tests/Generate/VLQSpec.hs new file mode 100644 index 000000000..745193005 --- /dev/null +++ b/tests/Generate/VLQSpec.hs @@ -0,0 +1,19 @@ +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" \ No newline at end of file From 5f9c114b4b3816f875715a8b553cf4392814a0ee Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 24 May 2023 23:08:52 +0200 Subject: [PATCH 27/47] First attempt at implementing VLQ encoding, fails for large negative numbers when Int > 32 bits. --- compiler/src/Generate/VLQ.hs | 53 ++++++++++++++++++++++++++++++++++-- gren.cabal | 3 +- tests/Generate/VLQSpec.hs | 2 +- 3 files changed, 54 insertions(+), 4 deletions(-) diff --git a/compiler/src/Generate/VLQ.hs b/compiler/src/Generate/VLQ.hs index ba880137b..7b2209263 100644 --- a/compiler/src/Generate/VLQ.hs +++ b/compiler/src/Generate/VLQ.hs @@ -2,6 +2,55 @@ module Generate.VLQ ( encode ) where +import Data.Bits ((.|.), (.&.)) +import Data.Bits qualified as Bit +import Data.List qualified as List +import Data.Map (Map, (!)) +import Data.Map qualified as Map +import Data.Function ((&)) +import Data.Foldable.WithIndex (ifoldr) + + +{- Ported from the Elm package Janiczek/elm-vlq +-} + encode :: Int -> String -encode _num = - "" \ No newline at end of file +encode num = + let + numWithSign = + if num < 0 + then (negate num `Bit.shiftL` 1) .|. 1 + else num `Bit.shiftL` 1 + in + encodeHelp numWithSign "" + +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/gren.cabal b/gren.cabal index 1ac18f7fc..54149d70a 100644 --- a/gren.cabal +++ b/gren.cabal @@ -225,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: diff --git a/tests/Generate/VLQSpec.hs b/tests/Generate/VLQSpec.hs index 745193005..c6dbe7bec 100644 --- a/tests/Generate/VLQSpec.hs +++ b/tests/Generate/VLQSpec.hs @@ -16,4 +16,4 @@ spec = do encode 123456789 `shouldBe` "qxmvrH" -- limits: encode (-2147483648) `shouldBe` "B" - encode 2147483647 `shouldBe` "+/////D" \ No newline at end of file + encode 2147483647 `shouldBe` "+/////D" From 24c5f86381a9c0a32f8aa989918027a653bbe3c6 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 24 May 2023 23:09:28 +0200 Subject: [PATCH 28/47] Cosmetic changes. --- compiler/src/Generate/VLQ.hs | 59 +++++++++++++++--------------------- tests/Generate/VLQSpec.hs | 1 - 2 files changed, 25 insertions(+), 35 deletions(-) diff --git a/compiler/src/Generate/VLQ.hs b/compiler/src/Generate/VLQ.hs index 7b2209263..fb75ba90c 100644 --- a/compiler/src/Generate/VLQ.hs +++ b/compiler/src/Generate/VLQ.hs @@ -1,56 +1,47 @@ -module Generate.VLQ - ( encode - ) where +module Generate.VLQ + ( encode, + ) +where -import Data.Bits ((.|.), (.&.)) +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 -import Data.Function ((&)) -import Data.Foldable.WithIndex (ifoldr) - {- Ported from the Elm package Janiczek/elm-vlq -} encode :: Int -> String -encode num = - let - numWithSign = - if num < 0 - then (negate num `Bit.shiftL` 1) .|. 1 - else num `Bit.shiftL` 1 - in - encodeHelp numWithSign "" +encode num = + let numWithSign = + if num < 0 + then (negate num `Bit.shiftL` 1) .|. 1 + else num `Bit.shiftL` 1 + in encodeHelp numWithSign "" encodeHelp :: Int -> String -> String encodeHelp num acc = - let - clamped = - num .&. 31 + let clamped = + num .&. 31 newNum = - num `Bit.shiftR` 5 + num `Bit.shiftR` 5 newClamped = - if newNum > 0 then - clamped .|. 32 - - else - clamped + 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 ! 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 + "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/='" + & ifoldr Map.insert Map.empty diff --git a/tests/Generate/VLQSpec.hs b/tests/Generate/VLQSpec.hs index c6dbe7bec..b9233c00b 100644 --- a/tests/Generate/VLQSpec.hs +++ b/tests/Generate/VLQSpec.hs @@ -3,7 +3,6 @@ module Generate.VLQSpec (spec) where import Generate.VLQ (encode) import Test.Hspec (Spec, describe, it, shouldBe) - spec :: Spec spec = do describe "VLQ tests" $ do From 1ac6746a6f111fd73993896e11058f336441b08c Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 24 May 2023 23:18:05 +0200 Subject: [PATCH 29/47] Fix issue with large negative numbers. --- compiler/src/Generate/VLQ.hs | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/compiler/src/Generate/VLQ.hs b/compiler/src/Generate/VLQ.hs index fb75ba90c..7fc7369b9 100644 --- a/compiler/src/Generate/VLQ.hs +++ b/compiler/src/Generate/VLQ.hs @@ -14,14 +14,19 @@ 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 `Bit.shiftL` 1) .|. 1 - else num `Bit.shiftL` 1 + 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 = From 9c80b25e5ce75e0b26fcc440935b04e093aa9363 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 26 May 2023 09:13:01 +0200 Subject: [PATCH 30/47] Output mappings in correct order. --- compiler/src/Generate/SourceMap.hs | 64 ++++++++++++++++++++---------- 1 file changed, 42 insertions(+), 22 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 13219fd21..e8791e66f 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -7,8 +7,11 @@ 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 Gren.ModuleName qualified as ModuleName @@ -47,34 +50,51 @@ data Mappings = Mappings parseMappings :: [JS.Mapping] -> Mappings parseMappings mappings = - let sortedMappings = List.sortBy (\a b -> JS._m_gen_line b `compare` JS._m_gen_line a) mappings - in parseMappingsHelp sortedMappings $ + 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_vlqs = [] } -parseMappingsHelp :: [JS.Mapping] -> Mappings -> Mappings -parseMappingsHelp mappings acc@(Mappings srcs nms vlqs) = - case mappings of - [] -> acc - first : rest -> - let newSources = insertIntoOrderedListBuilder (JS._m_src_module first) srcs - newNames = insertIntoOrderedListBuilder (JS._m_src_name first) nms - in parseMappingsHelp rest $ - Mappings newSources newNames $ - Json.object - [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line first), - (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col first), - (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module first), - (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module first) newSources), - (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name first), - (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name first) newNames), - (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line first), - (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col first) - ] - : 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@(Mappings srcs nms vlqs) = + if currentLine >= lastLine + then Mappings srcs nms (reverse vlqs) + else case Map.lookup currentLine mappingMap of + Nothing -> + parseMappingsHelp (currentLine + 1) lastLine mappingMap $ + Mappings srcs nms (Json.null : vlqs) + Just segments -> + let sortedSegments = List.sortOn (Data.Ord.Down . JS._m_gen_col) segments + in parseMappingsHelp (currentLine + 1) lastLine mappingMap $ + foldr encodeSegment acc sortedSegments + +encodeSegment :: JS.Mapping -> Mappings -> Mappings +encodeSegment segment (Mappings srcs nms vlqs) = + let newSources = insertIntoOrderedListBuilder (JS._m_src_module segment) srcs + newNames = insertIntoOrderedListBuilder (JS._m_src_name segment) nms + in Mappings newSources newNames $ + Json.object + [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line segment), + (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col segment), + (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module segment), + (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module segment) newSources), + (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name segment), + (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames), + (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line segment), + (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col segment) + ] + : vlqs -- Array builder From 83b493646d62568efc9a36078b47bd479475060e Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 26 May 2023 15:19:03 +0200 Subject: [PATCH 31/47] Write mapping numbers as deltas from previous segment. --- compiler/src/Generate/SourceMap.hs | 68 ++++++++++++++++++++++++------ 1 file changed, 56 insertions(+), 12 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index e8791e66f..14ec76df3 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -45,9 +45,18 @@ generate leadingLines moduleSources mappings = data Mappings = Mappings { _m_sources :: OrderedListBuilder ModuleName.Canonical, _m_names :: OrderedListBuilder JsName.Name, + _m_segment_accounting :: SegmentAccounting, _m_vlqs :: [Json.Value] } +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 @@ -55,6 +64,14 @@ parseMappings mappings = 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 = [] } @@ -67,32 +84,59 @@ mappingMapUpdater toInsert maybeVal = Just $ toInsert : existing parseMappingsHelp :: Word16 -> Word16 -> Map Word16 [JS.Mapping] -> Mappings -> Mappings -parseMappingsHelp currentLine lastLine mappingMap acc@(Mappings srcs nms vlqs) = +parseMappingsHelp currentLine lastLine mappingMap acc@(Mappings srcs nms sa vlqs) = if currentLine >= lastLine - then Mappings srcs nms (reverse vlqs) + then Mappings srcs nms sa (reverse vlqs) else case Map.lookup currentLine mappingMap of Nothing -> parseMappingsHelp (currentLine + 1) lastLine mappingMap $ - Mappings srcs nms (Json.null : vlqs) + Mappings srcs nms sa (Json.null : vlqs) Just segments -> let sortedSegments = List.sortOn (Data.Ord.Down . JS._m_gen_col) segments in parseMappingsHelp (currentLine + 1) lastLine mappingMap $ - foldr encodeSegment acc sortedSegments + 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 vlqs) = +encodeSegment segment (Mappings srcs nms sa vlqs) = let newSources = insertIntoOrderedListBuilder (JS._m_src_module segment) srcs newNames = insertIntoOrderedListBuilder (JS._m_src_name segment) nms - in Mappings newSources newNames $ + genCol = JS._m_gen_col segment + moduleIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module segment) newSources + sourceLine = fromIntegral $ JS._m_src_line segment + sourceCol = fromIntegral $ JS._m_src_col segment + nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames + genColDelta = genCol - 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)) + nameIdxDelta = nameIdx - Maybe.fromMaybe 0 (_sa_prev_name_idx 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 = Just nameIdx + } + in Mappings newSources newNames updatedSa $ Json.object - [ (JStr.fromChars "src_line", Json.int $ fromIntegral $ JS._m_src_line segment), - (JStr.fromChars "src_col", Json.int $ fromIntegral $ JS._m_src_col segment), + [ (JStr.fromChars "src_line", Json.int sourceLineDelta), + (JStr.fromChars "src_col", Json.int sourceColDelta), (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module segment), - (JStr.fromChars "src_module_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_module segment) newSources), + (JStr.fromChars "src_module_idx", Json.int moduleIdxDelta), (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name segment), - (JStr.fromChars "src_name_idx", Json.int $ Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames), + (JStr.fromChars "src_name_idx", Json.int nameIdxDelta), (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line segment), - (JStr.fromChars "gen_col", Json.int $ fromIntegral $ JS._m_gen_col segment) + (JStr.fromChars "gen_col", Json.int $ fromIntegral genColDelta) ] : vlqs @@ -134,7 +178,7 @@ orderedListBuilderToList (OrderedListBuilder _ values) = & Map.elems mappingsToJson :: Map.Map ModuleName.Raw String -> Mappings -> Json.Value -mappingsToJson moduleSources (Mappings sources names vlqs) = +mappingsToJson moduleSources (Mappings sources names _sa vlqs) = let moduleNames = orderedListBuilderToList sources in Json.object [ (JStr.fromChars "version", Json.int 3), From 598bc9002dfaf72ad43ee96c8e6b2877c2bff713 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 26 May 2023 22:06:39 +0200 Subject: [PATCH 32/47] Encode mappings section according to spec. --- compiler/src/Generate/SourceMap.hs | 41 +++++++++++++++--------------- 1 file changed, 21 insertions(+), 20 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 14ec76df3..b377d5489 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -14,6 +14,7 @@ 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 @@ -46,7 +47,7 @@ data Mappings = Mappings { _m_sources :: OrderedListBuilder ModuleName.Canonical, _m_names :: OrderedListBuilder JsName.Name, _m_segment_accounting :: SegmentAccounting, - _m_vlqs :: [Json.Value] + _m_vlqs :: B.Builder } data SegmentAccounting = SegmentAccounting @@ -72,7 +73,7 @@ parseMappings mappings = _sa_prev_source_col = Nothing, _sa_prev_name_idx = Nothing }, - _m_vlqs = [] + _m_vlqs = "" } mappingMapUpdater :: JS.Mapping -> Maybe [JS.Mapping] -> Maybe [JS.Mapping] @@ -84,13 +85,13 @@ mappingMapUpdater toInsert maybeVal = Just $ toInsert : existing parseMappingsHelp :: Word16 -> Word16 -> Map Word16 [JS.Mapping] -> Mappings -> Mappings -parseMappingsHelp currentLine lastLine mappingMap acc@(Mappings srcs nms sa vlqs) = +parseMappingsHelp currentLine lastLine mappingMap acc = if currentLine >= lastLine - then Mappings srcs nms sa (reverse vlqs) + then acc else case Map.lookup currentLine mappingMap of Nothing -> parseMappingsHelp (currentLine + 1) lastLine mappingMap $ - Mappings srcs nms sa (Json.null : vlqs) + prepareForNewLine acc Just segments -> let sortedSegments = List.sortOn (Data.Ord.Down . JS._m_gen_col) segments in parseMappingsHelp (currentLine + 1) lastLine mappingMap $ @@ -103,7 +104,7 @@ prepareForNewLine (Mappings srcs nms sa vlqs) = srcs nms (sa {_sa_prev_col = Nothing}) - vlqs + (vlqs <> ";") encodeSegment :: JS.Mapping -> Mappings -> Mappings encodeSegment segment (Mappings srcs nms sa vlqs) = @@ -114,7 +115,7 @@ encodeSegment segment (Mappings srcs nms sa vlqs) = sourceLine = fromIntegral $ JS._m_src_line segment sourceCol = fromIntegral $ JS._m_src_col segment nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames - genColDelta = genCol - Maybe.fromMaybe 0 (_sa_prev_col sa) + 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)) @@ -127,18 +128,18 @@ encodeSegment segment (Mappings srcs nms sa vlqs) = _sa_prev_source_col = Just sourceCol, _sa_prev_name_idx = Just nameIdx } + vlqPrefix = + if Maybe.isNothing (_sa_prev_col sa) + then "" + else "," in Mappings newSources newNames updatedSa $ - Json.object - [ (JStr.fromChars "src_line", Json.int sourceLineDelta), - (JStr.fromChars "src_col", Json.int sourceColDelta), - (JStr.fromChars "src_module", ModuleName.encode $ ModuleName._module $ JS._m_src_module segment), - (JStr.fromChars "src_module_idx", Json.int moduleIdxDelta), - (JStr.fromChars "src_name", Json.String $ JsName.toBuilder $ JS._m_src_name segment), - (JStr.fromChars "src_name_idx", Json.int nameIdxDelta), - (JStr.fromChars "gen_line", Json.int $ fromIntegral $ JS._m_gen_line segment), - (JStr.fromChars "gen_col", Json.int $ fromIntegral genColDelta) - ] - : vlqs + 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) -- Array builder @@ -184,6 +185,6 @@ mappingsToJson moduleSources (Mappings sources names _sa vlqs) = [ (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._module moduleName) moduleSources) moduleNames), - (JStr.fromChars "names", Json.array $ map (Json.String . JsName.toBuilder) $ orderedListBuilderToList names), - (JStr.fromChars "mappings", Json.array vlqs) + (JStr.fromChars "names", Json.array $ map (\jsName -> Json.String ("\"" <> JsName.toBuilder jsName <> "\"")) $ orderedListBuilderToList names), + (JStr.fromChars "mappings", Json.String ("\"" <> vlqs <> "\"")) ] From b4a663282fe39c456d28288eefe0bc11afcd3286 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 26 May 2023 22:20:45 +0200 Subject: [PATCH 33/47] All source positions are 0-based when in source maps. --- compiler/src/Generate/SourceMap.hs | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index b377d5489..6cee63c8d 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -110,10 +110,10 @@ encodeSegment :: JS.Mapping -> Mappings -> Mappings encodeSegment segment (Mappings srcs nms sa vlqs) = let newSources = insertIntoOrderedListBuilder (JS._m_src_module segment) srcs newNames = insertIntoOrderedListBuilder (JS._m_src_name segment) nms - genCol = JS._m_gen_col segment + 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 - sourceCol = fromIntegral $ JS._m_src_col segment + sourceLine = fromIntegral (JS._m_src_line segment) - 1 + sourceCol = fromIntegral (JS._m_src_col segment) - 1 nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames genColDelta = fromIntegral genCol - fromIntegral (Maybe.fromMaybe 0 (_sa_prev_col sa)) moduleIdxDelta = moduleIdx - Maybe.fromMaybe 0 (_sa_prev_source_idx sa) From 8dbf3302fcafcbc7ea61e83f49ce4a9033c49be4 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Fri, 26 May 2023 22:21:20 +0200 Subject: [PATCH 34/47] Remove trailing white space. --- compiler/src/Generate/SourceMap.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 6cee63c8d..5801c1de0 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -113,7 +113,7 @@ encodeSegment segment (Mappings srcs nms sa vlqs) = 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 + sourceCol = fromIntegral (JS._m_src_col segment) - 1 nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames genColDelta = fromIntegral genCol - fromIntegral (Maybe.fromMaybe 0 (_sa_prev_col sa)) moduleIdxDelta = moduleIdx - Maybe.fromMaybe 0 (_sa_prev_source_idx sa) From a10b7fe84ba3c5d318b389d50af7e43cee85c785 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Sun, 4 Jun 2023 12:48:50 +0200 Subject: [PATCH 35/47] Add all sources to sourcemap, not just the project's own sources. --- builder/src/Gren/Outline.hs | 60 ++++++++++++++++++++++++++++++ compiler/src/Generate/SourceMap.hs | 8 ++-- terminal/src/Make.hs | 19 +++++++--- 3 files changed, 78 insertions(+), 9 deletions(-) diff --git a/builder/src/Gren/Outline.hs b/builder/src/Gren/Outline.hs index 9d87ce4d4..7529b88fd 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,62 @@ sourceDirs outline = Pkg _ -> NE.singleton (RelativeSrcDir "src") +-- getAllModulePaths + +getAllModulePaths :: FilePath -> Outline -> IO (Map.Map ModuleName.Canonical FilePath) +getAllModulePaths root 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 Dir.doesDirectoryExist (filter (List.isSuffixOf "./") 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/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index 5801c1de0..e7dd003da 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -24,14 +24,14 @@ newtype SourceMap = SourceMap [JS.Mapping] wrap :: [JS.Mapping] -> SourceMap wrap = SourceMap -generateOnto :: Int -> Map.Map ModuleName.Raw String -> SourceMap -> B.Builder -> B.Builder +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.Raw String -> [JS.Mapping] -> B.Builder +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}) @@ -178,13 +178,13 @@ orderedListBuilderToList (OrderedListBuilder _ values) = & Map.fromList & Map.elems -mappingsToJson :: Map.Map ModuleName.Raw String -> Mappings -> Json.Value +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._module moduleName) moduleSources) 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/terminal/src/Make.hs b/terminal/src/Make.hs index 07a702e6f..b0fdaac25 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -7,6 +7,7 @@ module Make run, reportType, output, + rereadSources, ) where @@ -15,6 +16,7 @@ import BackgroundWriter qualified as BW import Build qualified import Data.ByteString.Builder qualified as B import Data.Map (Map) +import Data.Map qualified as Map import Data.Maybe qualified as Maybe import Data.NonEmptyList qualified as NE import Directories qualified as Dirs @@ -26,6 +28,7 @@ import Generate.Node qualified as Node 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 @@ -77,7 +80,7 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = do desiredMode <- getMode debug optimize details <- Task.eio Exit.MakeBadDetails (Details.load style scope root) - moduleSources <- rereadSources details + moduleSources <- Task.io $ rereadSources root let platform = getPlatform details let projectType = getProjectType details case (projectType, maybeOutput) of @@ -165,10 +168,16 @@ getMode debug optimize = (False, False) -> return Dev (False, True) -> return Prod -rereadSources :: Details.Details -> Task (Map ModuleName.Raw String) -rereadSources details = - let locals = Details._locals details - in Task.io $ traverse (readFile . Details._path) locals +rereadSources :: FilePath -> IO (Map ModuleName.Canonical String) +rereadSources root = + do + outlineResult <- Outline.read root + case outlineResult of + Left _ -> return Map.empty + Right outline -> + do + modulePaths <- Outline.getAllModulePaths root outline + traverse readFile modulePaths getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) getExposed (Details.Details _ validOutline _ _ _ _) = From 410e7c68c213cfb77296a0abe933566658f7bc7a Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 5 Jun 2023 22:24:07 +0200 Subject: [PATCH 36/47] Fix problem with nested modules. --- builder/src/Gren/Outline.hs | 28 +++++++++++++++++----------- terminal/src/Make.hs | 10 ++-------- 2 files changed, 19 insertions(+), 19 deletions(-) diff --git a/builder/src/Gren/Outline.hs b/builder/src/Gren/Outline.hs index 7529b88fd..369caf7ae 100644 --- a/builder/src/Gren/Outline.hs +++ b/builder/src/Gren/Outline.hs @@ -268,16 +268,22 @@ sourceDirs outline = -- getAllModulePaths -getAllModulePaths :: FilePath -> Outline -> IO (Map.Map ModuleName.Canonical FilePath) -getAllModulePaths root 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 +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 = @@ -298,7 +304,7 @@ recursiveFindGrenFilesHelp root = do dirContents <- Dir.getDirectoryContents root let (grenFiles, others) = List.partition (List.isSuffixOf ".gren") dirContents - subDirectories <- filterM Dir.doesDirectoryExist (filter (List.isSuffixOf "./") others) + 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 diff --git a/terminal/src/Make.hs b/terminal/src/Make.hs index b0fdaac25..c4e1b451b 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -16,7 +16,6 @@ import BackgroundWriter qualified as BW import Build qualified import Data.ByteString.Builder qualified as B import Data.Map (Map) -import Data.Map qualified as Map import Data.Maybe qualified as Maybe import Data.NonEmptyList qualified as NE import Directories qualified as Dirs @@ -171,13 +170,8 @@ getMode debug optimize = rereadSources :: FilePath -> IO (Map ModuleName.Canonical String) rereadSources root = do - outlineResult <- Outline.read root - case outlineResult of - Left _ -> return Map.empty - Right outline -> - do - modulePaths <- Outline.getAllModulePaths root outline - traverse readFile modulePaths + modulePaths <- Outline.getAllModulePaths root + traverse readFile modulePaths getExposed :: Details.Details -> Task (NE.List ModuleName.Raw) getExposed (Details.Details _ validOutline _ _ _ _) = From 8b5832b0964386e2a03390b96e57516ab4119cb2 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 5 Jun 2023 22:47:02 +0200 Subject: [PATCH 37/47] Implement the compiler flag to enable sourcemap generation. --- terminal/src/Main.hs | 1 + terminal/src/Make.hs | 36 ++++++++++++++++++++++++++---------- 2 files changed, 27 insertions(+), 10 deletions(-) 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 c4e1b451b..f16d929f0 100644 --- a/terminal/src/Make.hs +++ b/terminal/src/Make.hs @@ -24,6 +24,7 @@ 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 @@ -43,6 +44,7 @@ import Terminal (Parser (..)) data Flags = Flags { _debug :: Bool, _optimize :: Bool, + _sourceMaps :: Bool, _output :: Maybe Output, _report :: Maybe ReportType } @@ -62,7 +64,7 @@ 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 @@ -72,14 +74,13 @@ run paths flags@(Flags _ _ maybeOutput report) = 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 $ do desiredMode <- getMode debug optimize details <- Task.eio Exit.MakeBadDetails (Details.load style scope root) - moduleSources <- Task.io $ rereadSources root let platform = getPlatform details let projectType = getProjectType details case (projectType, maybeOutput) of @@ -107,15 +108,18 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = (Platform.Browser, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.html" (Html.sandwich name (SourceMap.generateOnto Html.leadingLines moduleSources sourceMap source)) (NE.List name []) + bundle <- prepareOutput withSourceMaps root Html.leadingLines sourceMap source + writeToDisk style "index.html" (Html.sandwich name bundle) (NE.List name []) (Platform.Node, [name]) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "app" (SourceMap.generateOnto Node.leadingLines moduleSources sourceMap (Node.sandwich name source)) (NE.List name []) + bundle <- prepareOutput withSourceMaps root Node.leadingLines sourceMap (Node.sandwich name source) + writeToDisk style "app" bundle (NE.List name []) (_, name : names) -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style "index.js" (SourceMap.generateOnto 0 moduleSources sourceMap source) (NE.List name names) + bundle <- prepareOutput withSourceMaps root 0 sourceMap source + writeToDisk style "index.js" bundle (NE.List name names) Just DevStdOut -> case getMains artifacts of [] -> @@ -123,7 +127,8 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = _ -> do (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - Task.io $ B.hPutBuilder IO.stdout (SourceMap.generateOnto 0 moduleSources sourceMap source) + bundle <- prepareOutput withSourceMaps root 0 sourceMap source + Task.io $ B.hPutBuilder IO.stdout bundle Just DevNull -> return () Just (Exe target) -> @@ -131,14 +136,16 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Node -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.generateOnto Node.leadingLines moduleSources sourceMap (Node.sandwich name source)) (NE.List name []) + 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 (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (SourceMap.generateOnto 0 moduleSources sourceMap source) (Build.getRootNames 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) -> @@ -146,7 +153,8 @@ runHelp root paths style (Flags debug optimize maybeOutput _) = Platform.Browser -> do name <- hasOneMain artifacts (JS.GeneratedResult source sourceMap) <- generate root details desiredMode artifacts - writeToDisk style target (Html.sandwich name (SourceMap.generateOnto Html.leadingLines moduleSources sourceMap source)) (NE.List name []) + bundle <- prepareOutput withSourceMaps root Html.leadingLines sourceMap source + writeToDisk style target (Html.sandwich name bundle) (NE.List name []) _ -> do Task.throw Exit.MakeHtmlOnlyForBrowserPlatform @@ -265,6 +273,14 @@ getNoMain modules root = -- WRITE TO DISK +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 $ From d47987a920c9e5fa83f121007d44aa8bbd372f41 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 7 Jun 2023 12:53:47 +0200 Subject: [PATCH 38/47] Add sourcemaps for record access patterns. --- compiler/src/AST/Optimized.hs | 6 ++-- compiler/src/Generate/JavaScript/Builder.hs | 29 ++++++++++++++-- .../src/Generate/JavaScript/Expression.hs | 6 ++-- compiler/src/Generate/SourceMap.hs | 34 ++++++++++++------- compiler/src/Nitpick/Debug.hs | 2 +- compiler/src/Optimize/Expression.hs | 4 +-- compiler/src/Optimize/Port.hs | 2 +- 7 files changed, 59 insertions(+), 24 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index dafb942ef..6b89e3bac 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -61,7 +61,7 @@ data Expr | Destruct Destructor Expr | Case Name Name (Decider Choice) [(Int, Expr)] | Accessor Name - | Access Expr Name + | Access Expr A.Region Name | Update Expr (Map.Map Name Expr) | Record (Map.Map Name Expr) @@ -227,7 +227,7 @@ instance Binary Expr where 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 + Access a b c -> putWord8 21 >> put a >> put b >> put c Update a b -> putWord8 22 >> put a >> put b Record a -> putWord8 23 >> put a @@ -256,7 +256,7 @@ instance Binary Expr where 18 -> liftM2 Destruct get get 19 -> liftM4 Case get get get get 20 -> liftM Accessor get - 21 -> liftM2 Access get get + 21 -> liftM3 Access get get get 22 -> liftM2 Update get get 23 -> liftM Record get _ -> fail "problem getting Opt.Expr binary" diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 56a901091..adb2ea33c 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -48,6 +48,7 @@ data Expr | Ref Name | TrackedRef A.Position ModuleName.Canonical Name Name | Access Expr Name -- foo.bar + | TrackedAccess Expr A.Position ModuleName.Canonical Name | Index Expr Expr -- foo[bar] | Prefix PrefixOp Expr | Infix InfixOp Expr Expr @@ -126,7 +127,7 @@ data Mapping = Mapping { _m_src_line :: Word16, _m_src_col :: Word16, _m_src_module :: ModuleName.Canonical, - _m_src_name :: Name, + _m_src_name :: Maybe Name, _m_gen_line :: Word16, _m_gen_col :: Word16 } @@ -185,7 +186,7 @@ addName (A.Position line col) moduleName name genName (Builder _code _currLine _ { _m_src_line = line, _m_src_col = col, _m_src_module = moduleName, - _m_src_name = name, + _m_src_name = Just name, _m_gen_line = _currLine, _m_gen_col = _currCol } @@ -193,6 +194,25 @@ addName (A.Position line col) moduleName name genName (Builder _code _currLine _ : _mappings } +addTrackedDot :: A.Position -> ModuleName.Canonical -> Builder -> Builder +addTrackedDot (A.Position line col) moduleName (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 @@ -479,6 +499,11 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = addName position moduleName name generatedName builder Access expr field -> makeDot level expr field builder + TrackedAccess expr position@(A.Position fieldLine fieldCol) moduleName field -> + builder + & fromExpr level Atomic expr + & addTrackedDot (A.Position fieldLine (fieldCol - 1)) moduleName + & addName position moduleName field field Index expr bracketedExpr -> makeBracketed level expr bracketedExpr builder Prefix op expr -> diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 25a565045..d337bd369 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -106,8 +106,8 @@ generate mode parentModule expression = [ JS.Return $ JS.Access (JS.Ref JsName.dollar) (generateField mode field) ] - Opt.Access record field -> - JsExpr $ JS.Access (generateJsExpr mode parentModule record) (generateField mode field) + Opt.Access record (A.Region startPos _) field -> + JsExpr $ JS.TrackedAccess (generateJsExpr mode parentModule record) startPos parentModule (generateField mode field) Opt.Update record fields -> JsExpr $ JS.Call @@ -431,7 +431,7 @@ apply :: Opt.Expr -> Opt.Expr -> Opt.Expr apply func value = case func of Opt.Accessor field -> - Opt.Access value field + Opt.Access value A.zero field Opt.Call region f args -> Opt.Call region f (args ++ [value]) _ -> diff --git a/compiler/src/Generate/SourceMap.hs b/compiler/src/Generate/SourceMap.hs index e7dd003da..90ec3e27d 100644 --- a/compiler/src/Generate/SourceMap.hs +++ b/compiler/src/Generate/SourceMap.hs @@ -109,37 +109,47 @@ prepareForNewLine (Mappings srcs nms sa vlqs) = encodeSegment :: JS.Mapping -> Mappings -> Mappings encodeSegment segment (Mappings srcs nms sa vlqs) = let newSources = insertIntoOrderedListBuilder (JS._m_src_module segment) srcs - newNames = insertIntoOrderedListBuilder (JS._m_src_name segment) nms 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 - nameIdx = Maybe.fromMaybe 0 $ lookupIndexOrderedListBuilder (JS._m_src_name segment) newNames 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)) - nameIdxDelta = nameIdx - Maybe.fromMaybe 0 (_sa_prev_name_idx 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 = Just nameIdx + _sa_prev_name_idx = _sa_prev_name_idx sa } vlqPrefix = if Maybe.isNothing (_sa_prev_col sa) then "" else "," - in Mappings newSources newNames updatedSa $ - 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) + 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 diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 667491c69..9cffdeaab 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -51,7 +51,7 @@ hasDebug expression = Opt.Destruct _ expr -> hasDebug expr Opt.Case _ _ d jumps -> deciderHasDebug d || any (hasDebug . snd) jumps Opt.Accessor _ -> False - Opt.Access r _ -> hasDebug r + Opt.Access r _ _ -> hasDebug r Opt.Update r fs -> hasDebug r || any hasDebug fs Opt.Record fs -> any hasDebug fs diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index d15f7bb92..d99fbc3d4 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -119,10 +119,10 @@ optimize cycle (A.At region expression) = return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) Can.Accessor field -> Names.registerField field (Opt.Accessor field) - Can.Access record (A.At _ 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 <*> optimize cycle record diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index c5abdb4c3..f1b4a3cdd 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -50,7 +50,7 @@ toEncoder tipe = let encodeField (name, Can.FieldType _ fieldType) = do encoder <- toEncoder fieldType - let value = Opt.Call A.zero encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) name] + let value = Opt.Call A.zero encoder [Opt.Access (Opt.VarLocal A.zero Name.dollar) A.zero name] return $ Opt.Record $ Map.fromList From 09cb1b7d0077d30251b118cbda2e72af5b1f0de7 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 7 Jun 2023 13:28:27 +0200 Subject: [PATCH 39/47] Add sourcemaps for literals. --- compiler/src/Generate/JavaScript/Builder.hs | 44 +++++++++++++++++++ .../src/Generate/JavaScript/Expression.hs | 22 +++++----- 2 files changed, 55 insertions(+), 11 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index adb2ea33c..20a71b99c 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -38,9 +38,13 @@ import Prelude hiding (lines) data Expr = 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] @@ -173,6 +177,38 @@ addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = _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 :: A.Position -> ModuleName.Canonical -> Name -> Name -> Builder -> Builder addName (A.Position line col) moduleName name genName (Builder _code _currLine _currCol _mappings) = let nameBuilder = Name.toBuilder genName @@ -473,12 +509,20 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = case expression of String string -> addByteString ("'" <> string <> "'") builder + TrackedString moduleName position string -> + addTrackedByteString moduleName position ("'" <> string <> "'") builder Float float -> addByteString float builder + TrackedFloat moduleName position float -> + addTrackedByteString moduleName position float builder Int n -> addByteString (B.intDec n) builder + TrackedInt moduleName position n -> + addTrackedByteString moduleName position (B.intDec n) builder Bool bool -> addAscii (if bool then "true" else "false") builder + TrackedBool moduleName position bool -> + addTrackedByteString moduleName position (if bool then "true" else "false") builder Null -> addAscii "null" builder Json json -> diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index d337bd369..6451d61d5 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -43,21 +43,21 @@ generateJsExpr mode parentModule expression = generate :: Mode.Mode -> ModuleName.Canonical -> Opt.Expr -> Code generate mode parentModule expression = case expression of - Opt.Bool _region bool -> - JsExpr $ JS.Bool bool - Opt.Chr _region 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 _region string -> - JsExpr $ JS.String (Utf8.toBuilder string) - Opt.Int _region int -> - JsExpr $ JS.Int int - Opt.Float _region float -> - JsExpr $ JS.Float (Utf8.toBuilder float) + 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 startPos parentModule (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> From d0a394f289013ed7cbba1925d7a3338b92a3e4f7 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 7 Jun 2023 13:52:49 +0200 Subject: [PATCH 40/47] Add sourcemaps for arrays. --- compiler/src/AST/Optimized.hs | 6 +++--- compiler/src/Generate/JavaScript/Builder.hs | 6 ++++++ compiler/src/Generate/JavaScript/Expression.hs | 8 ++++++-- compiler/src/Nitpick/Debug.hs | 2 +- compiler/src/Optimize/Expression.hs | 2 +- compiler/src/Optimize/Port.hs | 4 ++-- 6 files changed, 19 insertions(+), 9 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index 6b89e3bac..e28a3c8b2 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -52,7 +52,7 @@ data Expr | VarCycle A.Region ModuleName.Canonical Name | VarDebug A.Region Name ModuleName.Canonical (Maybe Name) | VarKernel A.Region Name Name - | Array [Expr] + | Array A.Region [Expr] | Function [Name] Expr | Call A.Region Expr [Expr] | TailCall Name [(Name, Expr)] @@ -218,7 +218,7 @@ instance Binary Expr where 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 c -> putWord8 11 >> put a >> put b >> put c - Array a -> putWord8 12 >> put a + Array a b -> putWord8 12 >> put a >> put b Function a b -> putWord8 13 >> 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 @@ -247,7 +247,7 @@ instance Binary Expr where 9 -> liftM3 VarCycle get get get 10 -> liftM4 VarDebug get get get get 11 -> liftM3 VarKernel get get get - 12 -> liftM Array get + 12 -> liftM2 Array get get 13 -> liftM2 Function get get 14 -> liftM3 Call get get get 15 -> liftM2 TailCall get get diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 20a71b99c..242a9298d 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -48,6 +48,7 @@ data Expr | Null | Json Json.Value | Array [Expr] + | TrackedArray ModuleName.Canonical A.Region [Expr] | Object [(Name, Expr)] | Ref Name | TrackedRef A.Position ModuleName.Canonical Name Name @@ -532,6 +533,11 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & addAscii "[ " & commaSepExpr (fromExpr level Whatever) exprs & addAscii " ]" + TrackedArray moduleName (A.Region start end) exprs -> + builder + & addTrackedByteString moduleName start "[ " + & commaSepExpr (fromExpr level Whatever) exprs + & addTrackedByteString moduleName end " ]" Object fields -> builder & addAscii "{ " diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 6451d61d5..f9653991a 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -80,8 +80,12 @@ generate mode parentModule expression = JsExpr $ generateDebug name home region unhandledValueName Opt.VarKernel _region home name -> JsExpr $ JS.Ref (JsName.fromKernel home name) - Opt.Array entries -> - JsExpr $ JS.Array $ map (generateJsExpr mode parentModule) entries + 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 parentModule body) Opt.Call (A.Region startPos _) func args -> diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 9cffdeaab..369825241 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -42,7 +42,7 @@ hasDebug expression = Opt.VarCycle _ _ _ -> False Opt.VarDebug _ _ _ _ -> True Opt.VarKernel _ _ _ -> False - Opt.Array exprs -> any hasDebug exprs + Opt.Array _ exprs -> any hasDebug exprs Opt.Function _ expr -> hasDebug expr Opt.Call _ e es -> hasDebug e || any hasDebug es Opt.TailCall _ args -> any (hasDebug . snd) args diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index d99fbc3d4..d51f565be 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -52,7 +52,7 @@ optimize cycle (A.At region expression) = Can.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 diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index f1b4a3cdd..64ff1c8ad 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -61,7 +61,7 @@ toEncoder tipe = object <- encode "object" keyValuePairs <- traverse encodeField (Map.toList fields) Names.registerFieldDict fields $ - Opt.Function [Name.dollar] (Opt.Call A.zero object [Opt.Array keyValuePairs]) + Opt.Function [Name.dollar] (Opt.Call A.zero object [Opt.Array A.zero keyValuePairs]) -- ENCODE HELPERS @@ -144,7 +144,7 @@ decodeMaybe tipe = return $ (Opt.Call A.zero) oneOf - [ Opt.Array + [ Opt.Array A.zero [ Opt.Call A.zero null [nothing], Opt.Call A.zero map_ [just, subDecoder] ] From 77bbfdb907b7e54f91eb420f1d86aef1b0da8e91 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 7 Jun 2023 19:17:35 +0200 Subject: [PATCH 41/47] Add sourcemaps for records. --- compiler/src/AST/Canonical.hs | 4 +-- compiler/src/AST/Optimized.hs | 12 ++++---- compiler/src/Canonicalize/Environment/Dups.hs | 29 +++++++++++++++++-- compiler/src/Canonicalize/Expression.hs | 11 +++---- compiler/src/Canonicalize/Type.hs | 3 -- compiler/src/Generate/JavaScript/Builder.hs | 19 ++++++++++-- .../src/Generate/JavaScript/Expression.hs | 28 +++++++++--------- compiler/src/Nitpick/Debug.hs | 4 +-- compiler/src/Optimize/Expression.hs | 7 +++-- compiler/src/Optimize/Names.hs | 4 +-- compiler/src/Optimize/Port.hs | 11 +++---- compiler/src/Reporting/Annotation.hs | 10 +++++++ compiler/src/Type/Constrain/Expression.hs | 9 +++--- 13 files changed, 98 insertions(+), 53 deletions(-) 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 e28a3c8b2..00e804f4b 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -62,8 +62,8 @@ data Expr | Case Name Name (Decider Choice) [(Int, Expr)] | Accessor Name | Access Expr A.Region Name - | Update Expr (Map.Map Name Expr) - | Record (Map.Map Name Expr) + | 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 @@ -228,8 +228,8 @@ instance Binary Expr where Case a b c d -> putWord8 19 >> put a >> put b >> put c >> put d Accessor a -> putWord8 20 >> put a Access a b c -> putWord8 21 >> put a >> put b >> put c - Update a b -> putWord8 22 >> put a >> put b - Record a -> putWord8 23 >> put a + Update a b c -> putWord8 22 >> put a >> put b >> put c + Record a b -> putWord8 23 >> put a >> put b get = do @@ -257,8 +257,8 @@ instance Binary Expr where 19 -> liftM4 Case get get get get 20 -> liftM Accessor get 21 -> liftM3 Access get get get - 22 -> liftM2 Update get get - 23 -> liftM Record get + 22 -> liftM3 Update get get get + 23 -> liftM2 Record get get _ -> fail "problem getting Opt.Expr binary" instance Binary Def where 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/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 242a9298d..ebd51eb82 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -50,6 +50,7 @@ data Expr | Array [Expr] | TrackedArray ModuleName.Canonical A.Region [Expr] | Object [(Name, Expr)] + | TrackedObject ModuleName.Canonical A.Region [(A.Located Name, Expr)] | Ref Name | TrackedRef A.Position ModuleName.Canonical Name Name | Access Expr Name -- foo.bar @@ -533,16 +534,23 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & addAscii "[ " & commaSepExpr (fromExpr level Whatever) exprs & addAscii " ]" - TrackedArray moduleName (A.Region start end) exprs -> + TrackedArray moduleName (A.Region start (A.Position endLine endCol)) exprs -> builder & addTrackedByteString moduleName start "[ " & commaSepExpr (fromExpr level Whatever) exprs - & addTrackedByteString moduleName end " ]" + & addAscii " " + & addTrackedByteString moduleName (A.Position endLine (endCol - 1)) "]" Object fields -> 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 -> addByteString (Name.toBuilder name) builder TrackedRef position moduleName name generatedName -> @@ -626,6 +634,13 @@ fromField level (field, expr) builder = & 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 + & addTrackedByteString moduleName start (Name.toBuilder field) + & addTrackedByteString moduleName end ": " + & fromExpr level Whatever expr + -- VALUES fromLValue :: Level -> LValue -> Builder -> Builder diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index f9653991a..98559ed5a 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -81,11 +81,11 @@ generate mode parentModule expression = Opt.VarKernel _region home name -> JsExpr $ JS.Ref (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 + 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 parentModule body) Opt.Call (A.Region startPos _) func args -> @@ -112,15 +112,15 @@ generate mode parentModule expression = ] Opt.Access record (A.Region startPos _) field -> JsExpr $ JS.TrackedAccess (generateJsExpr mode parentModule record) startPos parentModule (generateField mode field) - Opt.Update record fields -> + Opt.Update region record fields -> JsExpr $ JS.Call (JS.Ref (JsName.fromKernel Name.utils "update")) [ generateJsExpr mode parentModule record, - generateRecord mode parentModule fields + generateRecord mode parentModule region fields ] - Opt.Record fields -> - JsExpr $ generateRecord mode parentModule fields + Opt.Record region fields -> + JsExpr $ generateRecord mode parentModule region fields -- CODE CHUNKS @@ -190,11 +190,11 @@ ctorToInt home name index = -- RECORDS -generateRecord :: Mode.Mode -> ModuleName.Canonical -> Map.Map Name.Name Opt.Expr -> JS.Expr -generateRecord mode parentModule fields = - let toPair (field, value) = - (generateField mode field, generateJsExpr mode parentModule 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 = diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 369825241..74a2e38b5 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -52,8 +52,8 @@ hasDebug expression = 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.Update _ r fs -> hasDebug r || any hasDebug fs + Opt.Record _ fs -> any hasDebug fs defHasDebug :: Opt.Def -> Bool defHasDebug def = diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index d51f565be..af95c1737 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -11,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 @@ -38,7 +39,7 @@ optimize cycle (A.At region expression) = Can.VarForeign home name _ -> Names.registerGlobal region home name Can.VarCtor opts home name index _ -> - Names.registerCtor region 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 _ -> @@ -124,11 +125,11 @@ optimize cycle (A.At region expression) = optRecord <- optimize cycle record 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 diff --git a/compiler/src/Optimize/Names.hs b/compiler/src/Optimize/Names.hs index 91c8c43ca..1fb85e0bd 100644 --- a/compiler/src/Optimize/Names.hs +++ b/compiler/src/Optimize/Names.hs @@ -67,8 +67,8 @@ registerDebug name home region = let global = Opt.Global ModuleName.debug name in ok uid (Set.insert global deps) fields (Opt.VarDebug region name home Nothing) -registerCtor :: A.Region -> ModuleName.Canonical -> Name.Name -> Index.ZeroBased -> Can.CtorOpts -> Tracker Opt.Expr -registerCtor region 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 diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index 64ff1c8ad..b26872633 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -52,10 +52,10 @@ toEncoder tipe = encoder <- toEncoder fieldType 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 A.zero (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" @@ -144,7 +144,8 @@ decodeMaybe tipe = return $ (Opt.Call A.zero) oneOf - [ Opt.Array A.zero + [ Opt.Array + A.zero [ Opt.Call A.zero null [nothing], Opt.Call A.zero map_ [just, subDecoder] ] @@ -167,7 +168,7 @@ decodeRecord fields = 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 A.zero succeed [record]) 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 From 385425ca9f53dfd975a955532c31346d9e88b170 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Wed, 7 Jun 2023 19:58:21 +0200 Subject: [PATCH 42/47] Fix problem where core functions weren't added to the source map. --- compiler/src/Generate/JavaScript/Expression.hs | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 98559ed5a..9049a76f7 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -291,8 +291,12 @@ generateCallHelp mode pos parentModule func args = (map (generateJsExpr mode parentModule) args) generateGlobalCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateGlobalCall pos parentModule home name args = - generateNormalCall pos parentModule (JS.Ref (JsName.fromGlobal home name)) args +generateGlobalCall pos@(A.Position line col) parentModule home name args = + let ref = + if line == 0 && col == 0 + then JS.Ref (JsName.fromGlobal home name) + else JS.TrackedRef pos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + in generateNormalCall pos parentModule ref args generateNormalCall :: A.Position -> ModuleName.Canonical -> JS.Expr -> [JS.Expr] -> JS.Expr generateNormalCall pos parentModule func args = From f597a522b908cf840d5784d4d90a20ebe03a63f6 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 12 Jun 2023 23:10:49 +0200 Subject: [PATCH 43/47] Track function arguments. --- compiler/src/AST/Optimized.hs | 6 ++-- compiler/src/Generate/JavaScript/Builder.hs | 13 +++++++- .../src/Generate/JavaScript/Expression.hs | 32 ++++++++++++++++--- compiler/src/Optimize/Expression.hs | 22 ++++++------- compiler/src/Optimize/Port.hs | 6 ++-- 5 files changed, 57 insertions(+), 22 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index 00e804f4b..d392baa85 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -53,7 +53,7 @@ data Expr | VarDebug A.Region Name ModuleName.Canonical (Maybe Name) | VarKernel A.Region Name Name | Array A.Region [Expr] - | Function [Name] Expr + | Function [A.Located Name] Expr | Call A.Region Expr [Expr] | TailCall Name [(Name, Expr)] | If [(Expr, Expr)] Expr @@ -71,7 +71,7 @@ data Global = Global ModuleName.Canonical Name data Def = Def Name Expr - | TailDef Name [Name] Expr + | TailDef Name [A.Located Name] Expr data Destructor = Destructor Name Path @@ -126,7 +126,7 @@ data Main data Node = Define Expr (Set.Set Global) - | DefineTailFunc [Name] Expr (Set.Set Global) + | DefineTailFunc [A.Located Name] Expr (Set.Set Global) | Ctor Index.ZeroBased Int | Enum Index.ZeroBased | Box diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index ebd51eb82..44c59f547 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -63,6 +63,7 @@ data Expr | Call Expr [Expr] | TrackedNormalCall A.Position ModuleName.Canonical Expr Expr [Expr] | Function (Maybe Name) [Name] [Stmt] + | TrackedFunction ModuleName.Canonical [A.Located Name] [Stmt] data LValue = LRef Name @@ -618,6 +619,16 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = & fromStmtBlock nextLevel stmts & addByteString indent & addAscii "}" + TrackedFunction moduleName args stmts -> + builder + & addAscii "function" + & addAscii "(" + & commaSepExpr (\(A.At (A.Region start _) name) -> addName start moduleName name name) args + & addAscii ") {" + & addLine + & fromStmtBlock nextLevel stmts + & addByteString indent + & addAscii "}" trackedNameFromExpr :: Expr -> Maybe Name trackedNameFromExpr expr = @@ -637,7 +648,7 @@ fromField level (field, expr) builder = trackedFromField :: Level -> ModuleName.Canonical -> (A.Located Name, Expr) -> Builder -> Builder trackedFromField level moduleName (A.At (A.Region start end) field, expr) builder = builder - & addTrackedByteString moduleName start (Name.toBuilder field) + & addName start moduleName field field & addTrackedByteString moduleName end ": " & fromExpr level Whatever expr diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 9049a76f7..71be0c02e 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -87,7 +87,8 @@ generate mode parentModule expression = then JS.Array generatedEntries else JS.TrackedArray parentModule region generatedEntries Opt.Function args body -> - generateFunction (map JsName.fromLocal args) (generate mode parentModule body) + 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 startPos parentModule func args Opt.TailCall name args -> @@ -256,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 $ @@ -531,10 +555,10 @@ generateDef mode parentModule def = Opt.TailDef name argNames body -> JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode parentModule name argNames body)) -generateTailDef :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [Name.Name] -> Opt.Expr -> Code +generateTailDef :: Mode.Mode -> ModuleName.Canonical -> Name.Name -> [A.Located Name.Name] -> Opt.Expr -> Code generateTailDef mode parentModule name argNames body = - generateFunction (map JsName.fromLocal argNames) $ - JsBlock $ + 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 $ diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index af95c1737..b64e74723 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -101,7 +101,7 @@ optimize cycle (A.At region expression) = oexpr <- optimize cycle expr obody <- optimize cycle body pure $ - Opt.Let (Opt.Def name oexpr) (foldr Opt.Destruct obody destructs) + Opt.Let (Opt.Def (A.toValue name) oexpr) (foldr Opt.Destruct obody destructs) Can.Case expr branches -> let optimizeBranch root (Can.CaseBranch pattern branch) = do @@ -163,7 +163,7 @@ optimizeDefHelp cycle name args expr 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 = @@ -285,7 +285,7 @@ optimizePotentialTailCall cycle name args expr = toTailDef name argNames destructors <$> optimizeTail cycle name argNames expr -optimizeTail :: Cycle -> Name.Name -> [Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr +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 -> @@ -299,7 +299,7 @@ optimizeTail cycle rootName argNames locExpr@(A.At region 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 _ _ -> @@ -335,7 +335,7 @@ optimizeTail cycle rootName argNames locExpr@(A.At region expression) = 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 (A.toValue dname) oexpr) (foldr Opt.Destruct obody destructors) Can.Case expr branches -> let optimizeBranch root (Can.CaseBranch pattern branch) = do @@ -357,7 +357,7 @@ optimizeTail cycle rootName argNames locExpr@(A.At region expression) = -- DETECT TAIL CALLS -toTailDef :: Name.Name -> [Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def +toTailDef :: Name.Name -> [A.Located Name.Name] -> [Opt.Destructor] -> Opt.Expr -> Opt.Def toTailDef name argNames destructors body = if hasTailCall body then Opt.TailDef name argNames (foldr Opt.Destruct body destructors) diff --git a/compiler/src/Optimize/Port.hs b/compiler/src/Optimize/Port.hs index b26872633..21eff5d5e 100644 --- a/compiler/src/Optimize/Port.hs +++ b/compiler/src/Optimize/Port.hs @@ -61,7 +61,7 @@ toEncoder tipe = object <- encode "object" keyValuePairs <- traverse encodeField (Map.toList fields) Names.registerFieldDict fields $ - Opt.Function [Name.dollar] (Opt.Call A.zero object [Opt.Array A.zero keyValuePairs]) + Opt.Function [A.At A.zero Name.dollar] (Opt.Call A.zero object [Opt.Array A.zero keyValuePairs]) -- ENCODE HELPERS @@ -72,7 +72,7 @@ encodeMaybe tipe = encoder <- toEncoder tipe destruct <- Names.registerGlobal A.zero ModuleName.maybe "destruct" return $ - Opt.Function [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 @@ -183,7 +183,7 @@ fieldAndThen decoder (key, Can.FieldType _ tipe) = return $ (Opt.Call A.zero) andThen - [ Opt.Function [key] decoder, + [ Opt.Function [A.At A.zero key] decoder, Opt.Call A.zero field [Opt.Str A.zero (Name.toGrenString key), typeDecoder] ] From 8c04d28357e8db163e01a9923e3101dea249d53d Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 12 Jun 2023 23:31:44 +0200 Subject: [PATCH 44/47] Fix bug where not all function calls were tracked in source maps. --- compiler/src/AST/Optimized.hs | 6 +-- .../src/Generate/JavaScript/Expression.hs | 37 +++++++++++++++++-- compiler/src/Nitpick/Debug.hs | 2 +- compiler/src/Optimize/Expression.hs | 2 +- 4 files changed, 38 insertions(+), 9 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index d392baa85..7071e2f6c 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -60,7 +60,7 @@ data Expr | Let Def Expr | Destruct Destructor Expr | Case Name Name (Decider Choice) [(Int, Expr)] - | Accessor Name + | 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) @@ -226,7 +226,7 @@ instance Binary Expr where 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 + 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 @@ -255,7 +255,7 @@ instance Binary Expr where 17 -> liftM2 Let get get 18 -> liftM2 Destruct get get 19 -> liftM4 Case get get get get - 20 -> liftM Accessor get + 20 -> liftM2 Accessor get get 21 -> liftM3 Access get get get 22 -> liftM3 Update get get get 23 -> liftM2 Record get get diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 71be0c02e..b53c14fd1 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 @@ -103,7 +104,7 @@ generate mode parentModule expression = in JsBlock $ pathDef : codeToStmtList (generate mode parentModule body) Opt.Case label root decider jumps -> JsBlock $ generateCase mode parentModule label root decider jumps - Opt.Accessor field -> + Opt.Accessor _ field -> JsExpr $ JS.Function Nothing @@ -462,12 +463,40 @@ isLiteral expr = apply :: Opt.Expr -> Opt.Expr -> Opt.Expr apply func value = case func of - Opt.Accessor field -> - Opt.Access value A.zero field + Opt.Accessor region field -> + Opt.Access value region field Opt.Call region f args -> Opt.Call region f (args ++ [value]) _ -> - Opt.Call A.zero func [value] + Opt.Call (Maybe.fromMaybe A.zero (exprRegion func)) func [value] + +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 = diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 74a2e38b5..948738e96 100644 --- a/compiler/src/Nitpick/Debug.hs +++ b/compiler/src/Nitpick/Debug.hs @@ -50,7 +50,7 @@ hasDebug expression = 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.Accessor _ _ -> False Opt.Access r _ _ -> hasDebug r Opt.Update _ r fs -> hasDebug r || any hasDebug fs Opt.Record _ fs -> any hasDebug fs diff --git a/compiler/src/Optimize/Expression.hs b/compiler/src/Optimize/Expression.hs index b64e74723..c65507b70 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -119,7 +119,7 @@ optimize cycle (A.At region expression) = obranches <- traverse (optimizeBranch temp) branches return $ Opt.Let (Opt.Def temp oexpr) (Case.optimize temp temp obranches) Can.Accessor field -> - Names.registerField field (Opt.Accessor field) + Names.registerField field (Opt.Accessor region field) Can.Access record (A.At fieldPosition field) -> do optRecord <- optimize cycle record From 4aea94db39618e14e856faabb5eeaf83a943d19b Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Mon, 12 Jun 2023 23:43:44 +0200 Subject: [PATCH 45/47] Track more refs. --- .../src/Generate/JavaScript/Expression.hs | 21 +++++++++---------- 1 file changed, 10 insertions(+), 11 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index b53c14fd1..2b0afd1ea 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -63,24 +63,23 @@ generate mode parentModule expression = JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) - Opt.VarEnum _region (Opt.Global home name) index -> + 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 startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) Mode.Prod _ -> JsExpr $ JS.Int (Index.toMachine index) - Opt.VarBox _region (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 _region home name -> - JsExpr $ JS.Call (JS.Ref (JsName.fromCycle home name)) [] + case mode of + Mode.Dev _ -> JS.TrackedRef startPos parentModule (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 startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromCycle home name)) [] Opt.VarDebug region name home unhandledValueName -> JsExpr $ generateDebug name home region unhandledValueName - Opt.VarKernel _region home name -> - JsExpr $ JS.Ref (JsName.fromKernel home name) + Opt.VarKernel (A.Region startPos _) home name -> + JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromKernel home name) (JsName.fromKernel home name) Opt.Array region entries -> let generatedEntries = map (generateJsExpr mode parentModule) entries in JsExpr $ From f90d90924ba7fd1b67f690511230811d9b401aa4 Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 13 Jun 2023 00:12:41 +0200 Subject: [PATCH 46/47] Track vars and function names. --- compiler/src/AST/Optimized.hs | 24 ++++----- compiler/src/Generate/JavaScript.hs | 17 ++++--- compiler/src/Generate/JavaScript/Builder.hs | 10 ++++ .../src/Generate/JavaScript/Expression.hs | 10 ++-- compiler/src/Nitpick/Debug.hs | 8 +-- compiler/src/Optimize/Expression.hs | 50 +++++++++---------- compiler/src/Optimize/Module.hs | 24 ++++----- 7 files changed, 80 insertions(+), 63 deletions(-) diff --git a/compiler/src/AST/Optimized.hs b/compiler/src/AST/Optimized.hs index 7071e2f6c..d87d8a7d1 100644 --- a/compiler/src/AST/Optimized.hs +++ b/compiler/src/AST/Optimized.hs @@ -70,8 +70,8 @@ data Global = Global ModuleName.Canonical Name -- DEFINITIONS data Def - = Def Name Expr - | TailDef Name [A.Located 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 [A.Located 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 @@ -264,15 +264,15 @@ instance Binary Expr where 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/Generate/JavaScript.hs b/compiler/src/Generate/JavaScript.hs index 2c391c099..09db94e56 100644 --- a/compiler/src/Generate/JavaScript.hs +++ b/compiler/src/Generate/JavaScript.hs @@ -26,6 +26,7 @@ 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 @@ -140,16 +141,16 @@ 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 home 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 home name argNames body) + in trackedVar region global (Expr.generateTailDef mode home name argNames body) ) Opt.Ctor index arity -> addStmt @@ -202,6 +203,10 @@ 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 @@ -236,9 +241,9 @@ 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 -> + Opt.Def _ name expr -> JS.Var (JsName.fromGlobal home name) (Expr.codeToExpr (Expr.generate mode home expr)) - Opt.TailDef name args 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 diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index 44c59f547..d0b8f32eb 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -86,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] @@ -412,6 +413,15 @@ fromStmt level@(Level indent nextLevel) statement builder = & fromExpr level Whatever expr & addAscii ";" & addLine + TrackedVar moduleName pos name genName expr -> + builder + & addByteString indent + & addAscii "var " + & addName pos moduleName name genName + & addAscii " = " + & fromExpr level Whatever expr + & addAscii ";" + & addLine Vars [] -> builder Vars vars -> diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 2b0afd1ea..777a06653 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -578,10 +578,12 @@ generateTailCall mode parentModule name args = 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 parentModule body) - Opt.TailDef name argNames body -> - JS.Var (JsName.fromLocal name) (codeToExpr (generateTailDef mode parentModule name argNames body)) + 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 = diff --git a/compiler/src/Nitpick/Debug.hs b/compiler/src/Nitpick/Debug.hs index 948738e96..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 @@ -58,8 +58,8 @@ hasDebug expression = 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 c65507b70..b783b2bc6 100644 --- a/compiler/src/Optimize/Expression.hs +++ b/compiler/src/Optimize/Expression.hs @@ -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 (A.toValue 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 @@ -117,7 +117,7 @@ optimize cycle (A.At region expression) = _ -> 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 region field) Can.Access record (A.At fieldPosition field) -> @@ -143,23 +143,23 @@ 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 @@ -273,16 +273,16 @@ 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 -> [A.Located Name.Name] -> Can.Expr -> Names.Tracker Opt.Expr @@ -331,11 +331,11 @@ optimizeTail cycle rootName argNames locExpr@(A.At region 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 (A.toValue 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 @@ -351,17 +351,17 @@ optimizeTail cycle rootName argNames locExpr@(A.At region expression) = _ -> 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 -> [A.Located 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) From 8849d011de3a5cfd092b2e2c04e69cdac448a8cb Mon Sep 17 00:00:00 2001 From: Robin Heggelund Hansen Date: Tue, 13 Jun 2023 00:20:55 +0200 Subject: [PATCH 47/47] Be consistent on ordering of positions and moduleNames. --- compiler/src/Generate/JavaScript/Builder.hs | 28 +++--- .../src/Generate/JavaScript/Expression.hs | 90 +++++++++---------- 2 files changed, 58 insertions(+), 60 deletions(-) diff --git a/compiler/src/Generate/JavaScript/Builder.hs b/compiler/src/Generate/JavaScript/Builder.hs index d0b8f32eb..6f9c95710 100644 --- a/compiler/src/Generate/JavaScript/Builder.hs +++ b/compiler/src/Generate/JavaScript/Builder.hs @@ -52,16 +52,16 @@ data Expr | Object [(Name, Expr)] | TrackedObject ModuleName.Canonical A.Region [(A.Located Name, Expr)] | Ref Name - | TrackedRef A.Position ModuleName.Canonical Name Name + | TrackedRef ModuleName.Canonical A.Position Name Name | Access Expr Name -- foo.bar - | TrackedAccess Expr A.Position ModuleName.Canonical Name + | 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 A.Position ModuleName.Canonical Expr Expr [Expr] + | TrackedNormalCall ModuleName.Canonical A.Position Expr Expr [Expr] | Function (Maybe Name) [Name] [Stmt] | TrackedFunction ModuleName.Canonical [A.Located Name] [Stmt] @@ -158,8 +158,6 @@ addAscii code (Builder _code _currLine _currCol _mappings) = _mappings = _mappings } --- TODO: This is a crutch used during prototyping --- Should be removed once things stabalizes as it's bad for perf addByteString :: B.Builder -> Builder -> Builder addByteString bsBuilder (Builder _code _currLine _currCol _mappings) = let lazyByteString = B.toLazyByteString bsBuilder @@ -213,8 +211,8 @@ addTrackedByteString moduleName (A.Position line col) bsBuilder (Builder _code _ _mappings = newMappings } -addName :: A.Position -> ModuleName.Canonical -> Name -> Name -> Builder -> Builder -addName (A.Position line col) moduleName name genName (Builder _code _currLine _currCol _mappings) = +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 @@ -234,8 +232,8 @@ addName (A.Position line col) moduleName name genName (Builder _code _currLine _ : _mappings } -addTrackedDot :: A.Position -> ModuleName.Canonical -> Builder -> Builder -addTrackedDot (A.Position line col) moduleName (Builder _code _currLine _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, @@ -417,7 +415,7 @@ fromStmt level@(Level indent nextLevel) statement builder = builder & addByteString indent & addAscii "var " - & addName pos moduleName name genName + & addName moduleName pos name genName & addAscii " = " & fromExpr level Whatever expr & addAscii ";" @@ -568,11 +566,11 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = addName position moduleName name generatedName builder Access expr field -> makeDot level expr field builder - TrackedAccess expr position@(A.Position fieldLine fieldCol) moduleName field -> + TrackedAccess expr moduleName position@(A.Position fieldLine fieldCol) field -> builder & fromExpr level Atomic expr - & addTrackedDot (A.Position fieldLine (fieldCol - 1)) moduleName - & addName position moduleName field field + & addTrackedDot moduleName (A.Position fieldLine (fieldCol - 1)) + & addName moduleName position field field Index expr bracketedExpr -> makeBracketed level expr bracketedExpr builder Prefix op expr -> @@ -633,7 +631,7 @@ fromExpr level@(Level indent nextLevel) grouping expression builder = builder & addAscii "function" & addAscii "(" - & commaSepExpr (\(A.At (A.Region start _) name) -> addName start moduleName name name) args + & commaSepExpr (\(A.At (A.Region start _) name) -> addName moduleName start name name) args & addAscii ") {" & addLine & fromStmtBlock nextLevel stmts @@ -658,7 +656,7 @@ fromField level (field, expr) builder = trackedFromField :: Level -> ModuleName.Canonical -> (A.Located Name, Expr) -> Builder -> Builder trackedFromField level moduleName (A.At (A.Region start end) field, expr) builder = builder - & addName start moduleName field field + & addName moduleName start field field & addTrackedByteString moduleName end ": " & fromExpr level Whatever expr diff --git a/compiler/src/Generate/JavaScript/Expression.hs b/compiler/src/Generate/JavaScript/Expression.hs index 777a06653..bd4aa8480 100644 --- a/compiler/src/Generate/JavaScript/Expression.hs +++ b/compiler/src/Generate/JavaScript/Expression.hs @@ -60,26 +60,26 @@ generate mode parentModule expression = Opt.Float (A.Region start _) float -> JsExpr $ JS.TrackedFloat parentModule start (Utf8.toBuilder float) Opt.VarLocal (A.Region startPos _) name -> - JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) + JsExpr $ JS.TrackedRef parentModule startPos (JsName.fromLocalHumanReadable name) (JsName.fromLocal name) Opt.VarGlobal (A.Region startPos _) (Opt.Global home name) -> - JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal 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.TrackedRef startPos parentModule (JsName.fromGlobalHumanReadable home name) (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 (A.Region startPos _) (Opt.Global home name) -> JsExpr $ case mode of - Mode.Dev _ -> JS.TrackedRef startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + 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 startPos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromCycle 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 (A.Region startPos _) home name -> - JsExpr $ JS.TrackedRef startPos parentModule (JsName.fromKernel home name) (JsName.fromKernel 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 $ @@ -90,7 +90,7 @@ generate mode parentModule expression = 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 startPos parentModule func args + JsExpr $ generateCall mode parentModule startPos func args Opt.TailCall name args -> JsBlock $ generateTailCall mode parentModule name args Opt.If branches final -> @@ -112,7 +112,7 @@ generate mode parentModule expression = JS.Access (JS.Ref JsName.dollar) (generateField mode field) ] Opt.Access record (A.Region startPos _) field -> - JsExpr $ JS.TrackedAccess (generateJsExpr mode parentModule record) startPos parentModule (generateField mode field) + JsExpr $ JS.TrackedAccess (generateJsExpr mode parentModule record) parentModule startPos (generateField mode field) Opt.Update region record fields -> JsExpr $ JS.Call @@ -287,46 +287,46 @@ funcHelpers = -- CALLS -generateCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCall mode pos parentModule 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 _) _) | pkg == Pkg.core -> - generateCoreCall mode pos parentModule global args + generateCoreCall mode parentModule pos global args Opt.VarBox _ _ -> case mode of Mode.Dev _ -> - generateCallHelp mode pos parentModule func args + generateCallHelp mode parentModule pos func args Mode.Prod _ -> case args of [arg] -> generateJsExpr mode parentModule arg _ -> - generateCallHelp mode pos parentModule func args + generateCallHelp mode parentModule pos func args _ -> - generateCallHelp mode pos parentModule func args + generateCallHelp mode parentModule pos func args -generateCallHelp :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Expr -> [Opt.Expr] -> JS.Expr -generateCallHelp mode pos parentModule func args = +generateCallHelp :: Mode.Mode -> ModuleName.Canonical -> A.Position -> Opt.Expr -> [Opt.Expr] -> JS.Expr +generateCallHelp mode parentModule pos func args = generateNormalCall - pos parentModule + pos (generateJsExpr mode parentModule func) (map (generateJsExpr mode parentModule) args) -generateGlobalCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateGlobalCall pos@(A.Position line col) parentModule home name 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 pos parentModule (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) - in generateNormalCall pos parentModule ref args + else JS.TrackedRef parentModule pos (JsName.fromGlobalHumanReadable home name) (JsName.fromGlobal home name) + in generateNormalCall parentModule pos ref args -generateNormalCall :: A.Position -> ModuleName.Canonical -> JS.Expr -> [JS.Expr] -> JS.Expr -generateNormalCall pos parentModule func 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.TrackedNormalCall pos parentModule helper func args + JS.TrackedNormalCall parentModule pos helper func args Nothing -> List.foldl' (\f a -> JS.Call f [a]) func args @@ -337,25 +337,25 @@ callHelpers = -- CORE CALLS -generateCoreCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> Opt.Global -> [Opt.Expr] -> JS.Expr -generateCoreCall mode pos parentModule (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 pos parentModule home name args + then generateBasicsCall mode parentModule pos home name args else if moduleName == Name.bitwise - then generateBitwiseCall pos parentModule home name (map (generateJsExpr mode parentModule) args) + then generateBitwiseCall parentModule pos home name (map (generateJsExpr mode parentModule) args) else if moduleName == Name.math - then generateMathCall pos parentModule home name (map (generateJsExpr mode parentModule) args) - else generateGlobalCall pos parentModule home name (map (generateJsExpr mode parentModule) args) + then generateMathCall parentModule pos home name (map (generateJsExpr mode parentModule) args) + else generateGlobalCall parentModule pos home name (map (generateJsExpr mode parentModule) args) -generateBitwiseCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateBitwiseCall pos parentModule 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 pos parentModule home name args + _ -> generateGlobalCall parentModule pos home name args [left, right] -> case name of "and" -> JS.Infix JS.OpBitwiseAnd left right @@ -364,12 +364,12 @@ generateBitwiseCall pos parentModule 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 pos parentModule home name args + _ -> generateGlobalCall parentModule pos home name args _ -> - generateGlobalCall pos parentModule home name args + generateGlobalCall parentModule pos home name args -generateBasicsCall :: Mode.Mode -> A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [Opt.Expr] -> JS.Expr -generateBasicsCall mode pos parentModule 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 parentModule grenArg @@ -377,7 +377,7 @@ generateBasicsCall mode pos parentModule home name args = "not" -> JS.Prefix JS.PrefixNot arg "negate" -> JS.Prefix JS.PrefixNegate arg "toFloat" -> arg - _ -> generateGlobalCall pos parentModule home name [arg] + _ -> generateGlobalCall parentModule pos home name [arg] [grenLeft, grenRight] -> case name of -- NOTE: removed "composeL" and "composeR" because of this issue: @@ -403,23 +403,23 @@ generateBasicsCall mode pos parentModule 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 pos parentModule home name [left, right] + _ -> generateGlobalCall parentModule pos home name [left, right] _ -> - generateGlobalCall pos parentModule home name (map (generateJsExpr mode parentModule) args) + generateGlobalCall parentModule pos home name (map (generateJsExpr mode parentModule) args) -generateMathCall :: A.Position -> ModuleName.Canonical -> ModuleName.Canonical -> Name.Name -> [JS.Expr] -> JS.Expr -generateMathCall pos parentModule 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 pos parentModule home name [arg] + _ -> generateGlobalCall parentModule pos home name [arg] [left, right] -> case name of "remainderBy" -> JS.Infix JS.OpMod right left - _ -> generateGlobalCall pos parentModule home name [left, right] + _ -> generateGlobalCall parentModule pos home name [left, right] _ -> - generateGlobalCall pos parentModule home name args + generateGlobalCall parentModule pos home name args equal :: JS.Expr -> JS.Expr -> JS.Expr equal left right =