7cf5a56 · elk · git.iko.soy

Elm.cabal+2−1

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

228228 pandoc >= 1.10,

229229 parsec >= 3.1.1,

230230 pretty,

231− text

231+ text,

232+ union-find

232233

233234Test-Suite test-elm

234235 Type: exitcode-stdio-1.0

compiler/Generate/JavaScript.hs+18−21

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

1+{-# OPTIONS_GHC -W #-}

12module Generate.JavaScript (generate) where

23

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

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

2425 where

2526 go vars str =

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

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

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

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

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

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

3031

3132var name = Id () name

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

3738call = CallExpr ()

3839string = StringLit ()

3940

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

41+dotSep vars =

42+ case vars of

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

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

45+

4146obj = dotSep . split

4247

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

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

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

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

193198

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+

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

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

196209 expr' <- expression expr

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

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

209222

210223 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..])) ]

213225 where

214226 vars = getVars patterns

215227 getVars patterns =

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

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

300312 , concatMap jsImport (imports modul)

301313 , checkInPorts (recvPorts modul)

302− , map inPort (recvPorts modul)

303− , map outPort (sendPorts modul)

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

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

306316 , [ jsExports ]

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

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

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

332342

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

334−

335343 checkInPorts ports =

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

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

337345 where

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

339347

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−

348348binop span op e1 e2 =

349349 case op of

350350 "Basics.." ->

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

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

372372 _ -> es ++ [e]

373373

374− js1 = expression e1

375− js2 = expression e2

376−

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

378375 | otherwise = dotSep parts

379376 where

compiler/SourceSyntax/Expression.hs+24−11

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

1+{-# OPTIONS_GHC -Wall #-}

12module SourceSyntax.Expression where

23

3−import Data.List (intercalate)

44import SourceSyntax.PrettyPrint

55import Text.PrettyPrint as P

66import qualified SourceSyntax.Helpers as Help

77import qualified SourceSyntax.Location as Location

88import qualified SourceSyntax.Pattern as Pattern

9−import qualified SourceSyntax.Type as Type

9+import qualified SourceSyntax.Type as SrcType

1010import qualified SourceSyntax.Literal as Literal

11+import qualified Type.Type as Type

1112

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

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

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

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

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

4748 | 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)

4952

5053type ParseExpr = Expr' ParseDef

5154type LParseExpr = LExpr' ParseDef

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

5760-}

5861data ParseDef

5962 = Def Pattern.Pattern LParseExpr

60− | TypeAnnotation String Type.Type

61− deriving (Eq, Show)

63+ | TypeAnnotation String SrcType.Type

64+ deriving (Show)

6265

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

6467valid, they can be combined.

6568-}

66−data Def

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

68− deriving (Eq, Show)

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

70+ deriving (Show)

6971

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

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

7174

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

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

7377delist _ = []

7478

79+saveEnvName :: String

7580saveEnvName = "_save_the_environment!!!"

7681

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

7783dummyLet defs =

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

7985

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

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

106112 where

107113 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

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

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

111117 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

121127 4

122128 (commaSep $ map field fs)

123129 where

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

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

125131

126132 Record fs ->

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

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

130136

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

132138

139+ PortIn _ _ _ handler -> pretty handler

140+

141+ PortOut _ _ signal -> pretty signal

142+

133143instance Pretty ParseDef where

134144 pretty def =

135145 case def of

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

147157 Nothing -> P.empty

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

149159

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

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

151162 case expr of

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

153164 _ -> [lexpr]

154165

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

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

156168 case expr of

157169 Lambda pattern body ->

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

159171 in (pretty pattern : ps, body')

160172 _ -> ([], lexpr)

161173

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

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

163176 where

164177 needed =

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

169182 MultiIf _ -> True

170183 Let _ _ -> True

171184 Case _ _ -> True

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

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

173186 _ -> False

compiler/Transform/Canonicalize.hs+10−2

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

1−{-# OPTIONS_GHC -Wall #-}

1+{-# OPTIONS_GHC -W #-}

22module Transform.Canonicalize (interface, metadataModule) where

33

44import Control.Arrow ((***))

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

117117 let rnm = rename env

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

119119 format = Either.either throw return

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

120121 in

121122 L s <$>

122123 case expr of

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

156157 <*> rename env' body

157158 <*> case mtipe of

158159 Nothing -> return Nothing

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

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

160161

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

162163

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

171172

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

173174

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+

174182

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

176184renamePattern env pattern =

compiler/Transform/Expression.hs+2−1

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

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

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

3030 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) =

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

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

5151 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)

5254

5355definition :: Def -> Def

5456definition (Definition p e t) =

compiler/Transform/SortDefinitions.hs+4

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

8383

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

8585

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

87+

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

89+

8690 -- Actually do some reordering

8791 Let defs body ->

8892 do body' <- reorder body

compiler/Transform/Substitute.hs+3−1

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

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

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

3939 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 =

4545

4646 Port port ->

4747 case port of

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

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

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

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 ->

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

5152

5253 -- no constraints are needed for fixity declarations

5354 Fixity _ _ _ -> []

compiler/Type/Constrain/Expression.hs+11

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

1+{-# OPTIONS_GHC -W #-}

12module Type.Constrain.Expression where

23

34import qualified Data.List as List

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

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

146147 (c1 /\ c))

147148

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+

148159constrainDef env info (Definition pattern expr maybeTipe) =

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

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

libraries/Native/Utils.js+30−4

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

207207 return Tuple2(posx, posy);

208208 }

209209

210− function checkPorts(moduleName, ports) {

210+ function portCheck(moduleName, ports) {

211211 var expected = {};

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

213213 expected[ports[i]] = 1;

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

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

225225 }

226226 if (missing.length > 0) {

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

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

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

228229 }

229230 if (extra.length > 0) {

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

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

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

231233 }

232234 }

233235

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+

234258 return elm.Native.Utils.values = {

235259 eq:eq,

236260 cmp:cmp,

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

251275 htmlHeight: F2(htmlHeight),

252276 getXY: getXY,

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

254− checkPorts: checkPorts

278+ portCheck: portCheck,

279+ portOut: portOut,

280+ portIn: portIn

255281 };

256282};