git.iko.soy/elk
on master help sign in
Code gen can customize how variables are generated
ceb9175Evan Czaplicki
elm-compiler.cabal+1
compare with master
unifiedsplit
@@ -90,6 +90,7 @@ Library
90 Generate.JavaScript,
90 Generate.JavaScript,
91 Generate.JavaScript.Builder,
91 Generate.JavaScript.Builder,
92 Generate.JavaScript.BuiltIn,
92 Generate.JavaScript.BuiltIn,
93+ Generate.JavaScript.Effects,
93 Generate.JavaScript.Expression,
94 Generate.JavaScript.Expression,
94 Generate.JavaScript.Foreign,
95 Generate.JavaScript.Foreign,
95 Generate.JavaScript.Helpers,
96 Generate.JavaScript.Helpers,
src/Elm/Compiler.hs+10−10
@@ -1,14 +1,14 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Compiler
2module Elm.Compiler
3− ( version
3+ ( version
4− , parseDependencies, Tag(..)
4+ , parseDependencies, Tag(..)
5− , compile, Context(..), Result(..)
5+ , compile, Context(..), Result(..)
6− , generate
6+ , generate
7− , Localizer, dummyLocalizer
7+ , Localizer, dummyLocalizer
8− , Error, errorToDoc, errorToJson
8+ , Error, errorToDoc, errorToJson
9− , Warning, warningToDoc, warningToJson
9+ , Warning, warningToDoc, warningToJson
10− )
10+ )
11− where
11+ where
12
12
13import qualified Data.Aeson as Json
13import qualified Data.Aeson as Json
14import qualified Data.Map as Map
14import qualified Data.Map as Map
@@ -152,7 +152,7 @@ docsGen isExposed (Module.Module name info) =
152-- CODE GENERATION
152-- CODE GENERATION
153
153
154
154
155−generate :: Obj.Graph -> Obj.Roots -> (Set.Set M.Canonical, BS.Builder)
155+generate :: Obj.SymbolTable -> Obj.Graph -> Obj.Roots -> (Set.Set M.Canonical, BS.Builder)
156generate =
156generate =
157 JS.generate
157 JS.generate
158
158
src/Elm/Compiler/Module.hs+1−11
@@ -20,7 +20,6 @@ module Elm.Compiler.Module
20
20
21 -- canonical names
21 -- canonical names
22 , ModuleName.Canonical(..)
22 , ModuleName.Canonical(..)
23− , qualifiedVar
24 )
23 )
25 where
24 where
26
25
@@ -36,7 +35,6 @@ import qualified AST.Module as Module
36import qualified AST.Module.Name as ModuleName
35import qualified AST.Module.Name as ModuleName
37import qualified Elm.Compiler.Type as PublicType
36import qualified Elm.Compiler.Type as PublicType
38import qualified Elm.Compiler.Type.Extract as Extract
37import qualified Elm.Compiler.Type.Extract as Extract
39−import qualified Generate.JavaScript.Variable as Gen
40
38
41
39
42
40
@@ -45,7 +43,7 @@ import qualified Generate.JavaScript.Variable as Gen
45
43
46interfaceAliasedTypes :: Module.Interface -> Map.Map Text PublicType.Type
44interfaceAliasedTypes :: Module.Interface -> Map.Map Text PublicType.Type
47interfaceAliasedTypes interface =
45interfaceAliasedTypes interface =
48− Map.map Extract.extract (Module.iTypes interface)
46+ Map.map Extract.extract (Module.iTypes interface)
49
47
50
48
51programTypes :: Module.Interfaces -> ModuleName.Canonical -> Maybe PublicType.Program
49programTypes :: Module.Interfaces -> ModuleName.Canonical -> Maybe PublicType.Program
@@ -136,11 +134,3 @@ instance Json.FromJSON RawForJson where
136 parseJSON _ =
134 parseJSON _ =
137 fail "expecting the module name to be a string"
135 fail "expecting the module name to be a string"
138
136
139−
140−
141−-- CANONICAL NAMES
142−
143−
144−qualifiedVar :: ModuleName.Canonical -> Text -> Text
145−qualifiedVar =
146− Gen.qualified
src/Elm/Compiler/Objects.hs+2−1
@@ -1,6 +1,7 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2module Elm.Compiler.Objects
2module Elm.Compiler.Objects
3+ ( Symbol(..)
3− ( Graph
4+ , Graph
4 , union
5 , union
5 , unions
6 , unions
6 , Roots
7 , Roots
src/Elm/Compiler/Objects/Internal.hs+36−3
@@ -5,6 +5,9 @@ module Elm.Compiler.Objects.Internal
5 , fromModule
5 , fromModule
6 , union
6 , union
7 , unions
7 , unions
8+ , SymbolTable
9+ , Symbol(..)
10+ , lookup
8 , Roots
11 , Roots
9 , root
12 , root
10 , toGlobals
13 , toGlobals
@@ -12,7 +15,9 @@ module Elm.Compiler.Objects.Internal
12 where
15 where
13
16
14
17
18+import Prelude hiding (lookup)
15import Control.Arrow (first)
19import Control.Arrow (first)
20+import Control.Monad (liftM, liftM2)
16import Data.Binary
21import Data.Binary
17import qualified Data.Map as Map
22import qualified Data.Map as Map
18
23
@@ -24,7 +29,7 @@ import qualified Elm.Package as Pkg
24
29
25
30
26
31
27−-- OBJECTS
32+-- OBJECT GRAPH
28
33
29
34
30newtype Graph =
35newtype Graph =
@@ -32,7 +37,7 @@ newtype Graph =
32
37
33
38
34
39
35−-- HELPERS
40+-- OBJECT GRAPH HELPERS
36
41
37
42
38fromModule :: Module.Optimized -> Graph
43fromModule :: Module.Optimized -> Graph
@@ -57,6 +62,26 @@ destruct (Graph graph) =
57
62
58
63
59
64
65+-- SYMBOLS
66+
67+
68+data Symbol =
69+ Symbol
70+ { _home :: !Word16
71+ , _name :: !Word32
72+ }
73+
74+
75+newtype SymbolTable =
76+ SymbolTable (Map.Map Var.Global Symbol)
77+
78+
79+lookup :: Var.Global -> SymbolTable -> Maybe Symbol
80+lookup var (SymbolTable symbols) =
81+ Map.lookup var symbols
82+
83+
84+
60-- ROOTS
85-- ROOTS
61
86
62
87
@@ -85,4 +110,12 @@ instance Binary Graph where
85 put dict
110 put dict
86
111
87 get =
112 get =
88− Graph <$> get
113+ liftM Graph get
114+
115+
116+instance Binary Symbol where
117+ put (Symbol home name) =
118+ put home >> put name
119+
120+ get =
121+ liftM2 Symbol get get
src/Generate/JavaScript.hs+27−86
@@ -2,13 +2,12 @@
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript (generate) where
3module Generate.JavaScript (generate) where
4
4
5−import qualified Control.Monad.State as State
5+import Prelude hiding (init)
6import Data.Monoid ((<>))
6import Data.Monoid ((<>))
7import qualified Data.List as List
7import qualified Data.List as List
8import qualified Data.Map as Map
8import qualified Data.Map as Map
9import qualified Data.Set as Set
9import qualified Data.Set as Set
10import qualified Data.Text as Text
10import qualified Data.Text as Text
11−import Data.Text (Text)
12import qualified Data.ByteString.Builder as BS
11import qualified Data.ByteString.Builder as BS
13
12
14import qualified AST.Effects as Effects
13import qualified AST.Effects as Effects
@@ -18,8 +17,8 @@ import qualified AST.Variable as Var
18import qualified Elm.Package as Pkg
17import qualified Elm.Package as Pkg
19import qualified Elm.Compiler.Objects.Internal as Obj
18import qualified Elm.Compiler.Objects.Internal as Obj
20import qualified Generate.JavaScript.Builder as JS
19import qualified Generate.JavaScript.Builder as JS
20+import qualified Generate.JavaScript.Effects as Effects
21import qualified Generate.JavaScript.Expression as JS
21import qualified Generate.JavaScript.Expression as JS
22−import qualified Generate.JavaScript.Helpers as JS
23import qualified Generate.JavaScript.Variable as JS
22import qualified Generate.JavaScript.Variable as JS
24
23
25
24
@@ -27,37 +26,38 @@ import qualified Generate.JavaScript.Variable as JS
27-- GENERATE JAVASCRIPT
26-- GENERATE JAVASCRIPT
28
27
29
28
30−generate :: Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)
29+generate :: Obj.SymbolTable -> Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)
31−generate (Obj.Graph graph) roots =
30+generate symbols (Obj.Graph graph) roots =
32 let
31 let
33− (State builders _ natives effects) =
32+ (State builders _ natives effects table) =
34− List.foldl' (crawl graph) empty (Obj.toGlobals roots)
33+ List.foldl' (crawl graph) (init symbols) (Obj.toGlobals roots)
35
34
36 managers =
35 managers =
37− Map.foldrWithKey addManager "" effects
36+ fst $ JS.run table (Effects.generate effects)
38
37
39 javascript =
38 javascript =
40− List.foldl' (\rest js -> js <> rest) managers builders
39+ List.foldl' (\rest stmt -> JS.encodeUtf8 stmt <> rest) managers builders
41 in
40 in
42 (natives, javascript)
41 (natives, javascript)
43
42
44
43
45
44
46−-- DEAD CODE ELIMINATION
45+-- DCE STATE
47
46
48
47
49data State =
48data State =
50 State
49 State
51− { _js :: [BS.Builder]
50+ { _stmts :: [JS.Stmt]
52 , _seen :: Set.Set Var.Global
51 , _seen :: Set.Set Var.Global
53 , _natives :: Set.Set ModuleName.Canonical
52 , _natives :: Set.Set ModuleName.Canonical
54 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
53 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType
54+ , _table :: JS.Table
55 }
55 }
56
56
57
57
58−empty :: State
58+init :: Obj.SymbolTable -> State
59−empty =
59+init symbols =
60− State [] Set.empty Set.empty Map.empty
60+ State [] Set.empty Set.empty Map.empty (JS.init symbols)
61
61
62
62
63
63
@@ -68,7 +68,7 @@ type Graph = Map.Map Var.Global Opt.Decl
68
68
69
69
70crawl :: Graph -> State -> Var.Global -> State
70crawl :: Graph -> State -> Var.Global -> State
71−crawl graph state@(State js seen natives effects) name@(Var.Global home _) =
71+crawl graph state@(State js seen natives effects table) name@(Var.Global home _) =
72 if Set.member name seen then
72 if Set.member name seen then
73 state
73 state
74
74
@@ -82,35 +82,29 @@ crawl graph state@(State js seen natives effects) name@(Var.Global home _) =
82
82
83 Nothing ->
83 Nothing ->
84 if ModuleName.canonicalIsNative home then
84 if ModuleName.canonicalIsNative home then
85− State js seen (Set.insert home natives) effects
85+ State js seen (Set.insert home natives) effects table
86 else
86 else
87 error (crawlError name)
87 error (crawlError name)
88
88
89
89
90−virtualDomDebug :: ModuleName.Canonical
91−virtualDomDebug =
92− ModuleName.inVirtualDom "VirtualDom.Debug"
93−
94−
95crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State
90crawlDecl :: Graph -> Var.Global -> Opt.Decl -> State -> State
96−crawlDecl graph name@(Var.Global home _) (Opt.Decl deps mfx body) state =
91+crawlDecl graph var@(Var.Global home name) (Opt.Decl deps fx body) state =
97 let
92 let
98 newState =
93 newState =
99− state { _seen = Set.insert name (_seen state) }
94+ state { _seen = Set.insert var (_seen state) }
100
95
101− (State js seen natives effects) =
96+ (State stmts seen natives effects table) =
102 Set.foldl' (crawl graph) newState deps
97 Set.foldl' (crawl graph) newState deps
103
98
104− newEffects =
99+ (stmt, newTable) =
105− case mfx of
100+ JS.run table (JS.generateDecl home name body)
106− Nothing -> effects
107− Just fx -> Map.insert home fx effects
108 in
101 in
109 State
102 State
110− { _js = generateDecl name body : js
103+ { _stmts = stmt : stmts
111 , _seen = seen
104 , _seen = seen
112 , _natives = natives
105 , _natives = natives
113− , _effects = newEffects
106+ , _effects = maybe id (Map.insert home) fx effects
107+ , _table = newTable
114 }
108 }
115
109
116
110
@@ -123,59 +117,6 @@ crawlError (Var.Global (ModuleName.Canonical pkg home) name) =
123 <> "try to make an <http://sscce.org/> that demonstrates the issue!"
117 <> "try to make an <http://sscce.org/> that demonstrates the issue!"
124
118
125
119
126−generateDecl :: Var.Global -> Opt.Def -> BS.Builder
120+virtualDomDebug :: ModuleName.Canonical
127−generateDecl (Var.Global home name) def =
121+virtualDomDebug =
128− let
122+ ModuleName.inVirtualDom "VirtualDom.Debug"
129− genBody =
130− JS.generateDecl home name def
131− in
132− JS.encodeUtf8 (State.evalState genBody 0)
133−
134−
135−
136−-- ADD EFFECT MANAGER
137−
138−
139−addManager :: ModuleName.Canonical -> Effects.ManagerType -> BS.Builder -> BS.Builder
140−addManager name manager builder =
141− JS.encodeUtf8 [genManager name manager] <> builder
142−
143−
144−genManager :: ModuleName.Canonical -> Effects.ManagerType -> JS.Stmt
145−genManager moduleName@(ModuleName.Canonical pkg _) manager =
146− let
147− managers =
148− JS.coreNative "Platform" "effectManagers"
149−
150− managerName =
151− JS.String (ModuleName.canonicalToText moduleName)
152−
153− entry name =
154− ( JS.IdProp (JS.Id name)
155− , JS.ref (JS.qualified moduleName name)
156− )
157−
158− managerEntries =
159− [ "pkg" ==> Pkg.toText pkg
160− , entry "init"
161− , entry "onEffects"
162− , entry "onSelfMsg"
163− ]
164−
165− otherEntries =
166− case manager of
167− Effects.Cmds -> [ "tag" ==> "cmd", entry "cmdMap" ]
168− Effects.Subs -> [ "tag" ==> "sub", entry "subMap" ]
169− Effects.Both -> [ "tag" ==> "fx", entry "cmdMap", entry "subMap" ]
170− in
171− JS.ExprStmt $
172− JS.Assign
173− (JS.LBracket managers managerName)
174− (JS.Object (managerEntries ++ otherEntries))
175−
176−
177−(==>) :: Text -> Text -> ( JS.Prop, JS.Expr )
178−(==>) key value =
179− ( JS.IdProp (JS.Id key)
180− , JS.String value
181− )
src/Generate/JavaScript/Builder.hs+2−2
@@ -130,9 +130,9 @@ data PrefixOp
130-- ENCODE
130-- ENCODE
131
131
132
132
133−encodeUtf8 :: [Stmt] -> Builder
133+encodeUtf8 :: Stmt -> Builder
134encodeUtf8 stmts =
134encodeUtf8 stmts =
135− fromStmtBlock "" stmts
135+ fromStmt "" stmts
136
136
137
137
138
138
src/Generate/JavaScript/BuiltIn.hs+70−42
@@ -1,58 +1,74 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.BuiltIn
3module Generate.JavaScript.BuiltIn
4− ( character
4+ ( char
5− , list, cons
5+ , list
6+ , cons
6 , recordUpdate
7 , recordUpdate
8+ , eq
7− , eq, cmp
9+ , cmp
10+ , effectManagers
11+ , effect
8− , effect, outgoingPort, incomingPort
12+ , outgoingPort
13+ , incomingPort
14+ , staticProgram
9 , crash
15 , crash
10 )
16 )
11 where
17 where
12
18
19+
13import Data.Text (Text)
20import Data.Text (Text)
14
21
15import qualified AST.Module.Name as ModuleName
22import qualified AST.Module.Name as ModuleName
23+import qualified AST.Variable as Var
16import qualified Generate.JavaScript.Builder as JS
24import qualified Generate.JavaScript.Builder as JS
17import Generate.JavaScript.Helpers ((<|), (==>))
25import Generate.JavaScript.Helpers ((<|), (==>))
18import qualified Generate.JavaScript.Variable as Var
26import qualified Generate.JavaScript.Variable as Var
27+import Generate.JavaScript.Variable (Generator)
19import qualified Reporting.Region as R
28import qualified Reporting.Region as R
20
29
21
30
22
31
23−utils :: Text -> [JS.Expr] -> JS.Expr
32+-- LITERALS
24−utils func args =
33+
25− JS.Call (Var.coreNative "Utils" func) args
26
34
35+char :: Text -> Generator JS.Expr
36+char c =
37+ utils "chr" [ JS.String c ]
27
38
28
39
29−-- LITERALS
40+utils :: Text -> [JS.Expr] -> Generator JS.Expr
41+utils name args =
42+ do func <- core "Native.Utils" name
43+ return $ JS.Call func args
30
44
31
45
32−character :: Text -> JS.Expr
46+core :: ModuleName.Raw -> Text -> Generator JS.Expr
33−character char =
47+core home name =
34− utils "chr" [ JS.String char ]
48+ Var.global (Var.Global (ModuleName.inCore home) name)
35
49
36
50
37
51
38-- LISTS
52-- LISTS
39
53
40
54
41−list :: [JS.Expr] -> JS.Expr
55+list :: [JS.Expr] -> Generator JS.Expr
42list elements =
56list elements =
57+ do fromArray <- core "Native.List" "fromArray"
43− Var.coreNative "List" "fromArray" <| JS.Array elements
58+ return $ fromArray <| JS.Array elements
44
59
45
60
46−cons :: JS.Expr -> JS.Expr -> JS.Expr
61+cons :: JS.Expr -> JS.Expr -> Generator JS.Expr
47−cons front back =
62+cons first rest =
48− JS.Call (Var.coreNative "List" "Cons") [front, back]
63+ do func <- core "Native.List" "Cons"
64+ return $ JS.Call func [first, rest]
49
65
50
66
51
67
52-- RECORDS
68-- RECORDS
53
69
54
70
55−recordUpdate :: JS.Expr -> [(Text, JS.Expr)] -> JS.Expr
71+recordUpdate :: JS.Expr -> [(Text, JS.Expr)] -> Generator JS.Expr
56recordUpdate record fields =
72recordUpdate record fields =
57 utils "update"
73 utils "update"
58 [ record
74 [ record
@@ -64,12 +80,12 @@ recordUpdate record fields =
64-- COMPARISIONS
80-- COMPARISIONS
65
81
66
82
67−eq :: JS.Expr -> JS.Expr -> JS.Expr
83+eq :: JS.Expr -> JS.Expr -> Generator JS.Expr
68eq left right =
84eq left right =
69 utils "eq" [ left, right ]
85 utils "eq" [ left, right ]
70
86
71
87
72−cmp :: JS.Expr -> JS.Expr -> JS.Expr
88+cmp :: JS.Expr -> JS.Expr -> Generator JS.Expr
73cmp left right =
89cmp left right =
74 utils "cmp" [ left, right ]
90 utils "cmp" [ left, right ]
75
91
@@ -78,55 +94,67 @@ cmp left right =
78-- EFFECTS
94-- EFFECTS
79
95
80
96
97+effectManagers :: Generator JS.Expr
98+effectManagers =
99+ core "Native.Platform" "effectManagers"
100+
101+
81−effect :: ModuleName.Canonical -> JS.Expr
102+effect :: ModuleName.Canonical -> Generator JS.Expr
82effect effectName =
103effect effectName =
83− Var.coreNative "Platform" "leaf" <|
104+ do leaf <- core "Native.Platform" "leaf"
84− JS.String (ModuleName.canonicalToText effectName)
105+ return $ leaf <| JS.String (ModuleName.canonicalToText effectName)
85
106
86
107
87−outgoingPort :: Text -> JS.Expr -> JS.Expr
108+outgoingPort :: Text -> JS.Expr -> Generator JS.Expr
88outgoingPort name converter =
109outgoingPort name converter =
89− JS.Call
90− (Var.coreNative "Platform" "outgoingPort")
110+ do outPort <- core "Native.Platform" "outgoingPort"
91− [ JS.String name, converter ]
111+ return $ JS.Call outPort [ JS.String name, converter ]
92
112
93
113
94−incomingPort :: Text -> JS.Expr -> JS.Expr
114+incomingPort :: Text -> JS.Expr -> Generator JS.Expr
95incomingPort name converter =
115incomingPort name converter =
96− JS.Call
97− (Var.coreNative "Platform" "incomingPort")
116+ do inPort <- core "Native.Platform" "incomingPort"
98− [ JS.String name, converter ]
117+ return $ JS.Call inPort [ JS.String name, converter ]
118+
119+
120+
121+-- VIRTUAL DOM
122+
123+
124+staticProgram :: Generator JS.Expr
125+staticProgram =
126+ Var.global (Var.Global (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram")
99
127
100
128
101
129
102-- CRASH
130-- CRASH
103
131
104
132
105−crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expr) -> JS.Expr
133+crash :: ModuleName.Canonical -> R.Region -> Maybe (JS.Expr) -> Generator JS.Expr
106crash home region maybeCaseCrashValue =
134crash home region maybeCaseCrashValue =
107 let
135 let
108 homeString =
136 homeString =
109 JS.String (ModuleName.canonicalToText home)
137 JS.String (ModuleName.canonicalToText home)
110 in
138 in
111− case maybeCaseCrashValue of
139+ case maybeCaseCrashValue of
112− Nothing ->
140+ Nothing ->
113 utils "crash" [ homeString, regionToJs region ]
141 utils "crash" [ homeString, regionToJs region ]
114
142
115− Just crashValue ->
143+ Just crashValue ->
116 utils "crashCase" [ homeString, regionToJs region, crashValue ]
144 utils "crashCase" [ homeString, regionToJs region, crashValue ]
117
145
118
146
119regionToJs :: R.Region -> JS.Expr
147regionToJs :: R.Region -> JS.Expr
120regionToJs (R.Region start end) =
148regionToJs (R.Region start end) =
121− JS.Object
149+ JS.Object
122− [ "start" ==> positionToJs start
150+ [ "start" ==> positionToJs start
123− , "end" ==> positionToJs end
151+ , "end" ==> positionToJs end
124− ]
152+ ]
125
153
126
154
127positionToJs :: R.Position -> JS.Expr
155positionToJs :: R.Position -> JS.Expr
128positionToJs (R.Position line column) =
156positionToJs (R.Position line column) =
129− JS.Object
157+ JS.Object
130− [ "line" ==> JS.Int line
158+ [ "line" ==> JS.Int line
131− , "column" ==> JS.Int column
159+ , "column" ==> JS.Int column
132− ]
160+ ]
src/Generate/JavaScript/Effects.hsnew file+82
@@ -0,0 +1,82 @@
1+{-# OPTIONS_GHC -Wall #-}
2+{-# LANGUAGE OverloadedStrings #-}
3+module Generate.JavaScript.Effects
4+ ( generate
5+ )
6+ where
7+
8+
9+import qualified Data.ByteString.Builder as BS
10+import qualified Data.Map as Map
11+import Data.Monoid ((<>))
12+import Data.Text (Text)
13+
14+import qualified AST.Effects as Effects
15+import qualified AST.Module.Name as ModuleName
16+import qualified AST.Variable as Var
17+import qualified Elm.Package as Pkg
18+import qualified Generate.JavaScript.Builder as JS
19+import qualified Generate.JavaScript.BuiltIn as BuiltIn
20+import qualified Generate.JavaScript.Variable as Var
21+
22+
23+
24+-- GENERATE
25+
26+
27+generate :: Map.Map ModuleName.Canonical Effects.ManagerType -> Var.Generator BS.Builder
28+generate managers =
29+ let
30+ add home mngr makeBuilder =
31+ do builder <- makeBuilder
32+ stmt <- generateManager home mngr
33+ return (JS.encodeUtf8 stmt <> builder)
34+ in
35+ Map.foldrWithKey' add (return "") managers
36+
37+
38+generateManager :: ModuleName.Canonical -> Effects.ManagerType -> Var.Generator JS.Stmt
39+generateManager home manager =
40+ do managers <- BuiltIn.effectManagers
41+ let managerName = JS.String (ModuleName.canonicalToText home)
42+ let lValue = JS.LBracket managers managerName
43+ entries <- generateEntries home manager
44+ return $ JS.ExprStmt (JS.Assign lValue entries)
45+
46+
47+generateEntries :: ModuleName.Canonical -> Effects.ManagerType -> Var.Generator JS.Expr
48+generateEntries home@(ModuleName.Canonical pkg _) manager =
49+ let
50+ entry name =
51+ do let key = JS.IdProp (JS.Id name)
52+ value <- Var.global (Var.Global home name)
53+ return ( key, value )
54+ in
55+ fmap JS.Object $ sequence $
56+ [ "pkg" ==> Pkg.toText pkg
57+ , entry "init"
58+ , entry "onEffects"
59+ , entry "onSelfMsg"
60+ ]
61+ ++
62+ case manager of
63+ Effects.Cmds ->
64+ [ "tag" ==> "cmd"
65+ , entry "cmdMap"
66+ ]
67+
68+ Effects.Subs ->
69+ [ "tag" ==> "sub"
70+ , entry "subMap"
71+ ]
72+
73+ Effects.Both ->
74+ [ "tag" ==> "fx"
75+ , entry "cmdMap"
76+ , entry "subMap"
77+ ]
78+
79+
80+(==>) :: Text -> Text -> Var.Generator ( JS.Prop, JS.Expr )
81+(==>) key value =
82+ return ( JS.IdProp (JS.Id key), JS.String value )
src/Generate/JavaScript/Expression.hs+89−77
@@ -5,7 +5,7 @@ module Generate.JavaScript.Expression
5 where
5 where
6
6
7import Control.Arrow (second)
7import Control.Arrow (second)
8−import Control.Monad.State (State, foldM)
8+import Control.Monad (foldM)
9import qualified Data.List as List
9import qualified Data.List as List
10import qualified Data.Map as Map
10import qualified Data.Map as Map
11import Data.Monoid ((<>))
11import Data.Monoid ((<>))
@@ -23,6 +23,7 @@ import qualified Generate.JavaScript.BuiltIn as BuiltIn
23import qualified Generate.JavaScript.Foreign as Foreign
23import qualified Generate.JavaScript.Foreign as Foreign
24import qualified Generate.JavaScript.Literal as Literal
24import qualified Generate.JavaScript.Literal as Literal
25import qualified Generate.JavaScript.Variable as Var
25import qualified Generate.JavaScript.Variable as Var
26+import Generate.JavaScript.Variable (Generator)
26import qualified Optimize.DecisionTree as DT
27import qualified Optimize.DecisionTree as DT
27
28
28
29
@@ -30,9 +31,11 @@ import qualified Optimize.DecisionTree as DT
30-- GENERATE DECLARATION
31-- GENERATE DECLARATION
31
32
32
33
33−generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> State Int [JS.Stmt]
34+generateDecl :: ModuleName.Canonical -> Text -> Opt.Def -> Generator JS.Stmt
34generateDecl home name def =
35generateDecl home name def =
36+ do jsName <- Var.getGlobalName (V.Global home name)
35− Var.defineGlobal home name <$> generateDef name def
37+ jsBody <- generateDef name def
38+ return $ JS.VarDeclStmt [ Help.varDecl jsName jsBody ]
36
39
37
40
38
41
@@ -44,12 +47,12 @@ data Code
44 | JsBlock [JS.Stmt]
47 | JsBlock [JS.Stmt]
45
48
46
49
47−jsExpr :: JS.Expr -> State Int Code
50+jsExpr :: JS.Expr -> Generator Code
48jsExpr exp =
51jsExpr exp =
49 return (JsExpr exp)
52 return (JsExpr exp)
50
53
51
54
52−jsBlock :: [JS.Stmt] -> State Int Code
55+jsBlock :: [JS.Stmt] -> Generator Code
53jsBlock exp =
56jsBlock exp =
54 return (JsBlock exp)
57 return (JsBlock exp)
55
58
@@ -98,22 +101,22 @@ toExpr code =
98-- EXPRESSIONS
101-- EXPRESSIONS
99
102
100
103
101−generateJsExpr :: Opt.Expr -> State Int JS.Expr
104+generateJsExpr :: Opt.Expr -> Generator JS.Expr
102generateJsExpr optExpr =
105generateJsExpr optExpr =
103 toExpr <$> generateCode optExpr
106 toExpr <$> generateCode optExpr
104
107
105
108
106−generateCode :: Opt.Expr -> State Int Code
109+generateCode :: Opt.Expr -> Generator Code
107generateCode expr =
110generateCode expr =
108 case expr of
111 case expr of
109 VarLocal name ->
112 VarLocal name ->
110 jsExpr $ Var.local name
113 jsExpr $ Var.local name
111
114
112 VarGlobal name ->
115 VarGlobal name ->
113− jsExpr $ Var.global name
116+ JsExpr <$> Var.global name
114
117
115 Literal lit ->
118 Literal lit ->
116− jsExpr (Literal.literal lit)
119+ JsExpr <$> Literal.literal lit
117
120
118 Access record field ->
121 Access record field ->
119 do jsRecord <- generateJsExpr record
122 do jsRecord <- generateJsExpr record
@@ -127,7 +130,7 @@ generateCode expr =
127 in
130 in
128 do jsRecord <- generateJsExpr record
131 do jsRecord <- generateJsExpr record
129 jsFields <- mapM fieldToJs fields
132 jsFields <- mapM fieldToJs fields
130− jsExpr $ BuiltIn.recordUpdate jsRecord jsFields
133+ JsExpr <$> BuiltIn.recordUpdate jsRecord jsFields
131
134
132 Record fields ->
135 Record fields ->
133 let
136 let
@@ -173,7 +176,7 @@ generateCode expr =
173
176
174 List elements ->
177 List elements ->
175 do jsElements <- mapM generateJsExpr elements
178 do jsElements <- mapM generateJsExpr elements
176− jsExpr $ BuiltIn.list jsElements
179+ JsExpr <$> BuiltIn.list jsElements
177
180
178 Ctor tag members ->
181 Ctor tag members ->
179 let
182 let
@@ -191,39 +194,41 @@ generateCode expr =
191 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
194 jsExpr $ JS.DotRef jsDataExpr (JS.Id ("_" <> Text.pack (show index)))
192
195
193 Cmd moduleName _ ->
196 Cmd moduleName _ ->
194− jsExpr $ BuiltIn.effect moduleName
197+ JsExpr <$> BuiltIn.effect moduleName
195
198
196 Sub moduleName _ ->
199 Sub moduleName _ ->
197− jsExpr $ BuiltIn.effect moduleName
200+ JsExpr <$> BuiltIn.effect moduleName
198
201
199 OutgoingPort name tipe ->
202 OutgoingPort name tipe ->
200− jsExpr $ BuiltIn.outgoingPort name (Foreign.encode tipe)
203+ JsExpr <$> BuiltIn.outgoingPort name (Foreign.encode tipe)
201
204
202 IncomingPort name tipe ->
205 IncomingPort name tipe ->
203 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
206 do jsDecoder <- generateJsExpr (Foreign.decode tipe)
204− jsExpr $ BuiltIn.incomingPort name jsDecoder
207+ JsExpr <$> BuiltIn.incomingPort name jsDecoder
205
208
206 Program kind body ->
209 Program kind body ->
207 generateProgram kind body
210 generateProgram kind body
208
211
209 GLShader src ->
212 GLShader src ->
213+ do string <- Literal.literal (L.Str src)
210− jsExpr $ JS.Object [(JS.StringProp "src", Literal.literal (L.Str src))]
214+ jsExpr $ JS.Object [(JS.StringProp "src", string)]
211
215
212 Crash home region maybeBranchProblem ->
216 Crash home region maybeBranchProblem ->
213 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
217 do maybeOptBranchProblem <- traverse generateJsExpr maybeBranchProblem
214− jsExpr $ BuiltIn.crash home region maybeOptBranchProblem
218+ JsExpr <$> BuiltIn.crash home region maybeOptBranchProblem
215
219
216
220
217
221
218-- PROGRAMS
222-- PROGRAMS
219
223
220
224
221−generateProgram :: Can.Main -> Opt.Expr -> State Int Code
225+generateProgram :: Can.Main -> Opt.Expr -> Generator Code
222generateProgram kind body =
226generateProgram kind body =
223 case kind of
227 case kind of
224 Can.VDom ->
228 Can.VDom ->
225 do html <- generateJsExpr body
229 do html <- generateJsExpr body
226− jsExpr (Var.staticProgram <| html)
230+ func <- BuiltIn.staticProgram
231+ jsExpr (func <| html)
227
232
228 Can.NoFlags ->
233 Can.NoFlags ->
229 do almostProgram <- generateJsExpr body
234 do almostProgram <- generateJsExpr body
@@ -239,13 +244,13 @@ generateProgram kind body =
239-- DEFINITIONS
244-- DEFINITIONS
240
245
241
246
242−generateLetDef :: (Text, Opt.Def) -> State Int JS.Stmt
247+generateLetDef :: (Text, Opt.Def) -> Generator JS.Stmt
243generateLetDef (name, def) =
248generateLetDef (name, def) =
244 do jsBody <- generateDef name def
249 do jsBody <- generateDef name def
245 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
250 return $ JS.VarDeclStmt [ Help.varDecl name jsBody ]
246
251
247
252
248−generateDef :: Text -> Opt.Def -> State Int JS.Expr
253+generateDef :: Text -> Opt.Def -> Generator JS.Expr
249generateDef name def =
254generateDef name def =
250 case def of
255 case def of
251 Opt.TailDef argNames body ->
256 Opt.TailDef argNames body ->
@@ -255,7 +260,7 @@ generateDef name def =
255 generateJsExpr body
260 generateJsExpr body
256
261
257
262
258−generateTailFunction :: Text -> [Text] -> Opt.Expr -> State Int JS.Expr
263+generateTailFunction :: Text -> [Text] -> Opt.Expr -> Generator JS.Expr
259generateTailFunction name args body =
264generateTailFunction name args body =
260 do code <- generateCode body
265 do code <- generateCode body
261 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
266 return $ generateFunctionWithArity args $ JsBlock $ (:[]) $
@@ -268,7 +273,7 @@ generateTailFunction name args body =
268-- FUNCTIONS
273-- FUNCTIONS
269
274
270
275
271−generateFunction :: [Text] -> Opt.Expr -> State Int Code
276+generateFunction :: [Text] -> Opt.Expr -> Generator Code
272generateFunction args body =
277generateFunction args body =
273 do code <- generateCode body
278 do code <- generateCode body
274 jsExpr (generateFunctionWithArity args code)
279 jsExpr (generateFunctionWithArity args code)
@@ -297,7 +302,7 @@ generateFunctionWithArity rawArgs code =
297-- GENERATE CALL
302-- GENERATE CALL
298
303
299
304
300−generateCall :: Opt.Expr -> [Opt.Expr] -> State Int Code
305+generateCall :: Opt.Expr -> [Opt.Expr] -> Generator Code
301generateCall func args =
306generateCall func args =
302 case (func, args) of
307 case (func, args) of
303 (Opt.VarGlobal (V.Global home name), [arg]) ->
308 (Opt.VarGlobal (V.Global home name), [arg]) ->
@@ -320,13 +325,13 @@ generateCall func args =
320 generateCallHelp func args
325 generateCallHelp func args
321
326
322
327
323−genPrefix :: JS.PrefixOp -> Opt.Expr -> State Int Code
328+genPrefix :: JS.PrefixOp -> Opt.Expr -> Generator Code
324genPrefix op arg =
329genPrefix op arg =
325 do jsArg <- generateJsExpr arg
330 do jsArg <- generateJsExpr arg
326 jsExpr (JS.Prefix op jsArg)
331 jsExpr (JS.Prefix op jsArg)
327
332
328
333
329−genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> State Int Code
334+genInfix :: JS.InfixOp -> Opt.Expr -> Opt.Expr -> Generator Code
330genInfix op left right =
335genInfix op left right =
331 do jsLeft <- generateJsExpr left
336 do jsLeft <- generateJsExpr left
332 jsRight <- generateJsExpr right
337 jsRight <- generateJsExpr right
@@ -343,7 +348,7 @@ bitwise =
343 ModuleName.inCore "Bitwise"
348 ModuleName.inCore "Bitwise"
344
349
345
350
346−generateCallHelp :: Opt.Expr -> [Opt.Expr] -> State Int Code
351+generateCallHelp :: Opt.Expr -> [Opt.Expr] -> Generator Code
347generateCallHelp func args =
352generateCallHelp func args =
348 let
353 let
349 arity = length args
354 arity = length args
@@ -362,7 +367,7 @@ generateCallHelp func args =
362-- GENERATE IFS
367-- GENERATE IFS
363
368
364
369
365−generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> State Int Code
370+generateIf :: [(Opt.Expr, Opt.Expr)] -> Opt.Expr -> Generator Code
366generateIf givenBranches givenFinally =
371generateIf givenBranches givenFinally =
367 let
372 let
368 (branches, finally) =
373 (branches, finally) =
@@ -421,7 +426,7 @@ crushIfsHelp visitedBranches unvisitedBranches finally =
421-- CASE EXPRESSIONS
426-- CASE EXPRESSIONS
422
427
423
428
424−generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> State Int [JS.Stmt]
429+generateCase :: Text -> Opt.Decider Opt.Choice -> [(Int, Opt.Expr)] -> Generator [JS.Stmt]
425generateCase exprName decider jumps =
430generateCase exprName decider jumps =
426 do labelRoot <- Var.fresh
431 do labelRoot <- Var.fresh
427 decider <- generateDecider exprName labelRoot decider
432 decider <- generateDecider exprName labelRoot decider
@@ -432,7 +437,7 @@ generateCase exprName decider jumps =
432-- handle any jumps
437-- handle any jumps
433
438
434
439
435−goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> State Int [JS.Stmt]
440+goto :: Text -> [JS.Stmt] -> (Int, Opt.Expr) -> Generator [JS.Stmt]
436goto labelRoot deciderStmts (target, branch) =
441goto labelRoot deciderStmts (target, branch) =
437 let
442 let
438 labeledDeciderStmt =
443 labeledDeciderStmt =
@@ -453,7 +458,7 @@ toLabel root target =
453-- turn deciders into ifs and switches
458-- turn deciders into ifs and switches
454
459
455
460
456−generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> State Int [JS.Stmt]
461+generateDecider :: Text -> Text -> Opt.Decider Opt.Choice -> Generator [JS.Stmt]
457generateDecider exprName labelRoot decisionTree =
462generateDecider exprName labelRoot decisionTree =
458 case decisionTree of
463 case decisionTree of
459 Opt.Leaf (Opt.Inline branch) ->
464 Opt.Leaf (Opt.Inline branch) ->
@@ -466,7 +471,7 @@ generateDecider exprName labelRoot decisionTree =
466 let
471 let
467 makeTest (path, test) =
472 makeTest (path, test) =
468 do testExpr <- pathToTestableExpr exprName path test
473 do testExpr <- pathToTestableExpr exprName path test
469− return (JS.Infix JS.OpStrictEq testExpr (testToExpr test))
474+ JS.Infix JS.OpStrictEq testExpr <$> testToExpr test
470 in
475 in
471 do testExprs <- mapM makeTest testChain
476 do testExprs <- mapM makeTest testChain
472 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
477 let cond = List.foldl1' (JS.Infix JS.OpLAnd) testExprs
@@ -481,29 +486,31 @@ generateDecider exprName labelRoot decisionTree =
481 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
486 return [ JS.Switch testExpr (caseClauses ++ [caseDefault]) ]
482
487
483
488
484−edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> State Int JS.Case
489+edgeToCase :: Text -> Text -> (DT.Test, Opt.Decider Opt.Choice) -> Generator JS.Case
485edgeToCase exprName labelRoot (test, subTree) =
490edgeToCase exprName labelRoot (test, subTree) =
491+ JS.Case
492+ <$> testToExpr test
486− JS.Case (testToExpr test) <$> generateDecider exprName labelRoot subTree
493+ <*> generateDecider exprName labelRoot subTree
487
494
488
495
489−testToExpr :: DT.Test -> JS.Expr
496+testToExpr :: DT.Test -> Generator JS.Expr
490testToExpr test =
497testToExpr test =
491 case test of
498 case test of
492 DT.Constructor (V.Canonical _ tag) ->
499 DT.Constructor (V.Canonical _ tag) ->
493− JS.String tag
500+ return $ JS.String tag
494
501
495 DT.Literal (L.Chr char) ->
502 DT.Literal (L.Chr char) ->
496− JS.String char
503+ return $ JS.String char
497
504
498 DT.Literal lit ->
505 DT.Literal lit ->
499− Literal.literal lit
506+ Literal.literal lit
500
507
501
508
502
509
503-- work with paths
510-- work with paths
504
511
505
512
506−pathToTestableExpr :: Text -> DT.Path -> DT.Test -> State Int JS.Expr
513+pathToTestableExpr :: Text -> DT.Path -> DT.Test -> Generator JS.Expr
507pathToTestableExpr root path exampleTest =
514pathToTestableExpr root path exampleTest =
508 do accessExpr <- generateJsExpr (pathToExpr root path)
515 do accessExpr <- generateJsExpr (pathToExpr root path)
509 case exampleTest of
516 case exampleTest of
@@ -540,31 +547,32 @@ pathToExpr root fullPath =
540-- BINARY OPERATORS
547-- BINARY OPERATORS
541
548
542
549
543−generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> State Int Code
550+generateBinop :: V.Global -> Opt.Expr -> Opt.Expr -> Generator Code
544generateBinop op left right =
551generateBinop op left right =
545 do jsLeft <- generateJsExpr left
552 do jsLeft <- generateJsExpr left
546 jsRight <- generateJsExpr right
553 jsRight <- generateJsExpr right
547− jsExpr (generateBinopHelp op jsLeft jsRight)
554+ JsExpr <$> generateBinopHelp op jsLeft jsRight
548
555
549
556
550
557
551-- BINARY OPERATOR HELPERS
558-- BINARY OPERATOR HELPERS
552
559
553
560
554−generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> JS.Expr
561+generateBinopHelp :: V.Global -> JS.Expr -> JS.Expr -> Generator JS.Expr
555−generateBinopHelp var@(V.Global home op) leftExpr rightExpr =
562+generateBinopHelp var@(V.Global home op) jsLeft jsRight =
556 let
563 let
557 simpleMake left right =
564 simpleMake left right =
565+ do func <- Var.global var
558− JS.Call (ref "A2") [ Var.global var, left, right ]
566+ return $ JS.Call (ref "A2") [ func, left, right ]
559 in
567 in
560 if home == basics then
568 if home == basics then
561− (Map.findWithDefault simpleMake op basicOps) leftExpr rightExpr
569+ (Map.findWithDefault simpleMake op basicsOps) jsLeft jsRight
562
570
563 else if op == "::" && home == list then
571 else if op == "::" && home == list then
564− BuiltIn.cons leftExpr rightExpr
572+ BuiltIn.cons jsLeft jsRight
565
573
566 else
574 else
567− simpleMake leftExpr rightExpr
575+ simpleMake jsLeft jsRight
568
576
569
577
570list :: ModuleName.Canonical
578list :: ModuleName.Canonical
@@ -572,39 +580,43 @@ list =
572 ModuleName.inCore "List"
580 ModuleName.inCore "List"
573
581
574
582
575−basicOps :: Map.Map Text (JS.Expr -> JS.Expr -> JS.Expr)
583+basicsOps :: Map.Map Text (JS.Expr -> JS.Expr -> Generator JS.Expr)
576−basicOps =
584+basicsOps =
577− Map.fromList (infixOps ++ specialOps)
585+ Map.fromList (basicsOpsNormal ++ basicsOpsSpecial)
578
586
579
587
580−infixOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
588+basicsOpsNormal :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
581−infixOps =
589+basicsOpsNormal =
582− let
590+ let
583− infixOp str op =
591+ (=*>) str op =
584− (str, JS.Infix op)
592+ ( str, \left right -> return (JS.Infix op left right) )
585− in
593+ in
586− [ infixOp "+" JS.OpAdd
594+ [ "+" =*> JS.OpAdd
587− , infixOp "-" JS.OpSub
595+ , "-" =*> JS.OpSub
588− , infixOp "*" JS.OpMul
596+ , "*" =*> JS.OpMul
589− , infixOp "/" JS.OpDiv
597+ , "/" =*> JS.OpDiv
590− , infixOp "&&" JS.OpLAnd
598+ , "&&" =*> JS.OpLAnd
591− , infixOp "||" JS.OpLOr
599+ , "||" =*> JS.OpLOr
592− ]
600+ ]
593−
601+
594−
602+
595−specialOps :: [(Text, JS.Expr -> JS.Expr -> JS.Expr)]
603+basicsOpsSpecial :: [(Text, JS.Expr -> JS.Expr -> Generator JS.Expr)]
596−specialOps =
604+basicsOpsSpecial =
605+ let
606+ (=*>) = (,)
607+ in
597− [ (,) "^" $ \a b -> JS.Call (obj ["Math","pow"]) [a,b]
608+ [ "^" =*> \a b -> return $ JS.Call (obj ["Math","pow"]) [a,b]
598− , (,) "==" $ \a b -> BuiltIn.eq a b
609+ , "==" =*> BuiltIn.eq
599− , (,) "/=" $ \a b -> JS.Prefix JS.PrefixLNot (BuiltIn.eq a b)
610+ , "/=" =*> \a b -> JS.Prefix JS.PrefixLNot <$> BuiltIn.eq a b
600− , (,) "<" $ cmp JS.OpLT 0
611+ , "<" =*> cmp JS.OpLT 0
601− , (,) ">" $ cmp JS.OpGT 0
612+ , ">" =*> cmp JS.OpGT 0
602− , (,) "<=" $ cmp JS.OpLT 1
613+ , "<=" =*> cmp JS.OpLT 1
603− , (,) ">=" $ cmp JS.OpGT (-1)
614+ , ">=" =*> cmp JS.OpGT (-1)
604− , (,) "//" $ \a b -> JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
615+ , "//" =*> \a b -> return $ JS.Infix JS.OpBOr (JS.Infix JS.OpDiv a b) (JS.Int 0)
605 ]
616 ]
606
617
607
618
608−cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> JS.Expr
619+cmp :: JS.InfixOp -> Int -> JS.Expr -> JS.Expr -> Generator JS.Expr
609cmp op n a b =
620cmp op n a b =
610− JS.Infix op (BuiltIn.cmp a b) (JS.Int n)
621+ do ordering <- BuiltIn.cmp a b
622+ return $ JS.Infix op ordering (JS.Int n)
src/Generate/JavaScript/Foreign.hs+2−3
@@ -14,7 +14,6 @@ import qualified AST.Type as T
14import qualified AST.Variable as Var
14import qualified AST.Variable as Var
15import qualified Generate.JavaScript.Builder as JS
15import qualified Generate.JavaScript.Builder as JS
16import qualified Generate.JavaScript.Helpers as JS (function, ref)
16import qualified Generate.JavaScript.Helpers as JS (function, ref)
17−import qualified Generate.JavaScript.Variable as Var
18import Generate.JavaScript.Helpers ((<|), (==>))
17import Generate.JavaScript.Helpers ((<|), (==>))
19
18
20
19
@@ -83,7 +82,7 @@ fromList :: T.Canonical -> JS.Expr -> JS.Expr
83fromList tipe expr =
82fromList tipe expr =
84 let
83 let
85 array =
84 array =
86− Var.coreNative "List" "toArray" <| expr
85+ error "TODO port fromList" expr -- Var.coreNative "List" "toArray" <| expr
87 in
86 in
88 JS.DotRef array (JS.Id "map") <| encode tipe
87 JS.DotRef array (JS.Id "map") <| encode tipe
89
88
@@ -92,7 +91,7 @@ fromArray :: T.Canonical -> JS.Expr -> JS.Expr
92fromArray tipe expr =
91fromArray tipe expr =
93 let
92 let
94 array =
93 array =
95− Var.coreNative "Array" "toJSArray" <| expr
94+ error "TODO port fromArray" expr -- Var.coreNative "Array" "toJSArray" <| expr
96 in
95 in
97 JS.DotRef array (JS.Id "map") <| encode tipe
96 JS.DotRef array (JS.Id "map") <| encode tipe
98
97
src/Generate/JavaScript/Literal.hs+7−6
@@ -3,22 +3,23 @@ module Generate.JavaScript.Literal (literal) where
3import qualified AST.Literal as Lit
3import qualified AST.Literal as Lit
4import qualified Generate.JavaScript.Builder as JS
4import qualified Generate.JavaScript.Builder as JS
5import qualified Generate.JavaScript.BuiltIn as BuiltIn
5import qualified Generate.JavaScript.BuiltIn as BuiltIn
6+import Generate.JavaScript.Variable (Generator)
6
7
7
8
8−literal :: Lit.Literal -> JS.Expr
9+literal :: Lit.Literal -> Generator JS.Expr
9literal lit =
10literal lit =
10 case lit of
11 case lit of
11 Lit.Chr char ->
12 Lit.Chr char ->
12− BuiltIn.character char
13+ BuiltIn.char char
13
14
14 Lit.Str string ->
15 Lit.Str string ->
15− JS.String string
16+ return $ JS.String string
16
17
17 Lit.IntNum number ->
18 Lit.IntNum number ->
18− JS.Int number
19+ return $ JS.Int number
19
20
20 Lit.FloatNum number ->
21 Lit.FloatNum number ->
21− JS.Float number
22+ return $ JS.Float number
22
23
23 Lit.Boolean boolean ->
24 Lit.Boolean boolean ->
24− JS.Bool boolean
25+ return $ JS.Bool boolean
src/Generate/JavaScript/Variable.hs+143−85
@@ -1,44 +1,80 @@
1{-# OPTIONS_GHC -Wall #-}
1{-# OPTIONS_GHC -Wall #-}
2{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE OverloadedStrings #-}
3module Generate.JavaScript.Variable
3module Generate.JavaScript.Variable
4+ ( Generator
5+ , run
6+ , Table
7+ , init
4− ( fresh
8+ , fresh
5− , local
9+ , local
6− , global
7− , qualified
8− , coreNative
9− , staticProgram
10− , defineGlobal
11− , safe
10+ , safe
11+ , global
12+ , getGlobalName
12− )
13+ )
13− where
14+ where
14−
15+
16+
17+import Prelude hiding (init)
15import qualified Control.Monad.State as State
18import qualified Control.Monad.State as State
19+import qualified Data.Char as Char
16−import Data.Monoid
20+import Data.Monoid ((<>))
21+import qualified Data.Map as Map
17import qualified Data.Set as Set
22import qualified Data.Set as Set
18import qualified Data.Text as Text
23import qualified Data.Text as Text
19import Data.Text (Text)
24import Data.Text (Text)
25+import Data.Word (Word16, Word32)
20
26
21import qualified AST.Helpers as Help
27import qualified AST.Helpers as Help
22import qualified AST.Module.Name as ModuleName
28import qualified AST.Module.Name as ModuleName
23import qualified AST.Variable as Var
29import qualified AST.Variable as Var
24import qualified Elm.Package as Pkg
30import qualified Elm.Package as Pkg
31+import qualified Elm.Compiler.Objects.Internal as Obj
25import qualified Generate.JavaScript.Builder as JS
32import qualified Generate.JavaScript.Builder as JS
26import qualified Generate.JavaScript.Helpers as JS
33import qualified Generate.JavaScript.Helpers as JS
27
34
28
35
29
36
37+-- GENERATOR
38+
39+
40+type Generator = State.State Table
41+
42+
43+run :: Table -> Generator a -> ( a, Table )
44+run table generator =
45+ State.runState generator table
46+
47+
48+
49+-- STATE
50+
51+
52+data Table =
53+ Table
54+ { _uid :: !Int
55+ , _names :: Map.Map Var.Global Text
56+ , _symbols :: Obj.SymbolTable
57+ }
58+
59+
60+init :: Obj.SymbolTable -> Table
61+init symbols =
62+ Table 0 Map.empty symbols
63+
64+
65+
30-- FRESH NAMES
66-- FRESH NAMES
31
67
32
68
33−fresh :: State.State Int Text
69+fresh :: Generator Text
34fresh =
70fresh =
35− do n <- State.get
71+ do (Table uid names symbols) <- State.get
36− State.modify (+1)
72+ State.put (Table (uid + 1) names symbols)
37− return (Text.pack ("_v" ++ show n))
73+ return (Text.pack ("_v" ++ show uid))
38
74
39
75
40
76
41−-- VARIABLES
77+-- LOCAL NAMES
42
78
43
79
44local :: Text -> JS.Expr
80local :: Text -> JS.Expr
@@ -46,103 +82,125 @@ local name =
46 JS.ref (safe name)
82 JS.ref (safe name)
47
83
48
84
49−global :: Var.Global -> JS.Expr
85+safe :: Text -> Text
50−global (Var.Global home name) =
86+safe name =
51− if Help.isOp name then
87+ if Set.member name reservedWords then
52− JS.BracketRef (JS.ref (opsDict home)) (JS.String name)
88+ "_" <> name
53 else
89 else
54− JS.ref (qualified home name)
90+ name
55
91
56
92
93+reservedWords :: Set.Set Text
94+reservedWords =
95+ Set.fromList
96+ -- reserved by JavaScript
97+ [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
98+ , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
99+ , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
100+ , "transient", "synchronized", "function", "break", "case", "catch"
101+ , "continue", "debugger", "default", "delete", "do", "else", "finally"
102+ , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
103+ , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
104+ , "const", "enum", "export", "extends", "import", "super", "implements"
105+ , "interface", "let", "package", "private", "protected", "public"
106+ , "static", "yield"
107+ -- reserved by Elm
108+ , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
109+ , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
110+ , "ctor"
111+ ]
57
112
58−-- MISC
59
113
60
114
61−coreNative :: Text -> Text -> JS.Expr
115+-- GLOBAL NAMES
62−coreNative moduleName name =
63− global (Var.Global (ModuleName.inCore ("Native." <> moduleName)) name)
64
116
65
117
66−staticProgram :: JS.Expr
118+global :: Var.Global -> Generator JS.Expr
67−staticProgram =
119+global var =
68− global (Var.Global (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram")
120+ do table@(Table _ _ symbols) <- State.get
121+ case Obj.lookup var symbols of
122+ Nothing ->
123+ JS.ref <$> getGlobalNameHelp var table
69
124
125+ Just (Obj.Symbol symHome symName) ->
126+ return $
127+ JS.DotRef
128+ (JS.ref (symbolHomeToText symHome))
129+ (JS.Id (symbolNameToText symName))
70
130
71
131
72−-- DEFINE GLOBALS
132+getGlobalName :: Var.Global -> Generator Text
133+getGlobalName var =
134+ do table <- State.get
135+ getGlobalNameHelp var table
73
136
74
137
75−defineGlobal :: ModuleName.Canonical -> Text -> JS.Expr -> [JS.Stmt]
138+getGlobalNameHelp :: Var.Global -> Table -> Generator Text
76−defineGlobal home name body =
139+getGlobalNameHelp var@(Var.Global home name) (Table uid names symbols) =
77− case Help.isOp name of
140+ case Map.lookup var names of
78− False ->
141+ Just jsName ->
79− [ JS.VarDeclStmt [ JS.varDecl (qualified home name) body ]
142+ return jsName
80− ]
81
143
82− True ->
144+ Nothing ->
83− let
145+ case Help.isOp name of
84− dict = opsDict home
146+ False ->
85− lvalue = JS.LBracket (JS.ref dict) (JS.String name)
147+ do let jsName = globalToName home name
86− in
148+ State.put (Table uid (Map.insert var jsName names) symbols)
87− [ JS.VarDeclStmt [ JS.varDecl dict (JS.refOrObject dict) ]
149+ return jsName
88− , JS.ExprStmt (JS.Assign lvalue body)
89− ]
90
150
151+ True ->
152+ do let jsName = globalToName home ("_op" <> Text.pack (show uid))
153+ State.put (Table (uid + 1) (Map.insert var jsName names) symbols)
154+ return jsName
91
155
92
156
93−-- GLOBAL NAMES
157+globalToName :: ModuleName.Canonical -> Text -> Text
158+globalToName (ModuleName.Canonical (Pkg.Name user project) moduleName) name =
159+ Text.replace "-" "_" user
160+ <> "$" <> Text.replace "-" "_" project
161+ <> "$" <> Text.replace "." "_" moduleName
162+ <> "$" <> name
94
163
95
164
96−qualified :: ModuleName.Canonical -> Text -> Text
97−qualified home name =
98− moduleToText home <> "$" <> name
99
165
166+-- SYMBOLS
100
167
101−opsDict :: ModuleName.Canonical -> Text
102−opsDict home =
103− moduleToText home <> "_ops"
104
168
169+symbolHomeToText :: Word16 -> Text
170+symbolHomeToText word =
171+ Text.pack ('$' : show word)
105
172
106−moduleToText :: ModuleName.Canonical -> Text
107−moduleToText (ModuleName.Canonical (Pkg.Name user project) moduleName) =
108− let
109− safeUser =
110− Text.replace "-" "_" user
111
173
112− safeProject =
174+symbolNameToText :: Word32 -> Text
113− Text.replace "-" "_" project
175+symbolNameToText word =
176+ Text.pack (makeName word "")
114
177
115− safeModuleName =
116− Text.replace "." "_" moduleName
117− in
118− "_" <> safeUser <> "$" <> safeProject <> "$" <> safeModuleName
119
178
179+makeName :: Word32 -> String -> String
180+makeName word str =
181+ if word < 26 then
182+ makeChar 97 word : str
120
183
184+ else if word < 52 then
185+ makeChar 65 (word - 26) : str
121
186
122−-- SAFE NAMES
187+ else
188+ let
189+ (next, leftover) =
190+ quotRem word 52
191+ in
192+ makeName next (makeInnerChar leftover : str)
123
193
124
194
125−safe :: Text -> Text
195+makeInnerChar :: Word32 -> Char
126−safe name =
196+makeInnerChar word =
127− if Set.member name jsReserveds then "_" <> name else name
197+ if word < 26 then
198+ makeChar 97 word
199+ else
200+ makeChar 65 (word - 26)
128
201
129
202
130−jsReserveds :: Set.Set Text
203+{-# INLINE makeChar #-}
131−jsReserveds =
204+makeChar :: Word32 -> Word32 -> Char
132− Set.fromList
205+makeChar root offset =
133− -- JS reserved words
206+ Char.chr (fromIntegral (root + offset))
134− [ "null", "undefined", "Nan", "Infinity", "true", "false", "eval"
135− , "arguments", "int", "byte", "char", "goto", "long", "final", "float"
136− , "short", "double", "native", "throws", "boolean", "abstract", "volatile"
137− , "transient", "synchronized", "function", "break", "case", "catch"
138− , "continue", "debugger", "default", "delete", "do", "else", "finally"
139− , "for", "function", "if", "in", "instanceof", "new", "return", "switch"
140− , "this", "throw", "try", "typeof", "var", "void", "while", "with", "class"
141− , "const", "enum", "export", "extends", "import", "super", "implements"
142− , "interface", "let", "package", "private", "protected", "public"
143− , "static", "yield"
144− -- reserved by the Elm runtime system
145− , "F2", "F3", "F4", "F5", "F6", "F7", "F8", "F9"
146− , "A2", "A3", "A4", "A5", "A6", "A7", "A8", "A9"
147− , "ctor"
148− ]