26fab71 · elk · git.iko.soy

git.iko.soy/elk

Update JS generation code

Rely on new Canonicalization to get safe names. Get rid of SafeNames module.

commit26fab7110e823dd6d775bc20f65b67b410ae1168 authorEvan Czaplicki <info@elm-lang.org> dateSun 13 Apr 2014, 18:38 (13 years ago) parentee5e0fb

5 files changed+197−201

compare with master

unifiedsplit

compiler/Generate/Cases.hs+41−20 compiler/Generate/JavaScript.hs+105−73 compiler/Generate/JavaScript/Helpers.hs+9−1 compiler/Generate/JavaScript/Ports.hs+42−30 compiler/Transform/SafeNames.hs−77

compiler/Generate/Cases.hs+41−20

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

12module Generate.Cases (toMatch, Match (..), Clause (..), matchSubst, newVar) where

34import Control.Applicative ((<$>))

@@ -6,14 +7,15 @@ import Control.Monad.State

67import Data.List (groupBy,sortBy)

78import Data.Maybe (fromMaybe)

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import SourceSyntax.Literal

12−import qualified SourceSyntax.Pattern as P

13−import qualified SourceSyntax.Variable as V

10+import AST.Annotation

11+import AST.Expression.General

12+import AST.Expression.Canonical as Canonical

13+import AST.Literal

14+import qualified AST.Pattern as P

15+import qualified AST.Variable as Var

1416import Transform.Substitute

1517

16−toMatch :: [(P.Pattern, Expr)] -> State Int (String, Match)

18+toMatch :: [(P.CanonicalPattern, Canonical.Expr)] -> State Int (String, Match)

1719toMatch patterns = do

1820 v <- newVar

1921 (,) v <$> match [v] (map (first (:[])) patterns) Fail

@@ -27,12 +29,12 @@ data Match

2729 = Match String [Clause] Match

2830 | Break

2931 | Fail

30− | Other Expr

32+ | Other Canonical.Expr

3133 | Seq [Match]

3234 deriving Show

3335

3436data Clause =

35− Clause (Either String Literal) [String] Match

37+ Clause (Either Var.Canonical Literal) [String] Match

3638 deriving Show

3739

3840matchSubst :: [(String,String)] -> Match -> Match

@@ -42,7 +44,7 @@ matchSubst pairs match =

4244 Fail -> Fail

4345 Seq ms -> Seq (map (matchSubst pairs) ms)

4446 Other (A a e) ->

45− Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (rawVar y)) pairs

47+ Other . A a $ foldr ($) e $ map (\(x,y) -> subst x (localVar y)) pairs

4648 Match n cs m ->

4749 Match (varSubst n) (map clauseSubst cs) (matchSubst pairs m)

4850 where

@@ -50,15 +52,18 @@ matchSubst pairs match =

5052 clauseSubst (Clause c vs m) =

5153 Clause c (map varSubst vs) (matchSubst pairs m)

5254

55+isCon :: ([P.Pattern var], expr) -> Bool

56+isCon ([] , _) = noMatch "isCon"

5357isCon (p:_, _) =

5458 case p of

5559 P.Data _ _ -> True

5660 P.Literal _ -> True

5761 _ -> False

5862

63+isVar :: ([P.Pattern var], expr) -> Bool

5964isVar p = not (isCon p)

6065

61−match :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

66+match :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

6267match [] [] def = return def

6368match [] [([],e)] Fail = return $ Other e

6469match [] [([],e)] Break = return $ Other e

@@ -70,25 +75,30 @@ match vs@(v:_) cs def

7075 where

7176 cs' = map (dealias v) cs

7277

73−dealias :: String -> ([P.Pattern],Expr) -> ([P.Pattern],Expr)

78+dealias :: String -> ([P.CanonicalPattern], Canonical.Expr) -> ([P.CanonicalPattern], Canonical.Expr)

79+dealias _ ([], _) = noMatch "dealias"

7480dealias v c@(p:ps, A a e) =

7581 case p of

76− P.Alias x pattern -> (pattern:ps, A a $ subst x (rawVar v) e)

82+ P.Alias x pattern -> (pattern:ps, A a $ subst x (localVar v) e)

7783 _ -> c

7884

79−matchVar :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

85+matchVar :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

86+matchVar [] _ _ = noMatch "matchVar"

8087matchVar (v:vs) cs def = match vs (map subVar cs) def

8188 where

89+ subVar ([], _) = noMatch "matchVar.subVar"

8290 subVar (p:ps, (A a e)) = (ps, A a $ subOnePattern p e)

8391 where

8492 subOnePattern pattern e =

8593 case pattern of

86− P.Var x -> subst x (rawVar v) e

94+ P.Var x -> subst x (localVar v) e

8795 P.Anything -> e

8896 P.Record fs ->

89− foldr (\x -> subst x (Access (A a (rawVar v)) x)) e fs

97+ foldr (\x -> subst x (Access (A a (localVar v)) x)) e fs

98+ _ -> noMatch "matchVar.subVar"

9099

91−matchCon :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

100+matchCon :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

101+matchCon [] _ _ = noMatch "matchCon"

92102matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

93103 where

94104 css = groupBy eq (sortBy cmp cs)

@@ -97,37 +107,48 @@ matchCon (v:vs) cs def = (flip (Match v) def) <$> mapM toClause css

97107 case (p1,p2) of

98108 (P.Data n1 _, P.Data n2 _) -> compare n1 n2

99109 _ -> compare p1 p2

110+ cmp _ _ = noMatch "matchCon.cmp"

100111

101112 eq (p1:_,_) (p2:_,_) =

102113 case (p1,p2) of

103114 (P.Data n1 _, P.Data n2 _) -> n1 == n2

104115 _ -> p1 == p2

116+ eq _ _ = noMatch "matchCon.eq"

105117

106118 toClause cs =

107119 case head cs of

108120 (P.Data name _ : _, _) -> matchClause (Left name) (v:vs) cs Break

109121 (P.Literal lit : _, _) -> matchClause (Right lit) (v:vs) cs Break

122+ _ -> noMatch "matchCon"

110123

111−matchClause :: Either String Literal

124+matchClause :: Either Var.Canonical Literal

112125 -> [String]

113− -> [([P.Pattern],Expr)]

126+ -> [([P.CanonicalPattern], Canonical.Expr)]

114127 -> Match

115128 -> State Int Clause

129+matchClause _ [] _ _ = noMatch "matchClause"

116130matchClause c (_:vs) cs def =

117131 do vs' <- getVars

118132 Clause c vs' <$> match (vs' ++ vs) (map flatten cs) def

119133 where

120−

134+ flatten ([], _) = noMatch "matchClause.flatten"

121135 flatten (p:ps, e) =

122136 case p of

123137 P.Data _ ps' -> (ps' ++ ps, e)

124138 P.Literal _ -> (ps, e)

139+ _ -> noMatch "matchClause.flatten"

125140

126141 getVars =

127142 case head cs of

128143 (P.Data _ ps : _, _) -> forM ps (const newVar)

129144 (P.Literal _ : _, _) -> return []

145+ _ -> noMatch "matchClause.getVars"

130146

131−matchMix :: [String] -> [([P.Pattern],Expr)] -> Match -> State Int Match

147+matchMix :: [String] -> [([P.CanonicalPattern], Canonical.Expr)] -> Match -> State Int Match

132148matchMix vs cs def = foldM (flip $ match vs) def (reverse css)

133149 where css = groupBy (\p1 p2 -> isCon p1 == isCon p2) cs

150+

151+noMatch :: String -> a

152+noMatch name =

153+ error $ "unexpected pattern in '" ++ name ++

154+ "' function. Report a compiler issue to <https://github.com/elm-lang/Elm>."

compiler/Generate/JavaScript.hs+105−73

@@ -14,15 +14,17 @@ import Generate.JavaScript.Helpers

1414import qualified Generate.Cases as Case

1515import qualified Generate.JavaScript.Ports as Port

1616import qualified Generate.Markdown as MD

17−import SourceSyntax.Annotation

18−import SourceSyntax.Expression

19−import qualified SourceSyntax.Helpers as Help

20−import SourceSyntax.Literal

21−import SourceSyntax.Module

22−import qualified SourceSyntax.Pattern as P

23−import SourceSyntax.PrettyPrint (renderPretty)

24−import qualified SourceSyntax.Variable as V

25−import qualified Transform.SafeNames as MakeSafe

17+

18+import AST.Annotation

19+import AST.Module

20+import AST.Expression.General

21+import qualified AST.Expression.Canonical as Canonical

22+import qualified AST.Module as Module

23+import qualified AST.Helpers as Help

24+import AST.Literal

25+import qualified AST.Pattern as P

26+import AST.PrettyPrint (renderPretty)

27+import qualified AST.Variable as Var

2628

2729varDecl :: String -> Expression () -> VarDecl ()

2830varDecl x expr =

@@ -51,10 +53,24 @@ literal lit =

5153 FloatNum n -> NumLit () n

5254 Boolean b -> BoolLit () b

5355

54−expression :: Expr -> State Int (Expression ())

56+canonical :: Var.Canonical -> Expression ()

57+canonical (Var.Canonical home name) =

58+ case Help.isOp name of

59+ True -> BracketRef () (dotSep (home' ++ ["_op"])) (string name)

60+ False -> dotSep (home' ++ [map (swap '\'' '$') name])

61+ where

62+ swap from to c = if c == from then to else c

63+

64+ home' =

65+ case home of

66+ Var.Local -> []

67+ Var.BuiltIn -> []

68+ Var.Module path -> [ map (swap '.' '$') path ]

69+

70+expression :: Canonical.Expr -> State Int (Expression ())

5571expression (A region expr) =

5672 case expr of

57− Var (V.Raw x) -> return $ obj x

73+ Var var -> return $ canonical var

5874

5975 Literal lit -> return $ literal lit

6076

@@ -108,7 +124,7 @@ expression (A region expr) =

108124 P.Var x -> return (args ++ [x], body)

109125 _ -> do arg <- Case.newVar

110126 return ( args ++ [arg]

111− , A ann (Case (A ann (rawVar arg)) [(pattern, body)]))

127+ , A ann (Case (A ann (localVar arg)) [(pattern, body)]))

112128

113129 (patterns, innerBody) = collect [p] e

114130

@@ -141,7 +157,8 @@ expression (A region expr) =

141157 MultiIf branches ->

142158 do branches' <- forM branches $ \(b,e) -> (,) <$> expression b <*> expression e

143159 return $ case last branches of

144− (A _ (Var (V.Raw "Basics.otherwise")), _) -> safeIfs branches'

160+ (A _ (Var (Var.Canonical (Var.Module "Basics") "otherwise")), _) ->

161+ safeIfs branches'

145162 (A _ (Literal (Boolean True)), _) -> safeIfs branches'

146163 _ -> ifs branches' (obj "_E.If" `call` [ ref "$moduleName", string (renderPretty region) ])

147164 where

@@ -153,7 +170,7 @@ expression (A region expr) =

153170 do (tempVar,initialMatch) <- Case.toMatch cases

154171 (revisedMatch, stmt) <-

155172 case e of

156− A _ (Var (V.Raw x)) ->

173+ A _ (Var (Var.Canonical Var.Local x)) ->

157174 return (Case.matchSubst [(tempVar,x)] initialMatch, [])

158175 _ ->

159176 do e' <- expression e

@@ -187,8 +204,8 @@ expression (A region expr) =

187204 return $ obj "Native.Ports.portOut" `call`

188205 [ string name, Port.outgoing tipe, value' ]

189206

190−definition :: Def -> State Int [Statement ()]

191−definition (Definition pattern expr@(A region _) _) = do

207+definition :: Canonical.Def -> State Int [Statement ()]

208+definition (Canonical.Definition pattern expr@(A region _) _) = do

192209 expr' <- expression expr

193210 let assign x = varDecl x expr'

194211 case pattern of

@@ -203,7 +220,7 @@ definition (Definition pattern expr@(A region _) _) = do

203220 let setField f = varDecl f (dotSep ["$",f]) in

204221 return [ VarDeclStmt () (assign "$" : map setField fields) ]

205222

206− P.Data name patterns | vars /= Nothing ->

223+ P.Data (Var.Canonical _ name) patterns | vars /= Nothing ->

207224 return [ VarDeclStmt () (setup (zipWith decl (maybe [] id vars) [0..])) ]

208225 where

209226 vars = getVars patterns

@@ -227,9 +244,9 @@ definition (Definition pattern expr@(A region _) _) = do

227244 return (VarDeclStmt () [assign "_"] : defs')

228245 where

229246 vars = P.boundVarList pattern

230− mkVar = A region . rawVar

247+ mkVar = A region . localVar

231248 toDef y = let expr = A region $ Case (mkVar "_") [(pattern, mkVar y)]

232− in definition $ Definition (P.Var y) expr Nothing

249+ in definition $ Canonical.Definition (P.Var y) expr Nothing

233250

234251match :: Region -> Case.Match -> State Int [Statement ()]

235252match region mtch =

@@ -279,40 +296,46 @@ clause region variable (Case.Clause value vars mtch) =

279296 _ -> (,) False $ case value of

280297 Right (Boolean b) -> BoolLit () b

281298 Right lit -> literal lit

282− Left name -> string $ case List.elemIndices '.' name of

283− [] -> name

284− is -> drop (last is + 1) name

299+ Left (Var.Canonical _ name) ->

300+ string name

285301

286−flattenLets :: [Def] -> Expr -> ([Def], Expr)

302+flattenLets :: [Canonical.Def] -> Canonical.Expr -> ([Canonical.Def], Canonical.Expr)

287303flattenLets defs lexpr@(A _ expr) =

288304 case expr of

289305 Let ds body -> flattenLets (defs ++ ds) body

290306 _ -> (defs, lexpr)

291307

292−generate :: MetadataModule -> String

293−generate unsafeModule =

294− show . prettyPrint $ setup (Just "Elm") (names modul ++ ["make"]) ++

295− [ assign ("Elm" : names modul ++ ["make"]) (function ["_elm"] programStmts) ]

308+generate :: CanonicalModule -> String

309+generate modul =

310+ show . prettyPrint $ setup "Elm" (names ++ ["make"]) ++

311+ [ assign ("Elm" : names ++ ["make"]) (function ["_elm"] programStmts) ]

296312 where

297− modul = MakeSafe.metadataModule unsafeModule

298− thisModule = dotSep ("_elm" : names modul ++ ["values"])

313+ names = Module.names modul

314+

315+ thisModule = dotSep ("_elm" : names ++ ["values"])

299316 programStmts =

300317 concat

301318 [ [ ExprStmt () $ string "use strict" ]

302− , setup (Just "_elm") (names modul ++ ["values"])

319+ , setup "_elm" (names ++ ["values"])

303320 , [ IfSingleStmt () thisModule (ret thisModule) ]

304− , [ internalImports (List.intercalate "." (names modul)) ]

305− , concatMap jsImport . Set.toList . Set.fromList . map fst $ imports modul

321+ , [ internalImports (List.intercalate "." names) ]

322+ , map jsImport . Set.toList . Set.fromList . map fst $ Module.imports modul

306323 , [ assign ["_op"] (ObjectLit () []) ]

307− , concat $ evalState (mapM definition . fst . flattenLets [] $ program modul) 0

324+ , concat $ evalState (mapM definition . fst . flattenLets [] $ Module.program (Module.body modul)) 0

308325 , [ jsExports ]

309326 , [ ret thisModule ]

310327 ]

311328

312− jsExports = assign ("_elm" : names modul ++ ["values"]) (ObjectLit () exs)

329+ jsExports = assign ("_elm" : names ++ ["values"]) (ObjectLit () exs)

313330 where

314− exs = map entry . filter (not . Help.isOp) $ "_op" : exports modul

331+ exs = map entry $ "_op" : concatMap extract (exports modul)

315332 entry x = (prop x, ref x)

333+ extract value =

334+ case value of

335+ Var.Alias _ -> []

336+ Var.Value x | Help.isOp x -> []

337+ | otherwise -> [x]

338+ Var.ADT _ (Var.Listing ctors _) -> ctors

316339

317340 assign path expr =

318341 case path of

@@ -320,57 +343,66 @@ generate unsafeModule =

320343 _ -> ExprStmt () $

321344 AssignExpr () OpAssign (LDot () (dotSep (init path)) (last path)) expr

322345

323− jsImport modul = setup Nothing path ++ [ include ]

324− where

325− path = Help.splitDots modul

326− include = assign path $ dotSep ("Elm" : path ++ ["make"]) <| ref "_elm"

346+ jsImport name =

347+ assign [dolarize name] $ dotSep ("Elm" : Help.splitDots name ++ ["make"]) <| ref "_elm"

327348

328349 setup namespace path = map create paths

329350 where

330351 create name = assign name (InfixExpr () OpLOr (dotSep name) (ObjectLit () []))

331− paths = case namespace of

332− Nothing -> tail . init $ List.inits path

333− Just nmspc -> drop 2 . init . List.inits $ nmspc : path

334−

335−binop :: Region -> String -> Expr -> Expr -> State Int (Expression ())

336−binop region op e1 e2 =

337− case op of

338− "Basics.." ->

352+ paths = drop 2 . init . List.inits $ namespace : path

353+

354+binop :: Region -> Var.Canonical -> Canonical.Expr -> Canonical.Expr

355+ -> State Int (Expression ())

356+binop region (Var.Canonical home op) e1 e2 =

357+ case (home, op) of

358+ (Var.Module "Basics", ".") ->

339359 do es <- mapM expression (e1 : collect [] e2)

340360 return $ ["$"] ==> foldr (<|) (ref "$") es

341− "Basics.<|" ->

361+

362+ (Var.Module "Basics", "<|") ->

342363 do e2' <- expression e2

343364 es <- mapM expression (collect [] e1)

344365 return $ foldr (<|) e2' es

345− "List.++" ->

366+

367+ (Var.Module "List", "++") ->

346368 do e1' <- expression e1

347369 e2' <- expression e2

348370 return $ obj "_L.append" `call` [e1', e2']

349− "::" -> expression (A region (Data "::" [e1,e2]))

350− _ ->

371+

372+ (Var.BuiltIn, "::") ->

373+ expression (A region (Data "::" [e1,e2]))

374+

375+ (Var.Module "Basics", _) ->

351376 do e1' <- expression e1

352377 e2' <- expression e2

353− return $ case Map.lookup op opDict of

378+ return $ case Map.lookup op basicOps of

354379 Just f -> f e1' e2'

355380 Nothing -> ref "A2" `call` [ func, e1', e2' ]

381+

382+ _ ->

383+ do e1' <- expression e1

384+ e2' <- expression e2

385+ return (ref "A2" `call` [ func, e1', e2' ])

386+

356387 where

357388 collect es e =

358389 case e of

359− A _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

390+ A _ (Binop (Var.Canonical (Var.Module "Basics") ".") e1 e2) ->

391+ collect (es ++ [e1]) e2

360392 _ -> es ++ [e]

361393

362− func | Help.isOp operator = BracketRef () (dotSep (init parts ++ ["_op"])) (string operator)

363− | otherwise = dotSep parts

364− where

365− parts = Help.splitDots op

366− operator = last parts

367−

368− opDict = Map.fromList (infixOps ++ specialOps)

394+ func | Help.isOp op = BracketRef () (dotSep (path ++ ["_op"])) (string op)

395+ | otherwise = dotSep (path ++ [op])

396+ where

397+ path = case home of

398+ Var.Local -> []

399+ Var.BuiltIn -> []

400+ Var.Module m -> [dolarize m]

369401

370− specialOp str func = [ (str, func), ("Basics." ++ str, func) ]

371− infixOp str op = specialOp str (InfixExpr () op)

402+ basicOps = Map.fromList (infixOps ++ specialOps)

372403

373− infixOps = concat

404+ infixOps =

405+ let infixOp str op = (str, InfixExpr () op) in

374406 [ infixOp "+" OpAdd

375407 , infixOp "-" OpSub

376408 , infixOp "*" OpMul

@@ -379,16 +411,16 @@ binop region op e1 e2 =

379411 , infixOp "||" OpLOr

380412 ]

381413

382− specialOps = concat

383− [ specialOp "^" $ \a b -> obj "Math.pow" `call` [a,b]

384− , specialOp "|>" $ flip (<|)

385− , specialOp "==" $ \a b -> obj "_U.eq" `call` [a,b]

386− , specialOp "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

387− , specialOp "<" $ cmp OpLT 0

388− , specialOp ">" $ cmp OpGT 0

389− , specialOp "<=" $ cmp OpLT 1

390− , specialOp ">=" $ cmp OpGT (-1)

391− , specialOp "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

414+ specialOps =

415+ [ (,) "^" $ \a b -> obj "Math.pow" `call` [a,b]

416+ , (,) "|>" $ flip (<|)

417+ , (,) "==" $ \a b -> obj "_U.eq" `call` [a,b]

418+ , (,) "/=" $ \a b -> PrefixExpr () PrefixLNot (obj "_U.eq" `call` [a,b])

419+ , (,) "<" $ cmp OpLT 0

420+ , (,) ">" $ cmp OpGT 0

421+ , (,) "<=" $ cmp OpLT 1

422+ , (,) ">=" $ cmp OpGT (-1)

423+ , (,) "div" $ \a b -> InfixExpr () OpBOr (InfixExpr () OpDiv a b) (IntLit () 0)

392424 ]

393425

394426 cmp op n a b = InfixExpr () op (obj "_U.cmp" `call` [a,b]) (IntLit () n)

compiler/Generate/JavaScript/Helpers.hs+9−1

@@ -1,9 +1,12 @@

11{-# OPTIONS_GHC -W #-}

22module Generate.JavaScript.Helpers where

4−import qualified SourceSyntax.Helpers as Help

4+import qualified AST.Helpers as Help

55import Language.ECMAScript3.Syntax

7+dolarize :: String -> String

8+dolarize x = map (\c -> if c == '.' then '$' else c) x

710split :: String -> [String]

811split = go []

912 where

@@ -13,8 +16,12 @@ split = go []

1316 | otherwise -> go (vars ++ [x]) rest

1417 (x,[]) -> vars ++ [x]

1518

19+var :: String -> Id ()

1620var name = Id () name

21+

22+ref :: String -> Expression ()

1723ref name = VarRef () (var name)

24+

1825prop name = PropId () (var name)

1926f <| x = CallExpr () f [x]

2027ret e = ReturnStmt () (Just e)

@@ -23,6 +30,7 @@ function args stmts = FuncExpr () Nothing (map var args) stmts

2330call = CallExpr ()

2431string = StringLit ()

2532

33+dotSep :: [String] -> Expression ()

2634dotSep vars =

2735 case vars of

2836 x:xs -> foldl (DotRef ()) (ref x) (map var xs)

compiler/Generate/JavaScript/Ports.hs+42−30

@@ -2,8 +2,9 @@

22module Generate.JavaScript.Ports (incoming, outgoing) where

44import Generate.JavaScript.Helpers

5−import qualified SourceSyntax.Helpers as Help

6−import SourceSyntax.Type as T

5+import qualified AST.Helpers as Help

6+import AST.Type as T

7+import qualified AST.Variable as Var

78import Language.ECMAScript3.Syntax

910data JSType = JSNumber | JSBoolean | JSString | JSArray | JSObject [String]

@@ -23,23 +24,28 @@ check x jsType continue =

2324 JSArray -> [instanceof "Array"]

2425 JSObject fields -> [jsFold OpLAnd (typeof "object" : map member fields)]

2526

26−incoming :: Type -> Expression ()

27+incoming :: CanonicalType -> Expression ()

2728incoming tipe =

2829 case tipe of

29− Data "Signal.Signal" [t] ->

30+ Aliased _ t -> incoming t

31+

32+ Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->

3033 obj "Native.Ports.incomingSignal" <| incoming t

34+

3135 _ -> ["v"] ==> inc tipe (ref "v")

3236

33−inc :: Type -> Expression () -> Expression ()

37+inc :: CanonicalType -> Expression () -> Expression ()

3438inc tipe x =

3539 case tipe of

3640 Lambda _ _ -> error "functions should not be allowed through input ports"

3741 Var _ -> error "type variables should not be allowed through input ports"

42+ Aliased _ t ->

43+ inc t x

3844

39− Data "Json.Value" [] ->

45+ Data (Var.Canonical (Var.Module "Json") "Value") [] ->

4046 obj "Native.Json.fromJS" <| x

4147

42− Data ctor []

48+ Data (Var.Canonical Var.BuiltIn ctor) []

4349 | ctor == "Int" -> from JSNumber

4450 | ctor == "Float" -> from JSNumber

4551 | ctor == "Bool" -> from JSBoolean

@@ -47,18 +53,17 @@ inc tipe x =

4753 where

4854 from checks = check x checks x

4955

50− Data ctor [t]

51− | ctor == "Maybe.Maybe" ->

52− CondExpr () (equal x (NullLit ()))

53− (obj "Maybe.Nothing")

54− (obj "Maybe.Just" <| inc t x)

56+ Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->

57+ CondExpr () (equal x (NullLit ()))

58+ (obj "Maybe.Nothing")

59+ (obj "Maybe.Just" <| inc t x)

5560

56− | ctor == "_List" ->

57− check x JSArray (obj "_L.fromArray" <| array)

58− where

59− array = DotRef () x (var "map") <| incoming t

61+ Data (Var.Canonical Var.BuiltIn "_List") [t] ->

62+ check x JSArray (obj "_L.fromArray" <| array)

63+ where

64+ array = DotRef () x (var "map") <| incoming t

6065

61− Data ctor ts

66+ Data (Var.Canonical Var.BuiltIn ctor) ts

6267 | Help.isTuple ctor -> check x JSArray tuple

6368 where

6469 tuple = ObjectLit () $ (prop "ctor", string ctor) : values

@@ -79,15 +84,21 @@ inc tipe x =

7984 keys = map convert fields

8085 convert (f,t) = (prop f, inc t (DotRef () x (var f)))

8186

87+outgoing :: CanonicalType -> Expression ()

8288outgoing tipe =

8389 case tipe of

84− Data "Signal.Signal" [t] ->

90+ Aliased _ t -> outgoing t

91+

92+ Data (Var.Canonical (Var.Module "Signal") "Signal") [t] ->

8593 obj "Native.Ports.outgoingSignal" <| outgoing t

94+

8695 _ -> ["v"] ==> out tipe (ref "v")

8796

88−out :: Type -> Expression () -> Expression ()

97+out :: CanonicalType -> Expression () -> Expression ()

8998out tipe x =

9099 case tipe of

100+ Aliased _ t -> out t x

101+

91102 Lambda _ _

92103 | numArgs > 1 && numArgs < 10 ->

93104 func (ref ('A':show numArgs) `call` (x:values))

@@ -103,21 +114,22 @@ out tipe x =

103114 ]

104115

105116 Var _ -> error "type variables should not be allowed through input ports"

106− Data ctor []

117+

118+ Data (Var.Canonical Var.BuiltIn ctor) []

107119 | ctor `elem` ["Int","Float","Bool","String"] -> x

108− | ctor == "Json.Value" ->

109− obj "Native.Json.toJS" <| x

110120

111− Data ctor [t]

112− | ctor == "Maybe.Maybe" ->

113− CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

114− (NullLit ())

115− (out t (DotRef () x (var "_0")))

121+ Data (Var.Canonical (Var.Module "Json") "Value") [] ->

122+ obj "Native.Json.toJS" <| x

123+

124+ Data (Var.Canonical (Var.Module "Maybe") "Maybe") [t] ->

125+ CondExpr () (equal (DotRef () x (var "ctor")) (string "Nothing"))

126+ (NullLit ())

127+ (out t (DotRef () x (var "_0")))

116128

117− | ctor == "_List" ->

118− DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

129+ Data (Var.Canonical Var.BuiltIn "_List") [t] ->

130+ DotRef () (obj "_L.toArray" <| x) (var "map") <| outgoing t

119131

120− Data ctor ts

132+ Data (Var.Canonical Var.BuiltIn ctor) ts

121133 | Help.isTuple ctor ->

122134 let convert n t = out t $ DotRef () x $ var ('_':show n)

123135 in ArrayLit () $ zipWith convert [0..] ts

compiler/Transform/SafeNames.hsdeleted−77

@@ -1,77 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−module Transform.SafeNames (metadataModule) where

3−

4−import Control.Arrow (first, (***))

5−import qualified Data.List as List

6−import qualified Data.Set as Set

7−

8−import qualified Parse.Helpers as PHelp

9−import SourceSyntax.Annotation

10−import SourceSyntax.Expression

11−import qualified SourceSyntax.Helpers as SHelp

12−import SourceSyntax.Module

13−import qualified SourceSyntax.Pattern as P

14−import qualified SourceSyntax.Variable as Variable

15−

16−var :: String -> String

17−var = List.intercalate "." . map (dereserve . deprime) . SHelp.splitDots

18− where

19− deprime = map (\c -> if c == '\'' then '$' else c)

20− dereserve x = case Set.member x PHelp.jsReserveds of

21− False -> x

22− True -> "$" ++ x

23−

24−pattern :: P.Pattern -> P.Pattern

25−pattern pat =

26− case pat of

27− P.Var x -> P.Var (var x)

28− P.Literal _ -> pat

29− P.Record fs -> P.Record (map var fs)

30− P.Anything -> pat

31− P.Alias x p -> P.Alias (var x) (pattern p)

32− P.Data name ps -> P.Data name (map pattern ps)

33−

34−-- TODO: should be "normal expression" -> "expression for JS generation"

35−expression :: Expr -> Expr

36−expression (A ann expr) =

37− let f = expression in

38− A ann $

39− case expr of

40− Literal _ -> expr

41− Var (Variable.Raw x) -> rawVar (var x)

42− Range e1 e2 -> Range (f e1) (f e2)

43− ExplicitList es -> ExplicitList (map f es)

44− Binop op e1 e2 -> Binop op (f e1) (f e2)

45− Lambda p e -> Lambda (pattern p) (f e)

46− App e1 e2 -> App (f e1) (f e2)

47− MultiIf ps -> MultiIf (map (f *** f) ps)

48− Let defs body -> Let (map definition defs) (f body)

49− Case e cases -> Case (f e) $ map (pattern *** f) cases

50− Data name es -> Data name (map f es)

51− Access e x -> Access (f e) (var x)

52− Remove e x -> Remove (f e) (var x)

53− Insert e x v -> Insert (f e) (var x) (f v)

54− Modify r fs -> Modify (f r) (map (var *** f) fs)

55− Record fs -> Record (map (var *** f) fs)

56− Markdown uid md es -> Markdown uid md (map f es)

57− PortIn name st -> PortIn name st

58− PortOut name st signal -> PortOut name st (f signal)

59−

60−definition :: Def -> Def

61−definition (Definition p e t) =

62− Definition (pattern p) (expression e) t

63−

64−metadataModule :: MetadataModule -> MetadataModule

65−metadataModule modul =

66− modul

67− { names = map var (names modul)

68− , exports = map var (exports modul)

69− , imports = map (first var) (imports modul)

70− , program = expression (program modul)

71− , aliases =

72− let makeSafe (name,tvars,tipe) = (var name, tvars, tipe)

73− in map makeSafe (aliases modul)

74− , datatypes =

75− let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)

76− in map makeSafe (datatypes modul)

77− }