7cf5a56 · elk · git.iko.soy

Elm.cabal+2−1

compare with master

unifiedsplit

@@ -228,7 +228,8 @@ Executable elm-doc

228 pandoc >= 1.10,

229 parsec >= 3.1.1,

230 pretty,

231− text

231+ text,

232+ union-find

232

233

233Test-Suite test-elm

234Test-Suite test-elm

234 Type: exitcode-stdio-1.0

235 Type: exitcode-stdio-1.0

compiler/Generate/JavaScript.hs+18−21

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

1+{-# OPTIONS_GHC -W #-}

1module Generate.JavaScript (generate) where

2module Generate.JavaScript (generate) where

2

3

3import Control.Arrow (first,(***))

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

@@ -24,8 +25,8 @@ split = go []

24 where

25 where

25 go vars str =

26 go vars str =

26 case break (=='.') str of

27 case break (=='.') str of

27− (x,'.':rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

28+ (x,_:rest) | Help.isOp x -> vars ++ [x ++ '.' : rest]

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

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

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

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

30

31

31var name = Id () name

32var name = Id () name

@@ -37,7 +38,11 @@ function args stmts = FuncExpr () Nothing (map var args) stmts

37call = CallExpr ()

38call = CallExpr ()

38string = StringLit ()

39string = StringLit ()

39

40

41+dotSep vars =

42+ case vars of

40−dotSep (x:xs) = foldl (DotRef ()) (ref x) (map var xs)

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

44+ [] -> error "dotSep must be called on a non-empty list of variables"

45+

41obj = dotSep . split

46obj = dotSep . split

42

47

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

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

@@ -191,6 +196,14 @@ expression (L span expr) =

191 pad = "<div style=\"height:0;width:0;\"> </div>"

196 pad = "<div style=\"height:0;width:0;\"> </div>"

192 md = pad ++ MD.toHtml doc ++ pad

197 md = pad ++ MD.toHtml doc ++ pad

193

198

199+ PortIn name _ _ handler ->

200+ do handler' <- expression handler

201+ return $ obj "_N.portIn" `call` [ string name, handler' ]

202+

203+ PortOut name _ signal ->

204+ do signal' <- expression signal

205+ return $ obj "_N.portOut" `call` [ string name, signal' ]

206+

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

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

195definition (Definition pattern expr@(L span _) _) = do

208definition (Definition pattern expr@(L span _) _) = do

196 expr' <- expression expr

209 expr' <- expression expr

@@ -208,8 +221,7 @@ definition (Definition pattern expr@(L span _) _) = do

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

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

209

222

210 PData name patterns | vars /= Nothing ->

223 PData name patterns | vars /= Nothing ->

211− case vars of

212− Just vs -> return [ VarDeclStmt () (setup (zipWith decl vs [0..])) ]

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

213 where

225 where

214 vars = getVars patterns

226 vars = getVars patterns

215 getVars patterns =

227 getVars patterns =

@@ -299,8 +311,6 @@ generate unsafeModule =

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

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

300 , concatMap jsImport (imports modul)

312 , concatMap jsImport (imports modul)

301 , checkInPorts (recvPorts modul)

313 , checkInPorts (recvPorts modul)

302− , map inPort (recvPorts modul)

303− , map outPort (sendPorts modul)

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

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

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

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

306 , [ jsExports ]

316 , [ jsExports ]

@@ -330,21 +340,11 @@ generate unsafeModule =

330 Nothing -> tail . init $ List.inits path

340 Nothing -> tail . init $ List.inits path

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

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

332

342

333− addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")

334−

335 checkInPorts ports =

343 checkInPorts ports =

336− [ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]

344+ [ ExprStmt () $ obj "_N.portCheck" `call` [ref "$moduleName", names] ]

337 where

345 where

338 names = ArrayLit () [ string name | (name, _, _) <- ports ]

346 names = ArrayLit () [ string name | (name, _, _) <- ports ]

339

347

340− inPort (name, expr, _) =

341− assign [name] $ obj "_N.inPort" `call` [ dotSep ["_elm","ports_in",name]

342− , evalState (expression expr) 0 ]

343−

344− outPort (name, expr, _) =

345− let signal = evalState (expression expr) 0 in

346− assign ["_elm","ports_out",name] signal

347−

348binop span op e1 e2 =

349 case op of

350 "Basics.." ->

@@ -371,9 +371,6 @@ binop span op e1 e2 =

371 L _ (Binop op e1 e2) | op == "Basics.." -> collect (es ++ [e1]) e2

372 _ -> es ++ [e]

373

374− js1 = expression e1

375− js2 = expression e2

376−

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

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

378 | otherwise = dotSep parts

375 | otherwise = dotSep parts

379 where

376 where

compiler/SourceSyntax/Expression.hs+24−11

@@ -1,13 +1,14 @@

1+{-# OPTIONS_GHC -Wall #-}

1module SourceSyntax.Expression where

2module SourceSyntax.Expression where

2

3

3−import Data.List (intercalate)

4import SourceSyntax.PrettyPrint

5import Text.PrettyPrint as P

6import qualified SourceSyntax.Helpers as Help

7import qualified SourceSyntax.Location as Location

8import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

9+import qualified SourceSyntax.Type as SrcType

10import qualified SourceSyntax.Literal as Literal

11+import qualified Type.Type as Type

11

12

12{-| This is a located expression. -}

13{-| This is a located expression. -}

13type LExpr' def = Location.Located (Expr' def)

14type LExpr' def = Location.Located (Expr' def)

@@ -45,7 +46,9 @@ data Expr' def

45 | Modify (LExpr' def) [(String, LExpr' def)]

46 | Modify (LExpr' def) [(String, LExpr' def)]

46 | Record [(String, LExpr' def)]

47 | Record [(String, LExpr' def)]

47 | Markdown String String [LExpr' def]

48 | Markdown String String [LExpr' def]

48− deriving (Eq)

49+ -- for type checking and code gen only

50+ | PortIn String SrcType.Type Type.Type (LExpr' def)

51+ | PortOut String SrcType.Type (LExpr' def)

49

52

50type ParseExpr = Expr' ParseDef

53type ParseExpr = Expr' ParseDef

51type LParseExpr = LExpr' ParseDef

54type LParseExpr = LExpr' ParseDef

@@ -57,23 +60,26 @@ separately, and other checks will make sure they can be combined.

57-}

60-}

58data ParseDef

61data ParseDef

59 = Def Pattern.Pattern LParseExpr

62 = Def Pattern.Pattern LParseExpr

60− | TypeAnnotation String Type.Type

63+ | TypeAnnotation String SrcType.Type

61− deriving (Eq, Show)

64+ deriving (Show)

62

65

63{-| After checking that type annotations and definitions are all

66{-| After checking that type annotations and definitions are all

64valid, they can be combined.

67valid, they can be combined.

65-}

68-}

66−data Def

67− = Definition Pattern.Pattern (LExpr' Def) (Maybe Type.Type)

69+data Def = Definition Pattern.Pattern (LExpr' Def) (Maybe SrcType.Type)

68− deriving (Eq, Show)

70+ deriving (Show)

69

71

72+tuple :: [LExpr' def] -> Expr' def

70tuple es = Data ("_Tuple" ++ show (length es)) es

73tuple es = Data ("_Tuple" ++ show (length es)) es

71

74

75+delist :: LExpr' def -> [LExpr' def]

72delist (Location.L _ (Data "::" [h,t])) = h : delist t

76delist (Location.L _ (Data "::" [h,t])) = h : delist t

73delist _ = []

77delist _ = []

74

78

79+saveEnvName :: String

75saveEnvName = "_save_the_environment!!!"

80saveEnvName = "_save_the_environment!!!"

76

81

82+dummyLet :: Pretty def => [def] -> LExpr' def

77dummyLet defs =

83dummyLet defs =

78 Location.none $ Let defs (Location.none $ Var saveEnvName)

84 Location.none $ Let defs (Location.none $ Var saveEnvName)

79

85

@@ -105,7 +111,7 @@ instance Pretty def => Pretty (Expr' def) where

105 P.hang pexpr 2 (P.vcat (map pretty' pats))

111 P.hang pexpr 2 (P.vcat (map pretty' pats))

106 where

112 where

107 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

113 pexpr = P.sep [ P.text "case" <+> pretty e, P.text "of" ]

108− pretty' (p,e) = pretty p <+> P.text "->" <+> pretty e

114+ pretty' (p,b) = pretty p <+> P.text "->" <+> pretty b

109 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

115 Data "::" [hd,tl] -> pretty hd <+> P.text "::" <+> pretty tl

110 Data "[]" [] -> P.text "[]"

116 Data "[]" [] -> P.text "[]"

111 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

117 Data name es -> P.hang (P.text name) 2 (P.sep (map prettyParens es))

@@ -121,7 +127,7 @@ instance Pretty def => Pretty (Expr' def) where

121 4

127 4

122 (commaSep $ map field fs)

128 (commaSep $ map field fs)

123 where

129 where

124− field (x,e) = variable x <+> P.text "<-" <+> pretty e

130+ field (k,v) = variable k <+> P.text "<-" <+> pretty v

125

131

126 Record fs ->

132 Record fs ->

127 P.braces $ P.nest 2 (commaSep $ map field fs)

133 P.braces $ P.nest 2 (commaSep $ map field fs)

@@ -130,6 +136,10 @@ instance Pretty def => Pretty (Expr' def) where

130

136

131 Markdown _ _ _ -> P.text "[markdown| ... |]"

137 Markdown _ _ _ -> P.text "[markdown| ... |]"

132

138

139+ PortIn _ _ _ handler -> pretty handler

140+

141+ PortOut _ _ signal -> pretty signal

142+

133instance Pretty ParseDef where

143instance Pretty ParseDef where

134 pretty def =

144 pretty def =

135 case def of

145 case def of

@@ -147,11 +157,13 @@ instance Pretty Def where

147 Nothing -> P.empty

157 Nothing -> P.empty

148 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

158 Just tipe -> pretty pattern <+> P.colon <+> pretty tipe

149

159

160+collectApps :: LExpr' def -> [LExpr' def]

150collectApps lexpr@(Location.L _ expr) =

161collectApps lexpr@(Location.L _ expr) =

151 case expr of

162 case expr of

152 App a b -> collectApps a ++ [b]

163 App a b -> collectApps a ++ [b]

153 _ -> [lexpr]

164 _ -> [lexpr]

154

165

166+collectLambdas :: LExpr' def -> ([Doc], LExpr' def)

155collectLambdas lexpr@(Location.L _ expr) =

167collectLambdas lexpr@(Location.L _ expr) =

156 case expr of

168 case expr of

157 Lambda pattern body ->

169 Lambda pattern body ->

@@ -159,6 +171,7 @@ collectLambdas lexpr@(Location.L _ expr) =

159 in (pretty pattern : ps, body')

171 in (pretty pattern : ps, body')

160 _ -> ([], lexpr)

172 _ -> ([], lexpr)

161

173

174+prettyParens :: (Pretty def) => LExpr' def -> Doc

162prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

175prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

163 where

176 where

164 needed =

177 needed =

@@ -169,5 +182,5 @@ prettyParens (Location.L _ expr) = parensIf needed (pretty expr)

169 MultiIf _ -> True

182 MultiIf _ -> True

170 Let _ _ -> True

183 Let _ _ -> True

171 Case _ _ -> True

184 Case _ _ -> True

172− Data name (x:xs) -> name /= "::"

185+ Data name (_:_) -> name /= "::"

173 _ -> False

186 _ -> False

compiler/Transform/Canonicalize.hs+10−2

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

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

2module Transform.Canonicalize (interface, metadataModule) where

3

4import Control.Arrow ((***))

@@ -117,6 +117,7 @@ rename env (L s expr) =

117 let rnm = rename env

118 throw err = Left [ P.text $ "Error " ++ show s ++ "\n" ++ err ]

119 format = Either.either throw return

120+ renameType' env = renameType (format . replace "variable" env)

120 in

121 in

121 L s <$>

122 L s <$>

122 case expr of

123 case expr of

@@ -156,7 +157,7 @@ rename env (L s expr) =

156 <*> rename env' body

157 <*> rename env' body

157 <*> case mtipe of

158 <*> case mtipe of

158 Nothing -> return Nothing

159 Nothing -> return Nothing

159− Just tipe -> Just <$> renameType (format . replace "variable" env') tipe

160+ Just tipe -> Just <$> renameType' env' tipe

160

161

161 Var x -> Var <$> format (replace "variable" env x)

162 Var x -> Var <$> format (replace "variable" env x)

162

163

@@ -171,6 +172,13 @@ rename env (L s expr) =

171

172

172 Markdown uid md es -> Markdown uid md <$> mapM rnm es

173 Markdown uid md es -> Markdown uid md <$> mapM rnm es

173

174

175+ PortIn name st tt handler ->

176+ do st' <- renameType' env st

177+ handler' <- rnm handler

178+ return $ PortIn name st' tt handler'

179+

180+ PortOut name st signal -> PortOut name <$> renameType' env st <*> rnm signal

181+

174

182

175renamePattern :: Env -> P.Pattern -> Either String P.Pattern

183renamePattern :: Env -> P.Pattern -> Either String P.Pattern

176renamePattern env pattern =

184renamePattern env pattern =

compiler/Transform/Expression.hs+2−1

@@ -28,4 +28,5 @@ crawl transform = go

28 Record fields -> Record <$> mapM (\(k,v) -> (,) k <$> go v) fields

29 Markdown uid md es -> Markdown uid md <$> mapM go es

30 Let defs body -> Let <$> transform defs <*> go body

31−

31+ PortIn name st tt handler -> PortIn name st tt <$> go handler

32+ PortOut name st signal -> PortOut name st <$> go signal

compiler/Transform/SafeNames.hs+2

@@ -49,6 +49,8 @@ expression (L loc expr) =

49 Modify r fs -> Modify (f r) (map (var *** f) fs)

50 Record fs -> Record (map (var *** f) fs)

51 Markdown uid md es -> Markdown uid md (map f es)

52+ PortIn name st tt handler -> PortIn name st tt (f handler)

53+ PortOut name st signal -> PortOut name st (f signal)

52

54

53definition :: Def -> Def

55definition :: Def -> Def

54definition (Definition p e t) =

56definition (Definition p e t) =

compiler/Transform/SortDefinitions.hs+4

@@ -83,6 +83,10 @@ reorder (L s expr) =

83

84 Markdown uid md es -> Markdown uid md <$> mapM reorder es

85

86+ PortOut name st signal -> PortOut name st <$> reorder signal

87+

88+ PortIn name st tt handler -> PortIn name st tt <$> reorder handler

89+

86 -- Actually do some reordering

90 -- Actually do some reordering

87 Let defs body ->

91 Let defs body ->

88 do body' <- reorder body

92 do body' <- reorder body

compiler/Transform/Substitute.hs+3−1

@@ -37,4 +37,6 @@ subst old new expr =

37 Modify r fs -> Modify (f r) (map (second f) fs)

38 Record fs -> Record (map (second f) fs)

39 Literal _ -> expr

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

40+ Markdown uid md es -> Markdown uid md (map f es)

41+ PortIn name st tt handler -> PortIn name st tt (f handler)

42+ PortOut name st signal -> PortOut name st (f signal)

compiler/Type/Constrain/Declaration.hs+4−3

@@ -45,9 +45,10 @@ toDefs decl =

45

46 Port port ->

47 case port of

48− Send name expr tipe -> [ definition name expr tipe ]

48+ Send name expr@(L.L s _) tipe ->

49+ [ definition name (L.L s $ E.PortOut name tipe expr) tipe ]

50+ Recv name expr@(L.L s _) tipe ->

49− Recv _ _ _ -> -- [ definition name ]

51+ [ definition name (L.L s $ E.PortIn name tipe undefined expr) tipe ]

50− error "not sure how to generate constraints for recv yet"

51

52

52 -- no constraints are needed for fixity declarations

53 -- no constraints are needed for fixity declarations

53 Fixity _ _ _ -> []

54 Fixity _ _ _ -> []

compiler/Type/Constrain/Expression.hs+11

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

1+{-# OPTIONS_GHC -W #-}

1module Type.Constrain.Expression where

2module Type.Constrain.Expression where

2

3

3import qualified Data.List as List

4import qualified Data.List as List

@@ -145,6 +146,16 @@ constrain env (L span expr) tipe =

145 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

146 (clet [Scheme rqs fqs (clet [monoscheme header] c2) header ]

146 (c1 /\ c))

147 (c1 /\ c))

147

148

149+ PortIn _ _ tt handler ->

150+ exists $ \t1 ->

151+ exists $ \t2 ->

152+ exists $ \tHandler -> do

153+ cHandler <- constrain env handler tHandler

154+ return $ and [ cHandler, tHandler === (t1 ==> t2), tt === t2 ]

155+

156+ PortOut _ _ signal ->

157+ constrain env signal tipe

158+

148constrainDef env info (Definition pattern expr maybeTipe) =

159constrainDef env info (Definition pattern expr maybeTipe) =

149 let qs = [] -- should come from the def, but I'm not sure what would live there...

160 let qs = [] -- should come from the def, but I'm not sure what would live there...

150 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

161 (schemes, rigidQuantifiers, flexibleQuantifiers, headers, c2, c1) = info

libraries/Native/Utils.js+30−4

@@ -207,7 +207,7 @@ Elm.Native.Utils.make = function(elm) {

207 return Tuple2(posx, posy);

208 }

209

210− function checkPorts(moduleName, ports) {

210+ function portCheck(moduleName, ports) {

211 var expected = {};

212 for (var i = ports.length; i--; ) {

213 expected[ports[i]] = 1;

@@ -224,13 +224,37 @@ Elm.Native.Utils.make = function(elm) {

224 if (result < 0) extra.push(key);

225 }

226 if (missing.length > 0) {

227+ throw new Error("Module " + moduleName +

227− throw new Error("Module " + moduleName + " requires inputs for these ports: " + missing.join(', '));

228+ " requires inputs for these ports: " + missing.join(', '));

228 }

229 }

229 if (extra.length > 0) {

230 if (extra.length > 0) {

231+ throw new Error("Module " + moduleName +

230− throw new Error("Module " + moduleName + " has been given ports that do not exist: " + extra.join(', '));

232+ " has been given ports that do not exist: " + extra.join(', '));

231 }

233 }

232 }

234 }

233

235

236+ function portOut(name, signal) {

237+ var handlers = []

238+ function subscribe(handler) {

239+ handlers.push(handler);

240+ }

241+ function unsubscribe(handler) {

242+ handlers.pop(handlers.indexOf(handler));

243+ }

244+ Signal.lift(function(v) {

245+ var len = handlers.length;

246+ for (var i = 0; i < len; ++i) {

247+ handlers[i](v);

248+ }

249+ }, signal);

250+ elm.ports_out[name] = { subscribe:subscribe, unsubscribe:unsubscribe };

251+ return signal;

252+ }

253+ function portIn(name, handler) {

254+ var port = elm.ports_in[name];

255+ throw new Error('need to decide on Elm.input definition.');

256+ }

257+

234 return elm.Native.Utils.values = {

258 return elm.Native.Utils.values = {

235 eq:eq,

259 eq:eq,

236 cmp:cmp,

260 cmp:cmp,

@@ -251,6 +275,8 @@ Elm.Native.Utils.make = function(elm) {

251 htmlHeight: F2(htmlHeight),

275 htmlHeight: F2(htmlHeight),

252 getXY: getXY,

276 getXY: getXY,

253 toFloat: function(x) { return +x; },

277 toFloat: function(x) { return +x; },

254− checkPorts: checkPorts

278+ portCheck: portCheck,

279+ portOut: portOut,

280+ portIn: portIn

255 };

281 };

256};

282};