46bc422 · elk · git.iko.soy

git.iko.soy/elk

Make changes to support Elm.Kernel.* code and symbol tables

commit46bc4224c34587e60ad90d9e864099d3dbb26454 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 3 Apr 2017, 15:59 (10 years ago) parentceb9175

12 files changed+107−88

compare with master

unifiedsplit

src/AST/Module/Name.hs+13−8 src/AST/Variable.hs+11−11 src/Canonicalize/Setup.hs+1−1 src/Canonicalize/Variable.hs+1−1 src/Elm/Compiler/Objects.hs+3−1 src/Elm/Compiler/Objects/Internal.hs+10−4 src/Generate/JavaScript.hs+8−8 src/Generate/JavaScript/BuiltIn.hs+8−8 src/Generate/JavaScript/Expression.hs+2−1 src/Generate/JavaScript/Foreign.hs+30−30 src/Generate/JavaScript/Variable.hs+19−14 src/Type/Solve.hs+1−1

src/AST/Module/Name.hs+13−8

@@ -5,7 +5,7 @@ module AST.Module.Name

55 , Canonical(..)

66 , inVirtualDom, inCore, inHtml

77 , toString, toText, canonicalToText

8− , isNative, canonicalIsNative

8+ , isKernel, getKernel, canonicalIsKernel

99 )

1010 where

1111

@@ -71,17 +71,22 @@ canonicalToText (Canonical _ name) =

7171

7272

7373

74−-- IS NATIVE

74+-- IS KERNEL

7575

7676

77−isNative :: Raw -> Bool

78−isNative name =

79− Text.isPrefixOf "Native." name

77+isKernel :: Raw -> Bool

78+isKernel name =

79+ Text.isPrefixOf "Elm.Kernel." name

8080

8181

82−canonicalIsNative :: Canonical -> Bool

83−canonicalIsNative (Canonical _ name) =

84− isNative name

82+getKernel :: Raw -> Text

83+getKernel name =

84+ Text.drop 11 name

85+

86+

87+canonicalIsKernel :: Canonical -> Bool

88+canonicalIsKernel (Canonical _ name) =

89+ isKernel name

8590

8691

8792

src/AST/Variable.hs+11−11

@@ -8,7 +8,7 @@ module AST.Variable

88 , inCore, inHtml, cmd, sub

99 , isLocalHome, isCons

1010 , is, isJson, isMaybe, isArray, isTask, isList

11− , isNative, isTuple, isPrimitive, isPrim, isLocal

11+ , isKernel, isTuple, isPrimitive, isPrim, isLocal

1212 , rawToText, toText

1313 )

1414 where

@@ -157,23 +157,23 @@ isTask =

157157

158158

159159isList :: Canonical -> Bool

160−isList v =

161− v == Canonical BuiltIn "List"

160+isList var =

161+ var == Canonical BuiltIn "List"

162162

163163

164−isNative :: Canonical -> Bool

165−isNative v =

166− case v of

164+isKernel :: Canonical -> Bool

165+isKernel var =

166+ case var of

167167 Canonical (Module name) _ ->

168− ModuleName.canonicalIsNative name

168+ ModuleName.canonicalIsKernel name

169169

170170 _ ->

171171 False

172172

173173

174174isTuple :: Canonical -> Bool

175−isTuple v =

176− case v of

175+isTuple var =

176+ case var of

177177 Canonical BuiltIn name ->

178178 Help.isTuple name

179179

@@ -182,8 +182,8 @@ isTuple v =

182182

183183

184184isPrimitive :: Canonical -> Bool

185−isPrimitive v =

186− case v of

185+isPrimitive var =

186+ case var of

187187 Canonical BuiltIn name ->

188188 Set.member name primitiveSet

189189

src/Canonicalize/Setup.hs+1−1

@@ -80,7 +80,7 @@ importToPatches importDict allInterfaces (A.A region (rawImportName, method)) =

8080 in

8181 case maybeInterface of

8282 Nothing ->

83− if ModuleName.isNative rawImportName then

83+ if ModuleName.isKernel rawImportName then

8484 Result.ok []

8585

8686 else

src/Canonicalize/Variable.hs+1−1

@@ -52,7 +52,7 @@ logVar var =

5252variable :: R.Region -> Env.Env -> Text -> Result Var.Canonical

5353variable region env var =

5454 case toVarName var of

55− Right (name, varName) | ModuleName.isNative name ->

55+ Right (name, varName) | ModuleName.isKernel name ->

5656 let

5757 localPkg =

5858 ModuleName._package (Env._home env)

src/Elm/Compiler/Objects.hs+3−1

@@ -1,6 +1,8 @@

11{-# OPTIONS_GHC -Wall #-}

22module Elm.Compiler.Objects

3− ( Symbol(..)

3+ ( SymbolTable

4+ , symbolTable

5+ , Symbol(..)

46 , Graph

57 , union

68 , unions

src/Elm/Compiler/Objects/Internal.hs+10−4

@@ -6,6 +6,7 @@ module Elm.Compiler.Objects.Internal

66 , union

77 , unions

88 , SymbolTable

9+ , symbolTable

910 , Symbol(..)

1011 , lookup

1112 , Roots

@@ -65,6 +66,15 @@ destruct (Graph graph) =

6566-- SYMBOLS

6667

6768

69+newtype SymbolTable =

70+ SymbolTable (Map.Map Var.Global Symbol)

71+

72+

73+symbolTable :: Map.Map Var.Global Symbol -> SymbolTable

74+symbolTable =

75+ SymbolTable

76+

77+

6878data Symbol =

6979 Symbol

7080 { _home :: !Word16

@@ -72,10 +82,6 @@ data Symbol =

7282 }

7383

7484

75−newtype SymbolTable =

76− SymbolTable (Map.Map Var.Global Symbol)

77−

78−

7985lookup :: Var.Global -> SymbolTable -> Maybe Symbol

8086lookup var (SymbolTable symbols) =

8187 Map.lookup var symbols

src/Generate/JavaScript.hs+8−8

@@ -29,7 +29,7 @@ import qualified Generate.JavaScript.Variable as JS

2929generate :: Obj.SymbolTable -> Obj.Graph -> Obj.Roots -> (Set.Set ModuleName.Canonical, BS.Builder)

3030generate symbols (Obj.Graph graph) roots =

3131 let

32− (State builders _ natives effects table) =

32+ (State builders _ kernels effects table) =

3333 List.foldl' (crawl graph) (init symbols) (Obj.toGlobals roots)

3434

3535 managers =

@@ -38,7 +38,7 @@ generate symbols (Obj.Graph graph) roots =

3838 javascript =

3939 List.foldl' (\rest stmt -> JS.encodeUtf8 stmt <> rest) managers builders

4040 in

41− (natives, javascript)

41+ (kernels, javascript)

4242

4343

4444

@@ -49,7 +49,7 @@ data State =

4949 State

5050 { _stmts :: [JS.Stmt]

5151 , _seen :: Set.Set Var.Global

52− , _natives :: Set.Set ModuleName.Canonical

52+ , _kernels :: Set.Set ModuleName.Canonical

5353 , _effects :: Map.Map ModuleName.Canonical Effects.ManagerType

5454 , _table :: JS.Table

5555 }

@@ -68,7 +68,7 @@ type Graph = Map.Map Var.Global Opt.Decl

6868

6969

7070crawl :: Graph -> State -> Var.Global -> State

71−crawl graph state@(State js seen natives effects table) name@(Var.Global home _) =

71+crawl graph state@(State js seen kernels effects table) name@(Var.Global home _) =

7272 if Set.member name seen then

7373 state

7474

@@ -81,8 +81,8 @@ crawl graph state@(State js seen natives effects table) name@(Var.Global home _)

8181 crawlDecl graph name decl state

8282

8383 Nothing ->

84− if ModuleName.canonicalIsNative home then

85− State js seen (Set.insert home natives) effects table

84+ if ModuleName.canonicalIsKernel home then

85+ State js seen (Set.insert home kernels) effects table

8686 else

8787 error (crawlError name)

8888

@@ -93,7 +93,7 @@ crawlDecl graph var@(Var.Global home name) (Opt.Decl deps fx body) state =

9393 newState =

9494 state { _seen = Set.insert var (_seen state) }

9595

96− (State stmts seen natives effects table) =

96+ (State stmts seen kernels effects table) =

9797 Set.foldl' (crawl graph) newState deps

9898

9999 (stmt, newTable) =

@@ -102,7 +102,7 @@ crawlDecl graph var@(Var.Global home name) (Opt.Decl deps fx body) state =

102102 State

103103 { _stmts = stmt : stmts

104104 , _seen = seen

105− , _natives = natives

105+ , _kernels = kernels

106106 , _effects = maybe id (Map.insert home) fx effects

107107 , _table = newTable

108108 }

src/Generate/JavaScript/BuiltIn.hs+8−8

@@ -39,7 +39,7 @@ char c =

3939

4040utils :: Text -> [JS.Expr] -> Generator JS.Expr

4141utils name args =

42− do func <- core "Native.Utils" name

42+ do func <- core "Elm.Kernel.Utils" name

4343 return $ JS.Call func args

4444

4545

@@ -54,13 +54,13 @@ core home name =

5454

5555list :: [JS.Expr] -> Generator JS.Expr

5656list elements =

57− do fromArray <- core "Native.List" "fromArray"

57+ do fromArray <- core "Elm.Kernel.List" "fromArray"

5858 return $ fromArray <| JS.Array elements

5959

6060

6161cons :: JS.Expr -> JS.Expr -> Generator JS.Expr

6262cons first rest =

63− do func <- core "Native.List" "Cons"

63+ do func <- core "Elm.Kernel.List" "Cons"

6464 return $ JS.Call func [first, rest]

6565

6666

@@ -96,24 +96,24 @@ cmp left right =

9696

9797effectManagers :: Generator JS.Expr

9898effectManagers =

99− core "Native.Platform" "effectManagers"

99+ core "Elm.Kernel.Platform" "effectManagers"

100100

101101

102102effect :: ModuleName.Canonical -> Generator JS.Expr

103103effect effectName =

104− do leaf <- core "Native.Platform" "leaf"

104+ do leaf <- core "Elm.Kernel.Platform" "leaf"

105105 return $ leaf <| JS.String (ModuleName.canonicalToText effectName)

106106

107107

108108outgoingPort :: Text -> JS.Expr -> Generator JS.Expr

109109outgoingPort name converter =

110− do outPort <- core "Native.Platform" "outgoingPort"

110+ do outPort <- core "Elm.Kernel.Platform" "outgoingPort"

111111 return $ JS.Call outPort [ JS.String name, converter ]

112112

113113

114114incomingPort :: Text -> JS.Expr -> Generator JS.Expr

115115incomingPort name converter =

116− do inPort <- core "Native.Platform" "incomingPort"

116+ do inPort <- core "Elm.Kernel.Platform" "incomingPort"

117117 return $ JS.Call inPort [ JS.String name, converter ]

118118

119119

@@ -123,7 +123,7 @@ incomingPort name converter =

123123

124124staticProgram :: Generator JS.Expr

125125staticProgram =

126− Var.global (Var.Global (ModuleName.inVirtualDom "Native.VirtualDom") "staticProgram")

126+ Var.global (Var.Global (ModuleName.inVirtualDom "Elm.Kernel.VirtualDom") "staticProgram")

127127

128128

129129

src/Generate/JavaScript/Expression.hs+2−1

@@ -200,7 +200,8 @@ generateCode expr =

200200 JsExpr <$> BuiltIn.effect moduleName

201201

202202 OutgoingPort name tipe ->

203− JsExpr <$> BuiltIn.outgoingPort name (Foreign.encode tipe)

203+ do encoder <- Foreign.encode tipe

204+ JsExpr <$> BuiltIn.outgoingPort name encoder

204205

205206 IncomingPort name tipe ->

206207 do jsDecoder <- generateJsExpr (Foreign.decode tipe)

src/Generate/JavaScript/Foreign.hs+30−30

@@ -3,6 +3,7 @@

33module Generate.JavaScript.Foreign (encode, decode) where

55import Prelude hiding (maybe)

6+import Control.Monad (zipWithM)

67import qualified Data.List as List

78import qualified Data.Text as Text

89import Data.Text (Text)

@@ -15,18 +16,20 @@ import qualified AST.Variable as Var

1516import qualified Generate.JavaScript.Builder as JS

1617import qualified Generate.JavaScript.Helpers as JS (function, ref)

1718import Generate.JavaScript.Helpers ((<|), (==>))

19+import qualified Generate.JavaScript.Variable as JS (Generator, global)

1820

1921

2022

2123-- ENCODE

2224

2325

24−encode :: T.Canonical -> JS.Expr

26+encode :: T.Canonical -> JS.Generator JS.Expr

2527encode tipe =

26− JS.function ["v"] [ JS.Return (Just (encodeHelp tipe (JS.ref "v"))) ]

28+ do js <- encodeHelp tipe (JS.ref "v")

29+ return $ JS.function ["v"] [ JS.Return (Just js) ]

2730

2831

29−encodeHelp :: T.Canonical -> JS.Expr -> JS.Expr

32+encodeHelp :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

3033encodeHelp tipe expr =

3134 case tipe of

3235 T.Aliased _ args t ->

@@ -39,12 +42,12 @@ encodeHelp tipe expr =

3942 error "encodeHelp: type variable"

4043

4144 T.Type name

42− | Var.isPrim "Float" name -> expr

43− | Var.isPrim "Int" name -> expr

44− | Var.isPrim "Bool" name -> expr

45− | Var.isPrim "String" name -> expr

46− | Var.isJson name -> expr

47− | Var.isTuple name -> JS.Null

45+ | Var.isPrim "Float" name -> pure expr

46+ | Var.isPrim "Int" name -> pure expr

47+ | Var.isPrim "Bool" name -> pure expr

48+ | Var.isPrim "String" name -> pure expr

49+ | Var.isJson name -> pure expr

50+ | Var.isTuple name -> pure JS.Null

4851 | otherwise -> error "encodeHelp: bad type"

4952

5053 T.App (T.Type name) [arg]

@@ -65,44 +68,41 @@ encodeHelp tipe expr =

6568 T.Record fields Nothing ->

6669 let

6770 convert (k, t) =

68− k ==> encodeHelp t (JS.DotRef expr (JS.Id k))

71+ (==>) k <$> encodeHelp t (JS.DotRef expr (JS.Id k))

6972 in

70− JS.Object (map convert fields)

73+ JS.Object <$> traverse convert fields

7174

7275

73−fromMaybe :: T.Canonical -> JS.Expr -> JS.Expr

76+fromMaybe :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

7477fromMaybe tipe expr =

75− JS.If

76− (JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing"))

77− (JS.Null)

78− (encodeHelp tipe (JS.DotRef expr (JS.Id "_0")))

78+ do js <- encodeHelp tipe (JS.DotRef expr (JS.Id "_0"))

79+ let isNothing = JS.Infix JS.OpStrictEq (JS.DotRef expr (JS.Id "ctor")) (JS.String "Nothing")

80+ return $ JS.If isNothing JS.Null js

7981

8082

81−fromList :: T.Canonical -> JS.Expr -> JS.Expr

83+fromList :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

8284fromList tipe expr =

83− let

84− array =

85− error "TODO port fromList" expr -- Var.coreNative "List" "toArray" <| expr

86− in

87− JS.DotRef array (JS.Id "map") <| encode tipe

85+ do let var = Var.Global (ModuleName.inCore "Elm.Kernel.List") "toArray"

86+ toArray <- JS.global var

87+ encoder <- encode tipe

88+ return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder

8889

8990

90−fromArray :: T.Canonical -> JS.Expr -> JS.Expr

91+fromArray :: T.Canonical -> JS.Expr -> JS.Generator JS.Expr

9192fromArray tipe expr =

92− let

93− array =

94− error "TODO port fromArray" expr -- Var.coreNative "Array" "toJSArray" <| expr

95− in

96− JS.DotRef array (JS.Id "map") <| encode tipe

93+ do let var = Var.Global (ModuleName.inCore "Elm.Kernel.Array") "toJSArray"

94+ toArray <- JS.global var

95+ encoder <- encode tipe

96+ return $ JS.DotRef (toArray <| expr) (JS.Id "map") <| encoder

9797

9898

99−fromTuple :: [T.Canonical] -> JS.Expr -> JS.Expr

99+fromTuple :: [T.Canonical] -> JS.Expr -> JS.Generator JS.Expr

100100fromTuple types expr =

101101 let

102102 convert subType n =

103103 encodeHelp subType $ JS.DotRef expr (JS.Id (Text.pack ('_':show n)))

104104 in

105− JS.Array (zipWith convert types [ 0 .. length types ])

105+ JS.Array <$> zipWithM convert types [ 0 .. length types ]

106106

107107

108108

src/Generate/JavaScript/Variable.hs+19−14

@@ -1,5 +1,6 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

3+{-# LANGUAGE UnboxedTuples #-}

34module Generate.JavaScript.Variable

45 ( Generator

56 , run

@@ -142,24 +143,28 @@ getGlobalNameHelp var@(Var.Global home name) (Table uid names symbols) =

142143 return jsName

143144

144145 Nothing ->

145− case Help.isOp name of

146− False ->

147− do let jsName = globalToName home name

148− State.put (Table uid (Map.insert var jsName names) symbols)

149− return jsName

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

146+ let

147+ (# newUid, newName #) =

148+ if Help.isOp name

149+ then (# uid + 1, "_op" <> Text.pack (show uid) #)

150+ else (# uid, name #)

151+ in

152+ do let jsName = globalToName home newName

153+ let newNames = Map.insert var jsName names

154+ State.put (Table newUid newNames symbols)

155+ return jsName

155156

156157

157158globalToName :: ModuleName.Canonical -> Text -> Text

158159globalToName (ModuleName.Canonical (Pkg.Name user project) moduleName) name =

159− Text.replace "-" "_" user

160− <> "$" <> Text.replace "-" "_" project

161− <> "$" <> Text.replace "." "_" moduleName

162− <> "$" <> name

160+ if ModuleName.isKernel moduleName then

161+ "_" <> ModuleName.getKernel moduleName <> "_" <> name

162+

163+ else

164+ Text.replace "-" "_" user

165+ <> "$" <> Text.replace "-" "_" project

166+ <> "$" <> Text.replace "." "_" moduleName

167+ <> "$" <> name

163168

164169

165170

src/Type/Solve.hs+1−1

@@ -200,7 +200,7 @@ actuallySolve constraint =

200200 TS.makeInstance tipe

201201

202202 Nothing ->

203− if Text.isPrefixOf "Native." name then

203+ if Text.isPrefixOf "Elm.Kernel." name then

204204 liftIO (mkVar Nothing)

205205

206206 else