578dfb8 · elk · git.iko.soy

compiler/Build/Source.hs+5−6

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

4141 | null exs =

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

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

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

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

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

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

4646 | otherwise = exs

4747

4848 metaModule <- Canonical.metadataModule interfaces $ MetadataModule {

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

5353 -- reorder AST into strongly connected components

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

5555 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 ],

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

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

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

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

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

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

6160 }

6261

6362 types <- TI.infer interfaces metaModule

compiler/Docs.hs+11−6

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

1717

1818import SourceSyntax.Helpers (isSymbol)

1919import SourceSyntax.Type (Type(..))

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

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

2121import SourceSyntax.Expression (Def(..))

2222

2323import Text.Parsec hiding (newline,spaces)

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

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

135135 Definition (TypeAnnotation name tipe) ->

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

137− TypeAlias name vars tipe ->

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

137+ TypeAlias name vars tipe derivations ->

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

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

140− Datatype name vars ctors ->

140+ Datatype name vars ctors derivations ->

141141 let tipe = Data name (map Var vars)

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

142+ fields = ["typeVariables" .= vars

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

144+ , "deriving" .= derivations ]

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

144146 where

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

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

160162

161163ctorToJson tipe (ctor, tipes) =

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

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

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

301301 , concatMap jsImport (imports modul)

302− , concatMap importEvent (foreignImports modul)

302+ , checkInPorts (ports modul)

303+ , map jsPort (ports modul)

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

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

305− , map exportEvent $ foreignExports modul

306306 , [ jsExports ]

307307 , [ ReturnStmt () (Just thisModule) ]

308308 ]

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

332332

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

334334

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

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

337− , ExprStmt () $

338− obj "document.addEventListener" `call`

339− [ addId js

340− , function ["_e"]

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

342− ]

343− ]

335+ checkInPorts ports =

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

337+ where

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

344339

345− exportEvent (js,elm,_) =

346− ExprStmt () $

347− ref "A2" `call`

348− [ obj "Signal.lift"

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 ]

340+ jsPort (name, _, maybe) =

341+ case maybe of

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

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

358344

359345binop span op e1 e2 =

360346 case op of

compiler/Parse/Declaration.hs+39−79

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

1111import qualified Parse.Expression as Expr

1212import qualified SourceSyntax.Type as T

1313import qualified Parse.Type as Type

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

14+import qualified SourceSyntax.Declaration as D

1515

1616

17−declaration :: IParser (Declaration t v)

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

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

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

1919

20−definition :: IParser (Declaration t v)

21−definition = Definition <$> Expr.def

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

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

2222

23−alias :: IParser (Declaration t v)

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

2424alias = do

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

2626 forcedWS

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

2828 args <- spacePrefix lowVar

2929 padded equals

3030 tipe <- Type.expr

31− return (TypeAlias alias args tipe)

31+ json <- option [] $ do

32+ try $ padded (reserved "deriving")

33+ string "Json"

34+ return [D.Json]

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

3236

33−datatype :: IParser (Declaration t v)

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

3438datatype = do

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

3640 forcedWS

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

3842 args <- spacePrefix lowVar

3943 padded equals

4044 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

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

4246

4347

44−infixDecl :: IParser (Declaration t v)

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

4549infixDecl = do

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

47− , reserved "infix" >> return N

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

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

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

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

4953 forcedWS

5054 n <- digit

5155 forcedWS

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

53−

54−

55−foreignDef :: IParser (Declaration t v)

56−foreignDef = do

57− try (reserved "foreign")

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

66− elmVar <- lowVar

67− padded hasType

68− tipe <- Type.expr

69− case tipe of

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

71− case isExportable t of

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

73− Just err -> fail err

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

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

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

57+

58+

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

60+port =

61+ do try (reserved "port")

62+ whitespace

63+ name <- lowVar

64+ padded hasType

65+ tipe <- Type.expr

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

67+ padded equals

68+ Just <$> Expr.expr

69+ , return Nothing

70+ ]

71+ return $ D.Port name tipe expr

11672 where

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

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

73+ outPort name = do

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

22

33import Control.Arrow ((***))

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

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

1616import SourceSyntax.Pattern hiding (tuple,list)

1717import qualified SourceSyntax.Literal as Literal

1818import SourceSyntax.Expression

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

2019

2120

2221-------- Basic Terms --------

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

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

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

193192

193+expr :: IParser (LExpr t v)

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

195195 <|> lambdaExpr

196196 <|> binaryExpr

compiler/Parse/Helpers.hs+1−1

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

2222 , "module", "where"

2323 , "import", "as", "hiding", "open"

2424 , "export", "foreign"

25− , "deriving" ]

25+ , "deriving", "port" ]

2626

2727jsReserveds :: Set.Set String

2828jsReserveds = Set.fromList

compiler/Parse/Parse.hs+2−2

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

99import qualified Text.PrettyPrint as P

1010

1111import qualified SourceSyntax.Module as S

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

12+import qualified SourceSyntax.Declaration as D

1313import Parse.Helpers

1414import Parse.Binop (OpTable)

1515import Parse.Expression

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

6161

6262parseFixities = do

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

6565

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

6767setupParser p source =

compiler/SourceSyntax/Declaration.hs+48−14

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

11module SourceSyntax.Declaration where

22

3+import Data.Binary

34import qualified SourceSyntax.Expression as Expr

45import SourceSyntax.Type

56import SourceSyntax.PrettyPrint

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

78

89data Declaration tipe var

910 = Definition (Expr.Def tipe var)

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

11− | TypeAlias String [String] Type

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

13− | ExportEvent String String Type

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

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

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

1414 | Fixity Assoc Int String

1515 deriving (Eq, Show)

1616

1717data Assoc = L | N | R

18− deriving (Eq)

18+ deriving (Eq)

19+

20+data Derivation = Json | Binary | RecordConstructor

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

1935

2036instance Show Assoc where

2137 show assoc =

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

2945 case decl of

3046 Definition def -> pretty def

3147

32− Datatype tipe tvars ctors ->

48+ Datatype tipe tvars ctors deriveables ->

3349 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

3551 where

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

3753 prettyCtor (name, tipes) =

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

3955

40− TypeAlias name tvars tipe ->

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

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

56+ TypeAlias name tvars tipe deriveables ->

57+ alias <+> prettyDeriving deriveables

58+ where

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

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"

4374

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

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

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

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

75+prettyDeriving :: [Derivation] -> Doc

76+prettyDeriving deriveables =

77+ case deriveables of

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 {

4949 program :: LExpr t v,

5050 types :: Map.Map String Type,

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

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

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

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

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

52+ aliases :: [Alias],

53+ datatypes :: [ADT],

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

5655} deriving Show

5756

5857type 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])

6060

6161data ModuleInterface = ModuleInterface {

6262 iVersion :: Version.Version,

6363 iTypes :: Map.Map String Type,

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

6565 iAdts :: [ADT],

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

66+ iAliases :: [Alias],

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

6868} deriving Show

6969

compiler/Transform/Canonicalize.hs+15−15

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

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

2727 }

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

3030 prefix name = moduleName ++ "." ++ name

3131

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

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

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

3434 canons = Map.fromList $ concat

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

3636

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

5656 [] -> Right ()

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

5858 program' <- rename initialEnv (program modul)

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

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

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

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

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

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

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

6362 return $ modul { program = program'

6463 , aliases = aliases'

6564 , datatypes = datatypes'

66− , foreignExports = exports'

67− , foreignImports = imports' }

65+ , ports = ports' }

6866 where

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

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

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

72− d' <- g d

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

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

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

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

71+ do b' <- f b

72+ d' <- g d

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

7474 renameType' =

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

7676

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

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

7878 canon (name, importMethod) =

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

8080 iface = ifaces Map.! name

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

8282 , map get1 (iAliases iface)

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

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

8484 in case importMethod of

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

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

compiler/Transform/Check.hs+37−15

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

11module Transform.Check (mistakes) where

22

33import Transform.SortDefinitions (boundVars)

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

4+import qualified SourceSyntax.Declaration as D

55import SourceSyntax.Expression

66import SourceSyntax.Pattern

77import SourceSyntax.Location

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

1414import Text.PrettyPrint as P

1515

1616

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

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

1818mistakes decls =

1919 concat [ infiniteTypeAliases decls

2020 , illFormedTypes decls

2121 , map P.text (duplicateConstructors decls)

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

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

23+ , badDerivations decls ]

2324 where

2425 findErrors defs = duplicates defs ++ badOrder defs

2526

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

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

2728getLets decls = defs : concatMap defLets defs

2829 where

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

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

3031

3132 defLets def =

3233 case def of

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

6970 defMsg = dupErr "definition of"

7071 annMsg = dupErr "type annotation for"

7172

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

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

7374duplicateConstructors decls =

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

7576 where

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

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

7778 dataCtors = List.sort . concat $

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

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

7980 dataMsg = dupErr "definition of data constructor"

8081 typeMsg = dupErr "definition of type constructor"

8182

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

9697

9798 _ -> []

9899

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

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+

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

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

101123 where

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

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

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

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

104126

105127 freeVars tipe =

106128 case tipe of

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

141163 quote tvar = "'" ++ tvar ++ "'"

142164

143165

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

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

145167infiniteTypeAliases decls =

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

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

147169 where

148170 isInfinite name tipe =

149171 let infinite = isInfinite name in

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

154176 T.EmptyRecord -> False

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

156178

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

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

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

159181 , indented decl

160182 , P.text $ eightyCharLines 0 msg2

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

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

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

163185 ]

164186 where

compiler/Transform/Optimize.hs+1−1

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

1919

2020instance Simplify (Declaration t v) where

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

2323 simp stmt = stmt

2424

2525instance Simplify (Def t v) where

compiler/Transform/SafeNames.hs+5−8

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

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

6565 , program = expression (program modul)

6666 , aliases =

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

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

6868 in map makeSafe (aliases modul)

6969 , 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)

7171 in map makeSafe (datatypes modul)

72− , foreignImports =

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

74− in map makeSafe (foreignImports modul)

75− , foreignExports =

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

77− in map makeSafe (foreignExports modul)

72+ , ports =

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

74+ in map makeSafe (ports modul)

7875 }

compiler/Type/Alias.hs+4−4

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

99import SourceSyntax.Type

1010import SourceSyntax.Module

1111

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

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

1313

1414rules interfaces moduleAliases moduleImports =

1515 (collect interfaces moduleAliases, localizer moduleImports)

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

2020 rawAliases =

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

2222

23− isPrimitive (_,_,tipe) =

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

2424 case tipe of

2525 Data _ [] -> True

2626 _ -> False

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

6262

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

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

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

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

6666canonicalRealias aliases tipe =

6767 case concatMap tryRealias aliases of

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

6969 tipes -> f (bestType tipes)

7070 where

71− tryRealias (name, args, aliasTipe) =

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

7272 case diff aliasTipe tipe of

7373 Nothing -> []

7474 Just kvs ->

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

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

2222 case decl of

2323 Definition def -> [def]

2424

25− Datatype name tvars constructors -> concatMap toDefs constructors

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

2626 where

2727 toDefs (ctor, tipes) =

2828 let vars = take (length tipes) arguments

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

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

3333 ]

3434

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

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

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

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

3838 where

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

5050

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

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

53− TypeAlias _ _ _ -> []

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

54+ TypeAlias _ _ _ _ -> []

5455

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

56− [ Src.TypeAnnotation name tipe

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

58−

59− ExportEvent _ name tipe ->

60− [ Src.TypeAnnotation name tipe ]

56+ Port name tipe maybe ->

57+ Src.TypeAnnotation name tipe : case maybe of

58+ Nothing -> []

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

6160

6261 -- no constraints are needed for fixity declarations

6362 Fixity _ _ _ -> []

compiler/Type/Environment.hs+5−5

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

1313import qualified Text.PrettyPrint as PP

1414

1515import qualified SourceSyntax.Type as Src

16−import SourceSyntax.Module (ADT)

16+import SourceSyntax.Module (ADT, Alias)

1717import Type.Type

1818

1919type TypeDict = Map.Map String Type

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

2626 value :: TypeDict

2727}

2828

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

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

3030initialEnvironment datatypes aliases = do

3131 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

3333 env = Environment {

3434 constructor = Map.empty,

3535 value = Map.empty,

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

4242makeTypes datatypes =

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

4444 where

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

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

4646

4747 makeCtor (name, kind) = do

4848 ctor <- VarN <$> namedVar Constant name

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

8484

8585

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

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

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

8888 zip (map fst ctors) (map inst ctors)

8989 where

9090 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) {

207207 return Tuple2(posx, posy);

208208 }

209209

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+

210234 return elm.Native.Utils.values = {

211235 eq:eq,

212236 cmp:cmp,

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

226250 mod : F2(mod),

227251 htmlHeight: F2(htmlHeight),

228252 getXY: getXY,

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

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

254+ checkPorts: checkPorts

230255 };

231256};

runtime/Init.js+10−9

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

22(function() {

33'use strict';

44

5−Elm.fullscreen = function(module) {

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

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

77 style.type = 'text/css';

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

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

1010 document.head.appendChild(style);

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

1212 document.body.appendChild(container);

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

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

1414};

1515

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

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

1717 var tag = container.tagName;

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

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

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

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

2222 }

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

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

2424};

2525

26−Elm.worker = function(module) {

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

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

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

2828};

2929

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

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

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

3232 var inputs = [];

3333

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

6767 display:display,

6868 id:ElmRuntime.guid(),

6969 addListener:addListener,

70− inputs:inputs

70+ inputs:inputs,

71+ ports_in:ports

7172 };

7273

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

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

123124 }

124125

125126 reportAnyErrors();

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

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

127128};

128129

129130function filterListeners(inputs, listeners) {