578dfb8 · elk · git.iko.soy

compiler/Build/Source.hs+5−6

compare with master

unifiedsplit

@@ -41,8 +41,8 @@ build noPrelude interfaces source =

41 | null exs =

42 let get = Set.toList . SD.boundVars in

43 concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++

44− concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++

44+ concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++

45− [ name | TypeAlias name _ (Type.Record _ _) <- decls ]

45+ [ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]

46 | otherwise = exs

47

48 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

@@ -53,11 +53,10 @@ build noPrelude interfaces source =

53 -- reorder AST into strongly connected components

54 program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,

55 types = Map.empty,

56− datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],

56+ datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ],

57 fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],

58− aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],

58+ aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ],

59− foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],

59+ ports = [ (name,tipe,maybe) | Port name tipe maybe <- decls ]

60− foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]

61 }

60 }

62

61

63 types <- TI.infer interfaces metaModule

62 types <- TI.infer interfaces metaModule

compiler/Docs.hs+11−6

@@ -17,7 +17,7 @@ import qualified Data.Text as Text

17

18import SourceSyntax.Helpers (isSymbol)

19import SourceSyntax.Type (Type(..))

20−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

20+import SourceSyntax.Declaration (Declaration(..), Assoc(..), Derivation(..))

21import SourceSyntax.Expression (Def(..))

22

23import Text.Parsec hiding (newline,spaces)

@@ -134,12 +134,14 @@ collect infixes types aliases adts things =

134 collect (Map.insert name (assoc,prec) infixes) types aliases adts rest

135 Definition (TypeAnnotation name tipe) ->

136 collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest

137− TypeAlias name vars tipe ->

137+ TypeAlias name vars tipe derivations ->

138− let fields = ["typeVariables" .= vars, "type" .= tipe ]

138+ let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]

139 in collect infixes types (insert name fields aliases) adts rest

140− Datatype name vars ctors ->

140+ Datatype name vars ctors derivations ->

141 let tipe = Data name (map Var vars)

142+ fields = ["typeVariables" .= vars

142− fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]

143+ , "constructors" .= map (ctorToJson tipe) ctors

144+ , "deriving" .= derivations ]

143 in collect infixes types aliases (insert name fields adts) rest

145 in collect infixes types aliases (insert name fields adts) rest

144 where

146 where

145 insert name fields dict = Map.insert name (obj name fields) dict

147 insert name fields dict = Map.insert name (obj name fields) dict

@@ -160,4 +162,7 @@ instance ToJSON Type where

160

162

161ctorToJson tipe (ctor, tipes) =

163ctorToJson tipe (ctor, tipes) =

162 object [ "name" .= ctor

164 object [ "name" .= ctor

163− , "type" .= foldr Lambda tipe tipes ]

165+ , "type" .= foldr Lambda tipe tipes ]

166+

167+instance ToJSON Derivation where

168+ toJSON = toJSON . show

compiler/Generate/JavaScript.hs+10−24

@@ -299,10 +299,10 @@ generate unsafeModule =

299 , [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]

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

301 , concatMap jsImport (imports modul)

302− , concatMap importEvent (foreignImports modul)

302+ , checkInPorts (ports modul)

303+ , map jsPort (ports modul)

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

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

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

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

305− , map exportEvent $ foreignExports modul

306 , [ jsExports ]

307 , [ ReturnStmt () (Just thisModule) ]

308 ]

@@ -332,29 +332,15 @@ generate unsafeModule =

332

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

334

335− importEvent (js,base,elm,_) =

335+ checkInPorts ports =

336− [ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]

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

337− , ExprStmt () $

337+ where

338− obj "document.addEventListener" `call`

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

339− [ addId js

340− , function ["_e"]

341− [ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]

342− ]

343− ]

344

339

345− exportEvent (js,elm,_) =

340+ jsPort (name, _, maybe) =

346− ExprStmt () $

341+ case maybe of

347− ref "A2" `call`

342+ Nothing -> assign [name] $ dotSep ["_elm","ports_in",name]

348− [ obj "Signal.lift"

343+ Just expr -> assign ["_elm","ports_out",name] $ evalState (expression expr) 0

349− , function ["_v"]

350− [ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]

351− , ExprStmt () $

352− obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]

353− , ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")

354− , ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"

355− , ReturnStmt () (Just $ ref "_v")

356− ]

357− , ref elm ]

358

344

359binop span op e1 e2 =

345binop span op e1 e2 =

360 case op of

346 case op of

compiler/Parse/Declaration.hs+39−79

@@ -11,16 +11,16 @@ import Parse.Helpers

11import qualified Parse.Expression as Expr

12import qualified SourceSyntax.Type as T

13import qualified Parse.Type as Type

14−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

14+import qualified SourceSyntax.Declaration as D

15

16

17−declaration :: IParser (Declaration t v)

17+declaration :: IParser (D.Declaration t v)

18−declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

18+declaration = alias <|> datatype <|> infixDecl <|> port <|> definition

19

20−definition :: IParser (Declaration t v)

20+definition :: IParser (D.Declaration t v)

21−definition = Definition <$> Expr.def

21+definition = D.Definition <$> Expr.def

22

23−alias :: IParser (Declaration t v)

23+alias :: IParser (D.Declaration t v)

24alias = do

25 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

26 forcedWS

@@ -28,9 +28,13 @@ alias = do

28 args <- spacePrefix lowVar

29 padded equals

30 tipe <- Type.expr

31+ json <- option [] $ do

32+ try $ padded (reserved "deriving")

33+ string "Json"

34+ return [D.Json]

31− return (TypeAlias alias args tipe)

35+ return (D.TypeAlias alias args tipe json)

32

36

33−datatype :: IParser (Declaration t v)

37+datatype :: IParser (D.Declaration t v)

34datatype = do

38datatype = do

35 reserved "data" <?> "datatype definition (data T = A | B | ...)"

39 reserved "data" <?> "datatype definition (data T = A | B | ...)"

36 forcedWS

40 forcedWS

@@ -38,81 +42,37 @@ datatype = do

38 args <- spacePrefix lowVar

42 args <- spacePrefix lowVar

39 padded equals

43 padded equals

40 tcs <- pipeSep1 Type.constructor

44 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

45+ return $ D.Datatype name args tcs []

42

46

43

47

44−infixDecl :: IParser (Declaration t v)

48+infixDecl :: IParser (D.Declaration t v)

45infixDecl = do

49infixDecl = do

46− assoc <- choice [ reserved "infixl" >> return L

50+ assoc <- choice [ reserved "infixl" >> return D.L

47− , reserved "infix" >> return N

51+ , reserved "infix" >> return D.N

48− , reserved "infixr" >> return R ]

52+ , reserved "infixr" >> return D.R ]

49 forcedWS

53 forcedWS

50 n <- digit

54 n <- digit

51 forcedWS

55 forcedWS

52− Fixity assoc (read [n]) <$> anyOp

56+ D.Fixity assoc (read [n]) <$> anyOp

53−

57+

54−

58+

55−foreignDef :: IParser (Declaration t v)

59+port :: IParser (D.Declaration t v)

56−foreignDef = do

60+port =

57− try (reserved "foreign")

61+ do try (reserved "port")

58− whitespace

59− importEvent <|> exportEvent

60−

61−exportEvent :: IParser (Declaration t v)

62−exportEvent = do

63− try (reserved "export") >> padded (reserved "jsevent")

64− eventName <- jsVar

65− whitespace

62+ whitespace

66− elmVar <- lowVar

63+ name <- lowVar

67− padded hasType

64+ padded hasType

68− tipe <- Type.expr

65+ tipe <- Type.expr

69− case tipe of

66+ expr <- choice [ do try (outPort name)

70− T.Data "Signal" [t] ->

67+ padded equals

71− case isExportable t of

68+ Just <$> Expr.expr

72− Nothing -> return (ExportEvent eventName elmVar tipe)

69+ , return Nothing

73− Just err -> fail err

70+ ]

74− _ -> fail "When importing foreign events, the imported value must have type Signal."

71+ return $ D.Port name tipe expr

75−

76−importEvent :: IParser (Declaration t v)

77−importEvent = do

78− try (reserved "import") >> padded (reserved "jsevent")

79− eventName <- jsVar

80− baseValue <- padded Expr.term

81− <?> "Base case for imported signal (signals cannot be undefined)"

82− elmVar <- lowVar <?> "Name of imported signal"

83− padded hasType

84− tipe <- Type.expr

85− case tipe of

86− T.Data "Signal" [t] ->

87− case isExportable t of

88− Nothing -> return (ImportEvent eventName baseValue elmVar tipe)

89− Just err -> fail err

90− _ -> fail "When importing foreign events, the imported value must have type Signal."

91−

92−jsVar :: IParser String

93−jsVar = betwixt '"' '"' $ do

94− v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')

95− if Set.notMember v jsReserveds then return v else

96− fail $ "'" ++ v ++

97− "' is not a good name for a importing or exporting JS values."

98−

99−isExportable tipe =

100− case tipe of

101− T.Lambda _ _ ->

102− Just $ "Elm's JavaScript event interface does not yet handle functions. " ++

103− "Only simple values can be imported and exported in this release."

104−

105− T.Data "JSArray" [t] -> isExportable t

106−

107− T.Data name []

108− | any (`List.isSuffixOf` name) jsTypes -> Nothing

109− | otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg

110−

111− T.Data name _ ->

112− Just $ "'" ++ name ++ "' is not an exportable type " ++

113− "constructor. Only 'JSArray' is an exportable container."

114−

115− T.Var _ -> Just $ "Cannot export type variables." ++ msg

116 where

72 where

117− msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes

73+ outPort name = do

118− jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]

74+ freshLine

75+ reserved "port"

76+ whitespace

77+ name' <- lowVar

78+ if name == name' then return () else fail "different port"

compiler/Parse/Expression.hs+2−2

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

1−module Parse.Expression (def,term,typeAnnotation) where

1+module Parse.Expression (def,term,typeAnnotation,expr) where

2

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

4import Control.Applicative ((<$>), (<*>))

@@ -16,7 +16,6 @@ import SourceSyntax.Location as Location

16import SourceSyntax.Pattern hiding (tuple,list)

17import qualified SourceSyntax.Literal as Literal

18import SourceSyntax.Expression

19−import SourceSyntax.Declaration (Declaration(Definition))

20

19

21

20

22-------- Basic Terms --------

21-------- Basic Terms --------

@@ -191,6 +190,7 @@ caseExpr = do

191 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

190 with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))

192 without = block (do c <- case_ ; whitespace ; return c)

191 without = block (do c <- case_ ; whitespace ; return c)

193

192

193+expr :: IParser (LExpr t v)

194expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])

195 <|> lambdaExpr

196 <|> binaryExpr

compiler/Parse/Helpers.hs+1−1

@@ -22,7 +22,7 @@ reserveds = [ "if", "then", "else"

22 , "module", "where"

23 , "import", "as", "hiding", "open"

24 , "export", "foreign"

25− , "deriving" ]

25+ , "deriving", "port" ]

26

27jsReserveds :: Set.Set String

28jsReserveds = Set.fromList

compiler/Parse/Parse.hs+2−2

@@ -9,7 +9,7 @@ import Text.Parsec hiding (newline,spaces)

9import qualified Text.PrettyPrint as P

10

11import qualified SourceSyntax.Module as S

12−import SourceSyntax.Declaration (Declaration(Fixity))

12+import qualified SourceSyntax.Declaration as D

13import Parse.Helpers

14import Parse.Binop (OpTable)

15import Parse.Expression

@@ -61,7 +61,7 @@ setupParserWithTable table p source =

61

62parseFixities = do

63 decls <- onFreshLines (:) [] infixDecl

64− return $ Map.fromList [ (op,(lvl,assoc)) | Fixity assoc lvl op <- decls ]

64+ return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]

65

66setupParser :: IParser a -> String -> Either [P.Doc] a

67setupParser p source =

compiler/SourceSyntax/Declaration.hs+48−14

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

1module SourceSyntax.Declaration where

2

3+import Data.Binary

3import qualified SourceSyntax.Expression as Expr

4import qualified SourceSyntax.Expression as Expr

4import SourceSyntax.Type

5import SourceSyntax.Type

5import SourceSyntax.PrettyPrint

6import SourceSyntax.PrettyPrint

@@ -7,15 +8,30 @@ import Text.PrettyPrint as P

7

8

8data Declaration tipe var

9data Declaration tipe var

9 = Definition (Expr.Def tipe var)

10 = Definition (Expr.Def tipe var)

10− | Datatype String [String] [(String,[Type])]

11+ | Datatype String [String] [(String,[Type])] [Derivation]

11− | TypeAlias String [String] Type

12+ | TypeAlias String [String] Type [Derivation]

12− | ImportEvent String (Expr.LExpr tipe var) String Type

13+ | Port String Type (Maybe (Expr.LExpr tipe var))

13− | ExportEvent String String Type

14 | Fixity Assoc Int String

15 deriving (Eq, Show)

16

17data Assoc = L | N | R

18+ deriving (Eq)

19+

20+data Derivation = Json | Binary | RecordConstructor

18− deriving (Eq)

21+ deriving (Eq, Show)

22+

23+instance Binary Derivation where

24+ get = do n <- getWord8

25+ return $ case n of

26+ 0 -> Json

27+ 1 -> Binary

28+ 2 -> RecordConstructor

29+

30+ put derivation =

31+ case derivation of

32+ Json -> putWord8 0

33+ Binary -> putWord8 1

34+ RecordConstructor -> putWord8 2

19

35

20instance Show Assoc where

36instance Show Assoc where

21 show assoc =

37 show assoc =

@@ -29,19 +45,37 @@ instance Pretty (Declaration t v) where

29 case decl of

45 case decl of

30 Definition def -> pretty def

46 Definition def -> pretty def

31

47

32− Datatype tipe tvars ctors ->

48+ Datatype tipe tvars ctors deriveables ->

33 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

49 P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4

34− (P.sep $ zipWith join ("=" : repeat "|") ctors)

50+ (P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables

35 where

51 where

36 join c ctor = P.text c <+> prettyCtor ctor

52 join c ctor = P.text c <+> prettyCtor ctor

37 prettyCtor (name, tipes) =

53 prettyCtor (name, tipes) =

38 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

54 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

39

55

40− TypeAlias name tvars tipe ->

56+ TypeAlias name tvars tipe deriveables ->

57+ alias <+> prettyDeriving deriveables

58+ where

41− let alias = P.text name <+> P.hsep (map P.text tvars) in

59+ name' = P.text name <+> P.hsep (map P.text tvars)

42− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)

60+ alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)

61+

62+ Port name tipe maybeExpr ->

63+ let port = P.text "port" <+> P.text name in

64+ P.vcat [ port <+> P.colon <+> pretty tipe

65+ , maybe P.empty (\expr -> port <+> P.equals <+> pretty expr) maybeExpr

66+ ]

67+

68+ Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op

69+ where

70+ assoc' = case assoc of

71+ L -> P.text "l"

72+ N -> P.empty

73+ R -> P.text "r"

43

74

44− -- TODO: Actually write out the contained data in these cases.

75+prettyDeriving :: [Derivation] -> Doc

45− ImportEvent _ _ _ _ -> P.text (show decl)

76+prettyDeriving deriveables =

46− ExportEvent _ _ _ -> P.text (show decl)

77+ case deriveables of

47− Fixity _ _ _ -> P.text (show decl)

78+ [] -> P.empty

79+ [d] -> P.text "deriving" <+> P.text (show d)

80+ ds -> P.text "deriving" <+>

81+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

compiler/SourceSyntax/Module.hs+6−6

@@ -49,21 +49,21 @@ data MetadataModule t v = MetadataModule {

49 program :: LExpr t v,

50 types :: Map.Map String Type,

51 fixities :: [(Assoc, Int, String)],

52− aliases :: [(String, [String], Type)],

52+ aliases :: [Alias],

53− datatypes :: [ (String, [String], [(String,[Type])]) ],

53+ datatypes :: [ADT],

54− foreignImports :: [(String, LExpr t v, String, Type)],

54+ ports :: [(String, Type, Maybe (LExpr t v))]

55− foreignExports :: [(String, String, Type)]

56} deriving Show

55} deriving Show

57

56

58type Interfaces = Map.Map String ModuleInterface

57type Interfaces = Map.Map String ModuleInterface

59−type ADT = (String, [String], [(String,[Type])])

58+type ADT = (String, [String], [(String,[Type])], [Derivation])

59+type Alias = (String, [String], Type, [Derivation])

60

61data ModuleInterface = ModuleInterface {

62 iVersion :: Version.Version,

63 iTypes :: Map.Map String Type,

64 iImports :: [(String, ImportMethod)],

65 iAdts :: [ADT],

66− iAliases :: [(String, [String], Type)],

66+ iAliases :: [Alias],

67 iFixities :: [(Assoc, Int, String)]

68} deriving Show

69

compiler/Transform/Canonicalize.hs+15−15

@@ -26,11 +26,11 @@ interface moduleName iface =

26 , iFixities = iFixities iface -- cannot have canonicalized operators while parsing

27 }

28 where

29− both f g (a,b,c) = (f a, b, g c)

29+ both f g (a,b,c,d) = (f a, b, g c, d)

30 prefix name = moduleName ++ "." ++ name

31

32 pair name = (name, moduleName ++ "." ++ name)

33− canon (name,_,_) = pair name

33+ canon (name,_,_,_) = pair name

34 canons = Map.fromList $ concat

35 [ map canon (iAdts iface), map canon (iAliases iface) ]

36

@@ -56,31 +56,31 @@ metadataModule ifaces modul =

56 [] -> Right ()

57 missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]

58 program' <- rename initialEnv (program modul)

59− aliases' <- mapM (third renameType') (aliases modul)

59+ aliases' <- mapM (threeOfFour renameType') (aliases modul)

60− datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)

60+ datatypes' <- mapM (threeOfFour (mapM (two2 (mapM renameType')))) (datatypes modul)

61− exports' <- mapM (third renameType') (foreignExports modul)

61+ ports' <- mapM (two3 renameType') (ports modul)

62− imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)

63 return $ modul { program = program'

62 return $ modul { program = program'

64 , aliases = aliases'

63 , aliases = aliases'

65 , datatypes = datatypes'

64 , datatypes = datatypes'

66− , foreignExports = exports'

65+ , ports = ports' }

67− , foreignImports = imports' }

68 where

66 where

69− second f (a,b) = (,) a `fmap` f b

67+ two2 f (a,b) = (,) a `fmap` f b

70− third f (a,b,c) = (,,) a b `fmap` f c

68+ two3 f (a,b,c) = (,,) a `fmap` f b `ap` return c

69+ threeOfFour f (a,b,c,d) = (,,,) a b `fmap` f c `ap` return d

71− twoAndFour f g (a,b,c,d) = do b' <- f b

70+ twoAndFour f g (a,b,c,d) =

71+ do b' <- f b

72− d' <- g d

72+ d' <- g d

73− return (a,b',c,d')

73+ return (a,b',c,d')

74 renameType' =

75 Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)

76

77− get1 (a,_,_) = a

77+ get1 (a,_,_,_) = a

78 canon (name, importMethod) =

79 let pair pre var = (pre ++ drop (length name + 1) var, var)

80 iface = ifaces Map.! name

81 allNames = concat [ Map.keys (iTypes iface)

82 , map get1 (iAliases iface)

83− , concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]

83+ , concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]

84 in case importMethod of

85 As alias -> map (pair (alias ++ ".")) allNames

86 Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

compiler/Transform/Check.hs+37−15

@@ -1,7 +1,7 @@

1module Transform.Check (mistakes) where

2

3import Transform.SortDefinitions (boundVars)

4−import SourceSyntax.Declaration (Declaration(..))

4+import qualified SourceSyntax.Declaration as D

5import SourceSyntax.Expression

6import SourceSyntax.Pattern

7import SourceSyntax.Location

@@ -14,19 +14,20 @@ import qualified Data.Set as Set

14import Text.PrettyPrint as P

15

16

17−mistakes :: [Declaration t v] -> [Doc]

17+mistakes :: [D.Declaration t v] -> [Doc]

18mistakes decls =

19 concat [ infiniteTypeAliases decls

20 , illFormedTypes decls

21 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

22+ , map P.text (concatMap findErrors (getLets decls))

23+ , badDerivations decls ]

23 where

24 where

24 findErrors defs = duplicates defs ++ badOrder defs

25 findErrors defs = duplicates defs ++ badOrder defs

25

26

26−getLets :: [Declaration t v] -> [[Def t v]]

27+getLets :: [D.Declaration t v] -> [[Def t v]]

27getLets decls = defs : concatMap defLets defs

28getLets decls = defs : concatMap defLets defs

28 where

29 where

29− defs = [ d | Definition d <- decls ]

30+ defs = [ d | D.Definition d <- decls ]

30

31

31 defLets def =

32 defLets def =

32 case def of

33 case def of

@@ -69,13 +70,13 @@ duplicates defs =

69 defMsg = dupErr "definition of"

70 defMsg = dupErr "definition of"

70 annMsg = dupErr "type annotation for"

71 annMsg = dupErr "type annotation for"

71

72

72−duplicateConstructors :: [Declaration t v] -> [String]

73+duplicateConstructors :: [D.Declaration t v] -> [String]

73duplicateConstructors decls =

74duplicateConstructors decls =

74 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 where

76 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

77+ typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]

77 dataCtors = List.sort . concat $

78 dataCtors = List.sort . concat $

78− [ map fst patterns | Datatype _ _ patterns <- decls ]

79+ [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]

79 dataMsg = dupErr "definition of data constructor"

80 dataMsg = dupErr "definition of data constructor"

80 typeMsg = dupErr "definition of type constructor"

81 typeMsg = dupErr "definition of type constructor"

81

82

@@ -96,11 +97,32 @@ badOrder defs = go defs

96

97

97 _ -> []

98 _ -> []

98

99

100+badDerivations :: [D.Declaration t v] -> [Doc]

101+badDerivations decls = concatMap badDerivation derivations

102+ where

103+ derivations =

104+ [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++

105+ [ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]

106+

107+ badDerivation (decl, tvars, derives) =

108+ case (tvars, derives) of

109+ (_:_, _)

110+ | D.Json `elem` derives -> [report decl D.Json]

111+ | D.Binary `elem` derives -> [report decl D.Binary]

112+ _ -> []

113+

114+ report decl derive =

115+ P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."

116+ , P.text "Make sure all type variables are replaced with concrete types:"

117+ , P.text "\n"

118+ , nest 4 (pretty decl)

119+ ]

120+

99−illFormedTypes :: [Declaration t v] -> [Doc]

121+illFormedTypes :: [D.Declaration t v] -> [Doc]

100illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

122illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

101 where

123 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

124+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

125+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]

104

126

105 freeVars tipe =

127 freeVars tipe =

106 case tipe of

128 case tipe of

@@ -141,9 +163,9 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141 quote tvar = "'" ++ tvar ++ "'"

163 quote tvar = "'" ++ tvar ++ "'"

142

164

143

165

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

166+infiniteTypeAliases :: [D.Declaration t v] -> [Doc]

145infiniteTypeAliases decls =

167infiniteTypeAliases decls =

146− [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]

168+ [ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]

147 where

169 where

148 isInfinite name tipe =

170 isInfinite name tipe =

149 let infinite = isInfinite name in

171 let infinite = isInfinite name in

@@ -154,11 +176,11 @@ infiniteTypeAliases decls =

154 T.EmptyRecord -> False

176 T.EmptyRecord -> False

155 T.Record fields ext -> infinite ext || any (infinite . snd) fields

177 T.Record fields ext -> infinite ext || any (infinite . snd) fields

156

178

157− report decl@(TypeAlias name args tipe) =

179+ report decl@(D.TypeAlias name args tipe derivations) =

158 P.vcat [ P.text $ eightyCharLines 0 msg1

180 P.vcat [ P.text $ eightyCharLines 0 msg1

159 , indented decl

181 , indented decl

160 , P.text $ eightyCharLines 0 msg2

182 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

183+ , indented (D.Datatype name args [(name,[tipe])] derivations)

162 , P.text $ eightyCharLines 0 msg3 ++ "\n"

184 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163 ]

185 ]

164 where

186 where

compiler/Transform/Optimize.hs+1−1

@@ -19,7 +19,7 @@ class Simplify a where

19

20instance Simplify (Declaration t v) where

21 simp (Definition def) = Definition (simp def)

22− simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t

22+ simp (Port name tipe maybe) = Port name tipe (simp `fmap` maybe)

23 simp stmt = stmt

24

25instance Simplify (Def t v) where

compiler/Transform/SafeNames.hs+5−8

@@ -64,15 +64,12 @@ metadataModule modul =

64 , imports = map (first var) (imports modul)

65 , program = expression (program modul)

66 , aliases =

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

67+ let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)

68 in map makeSafe (aliases modul)

69 , datatypes =

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

70+ let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)

71 in map makeSafe (datatypes modul)

72− , foreignImports =

72+ , ports =

73− let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)

73+ let makeSafe (name,tipe,expr) = (name, tipe, expression `fmap` expr)

74− in map makeSafe (foreignImports modul)

75− , foreignExports =

76− let makeSafe (js,elm,tipe) = (js, var elm, tipe)

77− in map makeSafe (foreignExports modul)

74+ in map makeSafe (ports modul)

78 }

75 }

compiler/Type/Alias.hs+4−4

@@ -9,7 +9,7 @@ import qualified Data.List as List

9import SourceSyntax.Type

10import SourceSyntax.Module

11

12−type Rules = ([(String,[String],Type)], Type -> Type)

12+type Rules = ([Alias], Type -> Type)

13

14rules interfaces moduleAliases moduleImports =

15 (collect interfaces moduleAliases, localizer moduleImports)

@@ -20,7 +20,7 @@ collect interfaces moduleAliases =

20 rawAliases =

21 moduleAliases ++ concatMap iAliases (Map.elems interfaces)

22

23− isPrimitive (_,_,tipe) =

23+ isPrimitive (_,_,tipe,_) =

24 case tipe of

25 Data _ [] -> True

26 _ -> False

@@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)

62

63-- Realias using canonical aliases, so results will have aliases

64-- that are fully qualified and possible to compare.

65−canonicalRealias :: [(String,[String],Type)] -> Type -> Type

65+canonicalRealias :: [Alias] -> Type -> Type

66canonicalRealias aliases tipe =

67 case concatMap tryRealias aliases of

68 [] -> if tipe == tipe' then tipe else f tipe'

69 tipes -> f (bestType tipes)

70 where

71− tryRealias (name, args, aliasTipe) =

71+ tryRealias (name, args, aliasTipe, _) =

72 case diff aliasTipe tipe of

73 Nothing -> []

74 Just kvs ->

compiler/Type/Constrain/Declaration.hs+8−9

@@ -22,7 +22,7 @@ toDefs decl =

22 case decl of

23 Definition def -> [def]

24

25− Datatype name tvars constructors -> concatMap toDefs constructors

25+ Datatype name tvars constructors _ -> concatMap toDefs constructors

26 where

27 toDefs (ctor, tipes) =

28 let vars = take (length tipes) arguments

@@ -32,7 +32,7 @@ toDefs decl =

32 , Src.Def (P.PVar ctor) $ buildFunction body vars

33 ]

34

35− TypeAlias name tvars tipe@(Type.Record fields ext) ->

35+ TypeAlias name tvars tipe@(Type.Record fields ext) _ ->

36 [ Src.TypeAnnotation name $ foldr Type.Lambda tipe args

37 , Src.Def (P.PVar name) $ buildFunction record vars ]

38 where

@@ -50,14 +50,13 @@ toDefs decl =

50

51 -- Type aliases must be added to an extended equality dictionary,

52 -- but they do not require any basic constraints.

53+ -- TODO: with the ability to derive code, you may need to generate stuff!

53− TypeAlias _ _ _ -> []

54+ TypeAlias _ _ _ _ -> []

54

55

55− ImportEvent _ expr@(L.L s _) name tipe ->

56+ Port name tipe maybe ->

56− [ Src.TypeAnnotation name tipe

57+ Src.TypeAnnotation name tipe : case maybe of

58+ Nothing -> []

57− , Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]

59+ Just expr -> [ Src.Def (P.PVar name) expr ]

58−

59− ExportEvent _ name tipe ->

60− [ Src.TypeAnnotation name tipe ]

61

60

62 -- no constraints are needed for fixity declarations

61 -- no constraints are needed for fixity declarations

63 Fixity _ _ _ -> []

62 Fixity _ _ _ -> []

compiler/Type/Environment.hs+5−5

@@ -13,7 +13,7 @@ import qualified Data.UnionFind.IO as UF

13import qualified Text.PrettyPrint as PP

14

15import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

17import Type.Type

18

19type TypeDict = Map.Map String Type

@@ -26,10 +26,10 @@ data Environment = Environment {

26 value :: TypeDict

27}

28

29−initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment

29+initialEnvironment :: [ADT] -> [Alias] -> IO Environment

30initialEnvironment datatypes aliases = do

31 types <- makeTypes datatypes

32− let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases

32+ let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases

33 env = Environment {

34 constructor = Map.empty,

35 value = Map.empty,

@@ -42,7 +42,7 @@ makeTypes :: [ADT] -> IO TypeDict

42makeTypes datatypes =

43 Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)

44 where

45− nameAndKind (name, tvars, _) = (name, length tvars)

45+ nameAndKind (name, tvars, _, _) = (name, length tvars)

46

47 makeCtor (name, kind) = do

48 ctor <- VarN <$> namedVar Constant name

@@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins

84

85

86ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]

87−ctorToType env (name, tvars, ctors) =

87+ctorToType env (name, tvars, ctors, derivations) =

88 zip (map fst ctors) (map inst ctors)

89 where

90 inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

libraries/Native/Utils.js+26−1

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

207 return Tuple2(posx, posy);

208 }

209

210+ function checkPorts(moduleName, ports) {

211+ var expected = {};

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

213+ expected[ports[i]] = 1;

214+ }

215+ for (var key in elm.ports_in) {

216+ expected[key] = expected[key] || 0;

217+ expected[key] -= 1;

218+ }

219+ var missing = [];

220+ var extra = [];

221+ for (var key in expected) {

222+ var result = expected[key];

223+ if (result > 0) missing.push(key);

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

225+ }

226+ if (missing.length > 0) {

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

228+ }

229+ if (extra.length > 0) {

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

231+ }

232+ }

233+

210 return elm.Native.Utils.values = {

234 return elm.Native.Utils.values = {

211 eq:eq,

235 eq:eq,

212 cmp:cmp,

236 cmp:cmp,

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

226 mod : F2(mod),

250 mod : F2(mod),

227 htmlHeight: F2(htmlHeight),

251 htmlHeight: F2(htmlHeight),

228 getXY: getXY,

252 getXY: getXY,

229− toFloat: function(x) { return +x; }

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

254+ checkPorts: checkPorts

230 };

255 };

231};

256};

runtime/Init.js+10−9

@@ -2,7 +2,7 @@

2(function() {

3'use strict';

4

5−Elm.fullscreen = function(module) {

5+Elm.fullscreen = function(module, ports) {

6 var style = document.createElement('style');

7 style.type = 'text/css';

8 style.innerHTML = "html,head,body { padding:0; margin:0; }" +

@@ -10,24 +10,24 @@ Elm.fullscreen = function(module) {

10 document.head.appendChild(style);

11 var container = document.createElement('div');

12 document.body.appendChild(container);

13− return init(ElmRuntime.Display.FULLSCREEN, container, module);

13+ return init(ElmRuntime.Display.FULLSCREEN, container, module, ports);

14};

15

16−Elm.embed = function(module, container) {

16+Elm.embed = function(module, container, ports) {

17 var tag = container.tagName;

18 if (tag !== 'DIV') {

19 throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');

20 } else if (container.hasChildNodes()) {

21 throw new Error('Elm.node must be given an empty DIV. No children allowed!');

22 }

23− return init(ElmRuntime.Display.COMPONENT, container, module);

23+ return init(ElmRuntime.Display.COMPONENT, container, module, ports);

24};

25

26−Elm.worker = function(module) {

26+Elm.worker = function(module, ports) {

27− return init(ElmRuntime.Display.NONE, {}, module);

27+ return init(ElmRuntime.Display.NONE, {}, module, ports);

28};

29

30−function init(display, container, module, moduleToReplace) {

30+function init(display, container, module, moduleToReplace, ports) {

31 // defining state needed for an instance of the Elm RTS

32 var inputs = [];

33

@@ -67,7 +67,8 @@ function init(display, container, module, moduleToReplace) {

67 display:display,

68 id:ElmRuntime.guid(),

69 addListener:addListener,

70− inputs:inputs

70+ inputs:inputs,

71+ ports_in:ports

71 };

72 };

72

73

73 // Set up methods to communicate with Elm program from JS.

74 // Set up methods to communicate with Elm program from JS.

@@ -123,7 +124,7 @@ function init(display, container, module, moduleToReplace) {

123 }

124 }

124

125

125 reportAnyErrors();

126 reportAnyErrors();

126− return { send:send, recv:recv, swap:swap };

127+ return { send:send, recv:recv, swap:swap, ports:elm.ports_out };

127};

128};

128

129

129function filterListeners(inputs, listeners) {

130function filterListeners(inputs, listeners) {