yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'js-integration' into dev

Browse source
This commit is contained in:
Evan Czaplicki 2014-01-02 12:29:08 -08:00
commit 578dfb8358
18 changed files with 233 additions and 205 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

11
compiler/Build/Source.hs
View file

@ -41,8 +41,8 @@ build noPrelude interfaces source =
| null exs =
let get = Set.toList . SD.boundVars in
concat [ get pattern | Definition (Expr.Def pattern _) <- decls ] ++
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]
concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++
[ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]
| otherwise = exs
metaModule <- Canonical.metadataModule interfaces $ MetadataModule {
@ -53,11 +53,10 @@ build noPrelude interfaces source =
-- reorder AST into strongly connected components
program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls,
types = Map.empty,
datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ],
datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ],
fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ],
aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ],
foreignImports = [ (evt,v,name,typ) | ImportEvent evt v name typ <- decls ],
foreignExports = [ (evt,name,typ) | ExportEvent evt name typ <- decls ]
aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ],
ports = [ (name,tipe,maybe) | Port name tipe maybe <- decls ]
}
types <- TI.infer interfaces metaModule

17
compiler/Docs.hs
View file

@ -17,7 +17,7 @@ import qualified Data.Text as Text
import SourceSyntax.Helpers (isSymbol)
import SourceSyntax.Type (Type(..))
import SourceSyntax.Declaration (Declaration(..), Assoc(..))
import SourceSyntax.Declaration (Declaration(..), Assoc(..), Derivation(..))
import SourceSyntax.Expression (Def(..))
import Text.Parsec hiding (newline,spaces)
@ -134,12 +134,14 @@ collect infixes types aliases adts things =
collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
Definition (TypeAnnotation name tipe) ->
collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
TypeAlias name vars tipe ->
let fields = ["typeVariables" .= vars, "type" .= tipe ]
TypeAlias name vars tipe derivations ->
let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
in collect infixes types (insert name fields aliases) adts rest
Datatype name vars ctors ->
Datatype name vars ctors derivations ->
let tipe = Data name (map Var vars)
fields = ["typeVariables" .= vars, "constructors" .= map (ctorToJson tipe) ctors ]
fields = ["typeVariables" .= vars
, "constructors" .= map (ctorToJson tipe) ctors
, "deriving" .= derivations ]
in collect infixes types aliases (insert name fields adts) rest
where
insert name fields dict = Map.insert name (obj name fields) dict
@ -160,4 +162,7 @@ instance ToJSON Type where
ctorToJson tipe (ctor, tipes) =
object [ "name" .= ctor
, "type" .= foldr Lambda tipe tipes ]
, "type" .= foldr Lambda tipe tipes ]
instance ToJSON Derivation where
toJSON = toJSON . show

34
compiler/Generate/JavaScript.hs
View file

@ -299,10 +299,10 @@ generate unsafeModule =
, [ IfSingleStmt () thisModule (ReturnStmt () (Just thisModule)) ]
, [ internalImports (List.intercalate "." (names modul)) ]
, concatMap jsImport (imports modul)
, concatMap importEvent (foreignImports modul)
, checkInPorts (ports modul)
, map jsPort (ports modul)
, [ assign ["_op"] (ObjectLit () []) ]
, concat $ evalState (mapM definition . fst . SD.flattenLets [] $ program modul) 0
, map exportEvent $ foreignExports modul
, [ jsExports ]
, [ ReturnStmt () (Just thisModule) ]
]
@ -332,29 +332,15 @@ generate unsafeModule =
addId js = InfixExpr () OpAdd (string (js++"_")) (obj "_elm.id")
importEvent (js,base,elm,_) =
[ VarDeclStmt () [ varDecl elm $ obj "Signal.constant" <| evalState (expression base) 0 ]
, ExprStmt () $
obj "document.addEventListener" `call`
[ addId js
, function ["_e"]
[ ExprStmt () $ obj "_elm.notify" `call` [dotSep [elm,"id"], obj "_e.value"] ]
]
]
checkInPorts ports =
[ ExprStmt () $ obj "_N.checkPorts" `call` [ref "$moduleName", names] ]
where
names = ArrayLit () [ string name | (name, _, Nothing) <- ports ]
exportEvent (js,elm,_) =
ExprStmt () $
ref "A2" `call`
[ obj "Signal.lift"
, function ["_v"]
[ VarDeclStmt () [varDecl "_e" $ obj "document.createEvent" <| string "Event"]
, ExprStmt () $
obj "_e.initEvent" `call` [ addId js, BoolLit () True, BoolLit () True ]
, ExprStmt () $ AssignExpr () OpAssign (LDot () (ref "_e") "value") (ref "_v")
, ExprStmt () $ obj "document.dispatchEvent" <| ref "_e"
, ReturnStmt () (Just $ ref "_v")
]
, ref elm ]
jsPort (name, _, maybe) =
case maybe of
Nothing -> assign [name] $ dotSep ["_elm","ports_in",name]
Just expr -> assign ["_elm","ports_out",name] $ evalState (expression expr) 0
binop span op e1 e2 =
case op of

114
compiler/Parse/Declaration.hs
View file

@ -11,16 +11,16 @@ import Parse.Helpers
import qualified Parse.Expression as Expr
import qualified SourceSyntax.Type as T
import qualified Parse.Type as Type
import SourceSyntax.Declaration (Declaration(..), Assoc(..))
import qualified SourceSyntax.Declaration as D
declaration :: IParser (Declaration t v)
declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition
declaration :: IParser (D.Declaration t v)
declaration = alias <|> datatype <|> infixDecl <|> port <|> definition
definition :: IParser (Declaration t v)
definition = Definition <$> Expr.def
definition :: IParser (D.Declaration t v)
definition = D.Definition <$> Expr.def
alias :: IParser (Declaration t v)
alias :: IParser (D.Declaration t v)
alias = do
reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
forcedWS
@ -28,9 +28,13 @@ alias = do
args <- spacePrefix lowVar
padded equals
tipe <- Type.expr
return (TypeAlias alias args tipe)
json <- option [] $ do
try $ padded (reserved "deriving")
string "Json"
return [D.Json]
return (D.TypeAlias alias args tipe json)
datatype :: IParser (Declaration t v)
datatype :: IParser (D.Declaration t v)
datatype = do
reserved "data" <?> "datatype definition (data T = A | B | ...)"
forcedWS
@ -38,81 +42,37 @@ datatype = do
args <- spacePrefix lowVar
padded equals
tcs <- pipeSep1 Type.constructor
return $ Datatype name args tcs
return $ D.Datatype name args tcs []
infixDecl :: IParser (Declaration t v)
infixDecl :: IParser (D.Declaration t v)
infixDecl = do
assoc <- choice [ reserved "infixl" >> return L
, reserved "infix" >> return N
, reserved "infixr" >> return R ]
assoc <- choice [ reserved "infixl" >> return D.L
, reserved "infix" >> return D.N
, reserved "infixr" >> return D.R ]
forcedWS
n <- digit
forcedWS
Fixity assoc (read [n]) <$> anyOp
D.Fixity assoc (read [n]) <$> anyOp
foreignDef :: IParser (Declaration t v)
foreignDef = do
try (reserved "foreign")
whitespace
importEvent <|> exportEvent
exportEvent :: IParser (Declaration t v)
exportEvent = do
try (reserved "export") >> padded (reserved "jsevent")
eventName <- jsVar
whitespace
elmVar <- lowVar
padded hasType
tipe <- Type.expr
case tipe of
T.Data "Signal" [t] ->
case isExportable t of
Nothing -> return (ExportEvent eventName elmVar tipe)
Just err -> fail err
_ -> fail "When importing foreign events, the imported value must have type Signal."
importEvent :: IParser (Declaration t v)
importEvent = do
try (reserved "import") >> padded (reserved "jsevent")
eventName <- jsVar
baseValue <- padded Expr.term
<?> "Base case for imported signal (signals cannot be undefined)"
elmVar <- lowVar <?> "Name of imported signal"
padded hasType
tipe <- Type.expr
case tipe of
T.Data "Signal" [t] ->
case isExportable t of
Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
Just err -> fail err
_ -> fail "When importing foreign events, the imported value must have type Signal."
jsVar :: IParser String
jsVar = betwixt '"' '"' $ do
v <- (:) <$> (letter <|> char '_') <*> many (alphaNum <|> char '_')
if Set.notMember v jsReserveds then return v else
fail $ "'" ++ v ++
"' is not a good name for a importing or exporting JS values."
isExportable tipe =
case tipe of
T.Lambda _ _ ->
Just $ "Elm's JavaScript event interface does not yet handle functions. " ++
"Only simple values can be imported and exported in this release."
T.Data "JSArray" [t] -> isExportable t
T.Data name []
| any (`List.isSuffixOf` name) jsTypes -> Nothing
| otherwise -> Just $ "'" ++ name ++ "' is not an exportable type." ++ msg
T.Data name _ ->
Just $ "'" ++ name ++ "' is not an exportable type " ++
"constructor. Only 'JSArray' is an exportable container."
T.Var _ -> Just $ "Cannot export type variables." ++ msg
port :: IParser (D.Declaration t v)
port =
do try (reserved "port")
whitespace
name <- lowVar
padded hasType
tipe <- Type.expr
expr <- choice [ do try (outPort name)
padded equals
Just <$> Expr.expr
, return Nothing
]
return $ D.Port name tipe expr
where
msg = " The following types are exportable: " ++ List.intercalate ", " jsTypes
jsTypes = ["JSString","JSNumber","JSDomNode","JSBool","JSObject"]
outPort name = do
freshLine
reserved "port"
whitespace
name' <- lowVar
if name == name' then return () else fail "different port"

4
compiler/Parse/Expression.hs
View file

@ -1,4 +1,4 @@
module Parse.Expression (def,term,typeAnnotation) where
module Parse.Expression (def,term,typeAnnotation,expr) where
import Control.Arrow ((***))
import Control.Applicative ((<$>), (<*>))
@ -16,7 +16,6 @@ import SourceSyntax.Location as Location
import SourceSyntax.Pattern hiding (tuple,list)
import qualified SourceSyntax.Literal as Literal
import SourceSyntax.Expression
import SourceSyntax.Declaration (Declaration(Definition))
-------- Basic Terms --------
@ -191,6 +190,7 @@ caseExpr = do
with = brackets (semiSep1 (case_ <?> "cases { x -> ... }"))
without = block (do c <- case_ ; whitespace ; return c)
expr :: IParser (LExpr t v)
expr = addLocation (choice [ ifExpr, letExpr, caseExpr ])
<|> lambdaExpr
<|> binaryExpr

2
compiler/Parse/Helpers.hs
View file

@ -22,7 +22,7 @@ reserveds = [ "if", "then", "else"
, "module", "where"
, "import", "as", "hiding", "open"
, "export", "foreign"
, "deriving" ]
, "deriving", "port" ]
jsReserveds :: Set.Set String
jsReserveds = Set.fromList

4
compiler/Parse/Parse.hs
View file

@ -9,7 +9,7 @@ import Text.Parsec hiding (newline,spaces)
import qualified Text.PrettyPrint as P
import qualified SourceSyntax.Module as S
import SourceSyntax.Declaration (Declaration(Fixity))
import qualified SourceSyntax.Declaration as D
import Parse.Helpers
import Parse.Binop (OpTable)
import Parse.Expression
@ -61,7 +61,7 @@ setupParserWithTable table p source =
parseFixities = do
decls <- onFreshLines (:) [] infixDecl
return $ Map.fromList [ (op,(lvl,assoc)) | Fixity assoc lvl op <- decls ]
return $ Map.fromList [ (op,(lvl,assoc)) | D.Fixity assoc lvl op <- decls ]
setupParser :: IParser a -> String -> Either [P.Doc] a
setupParser p source =

62
compiler/SourceSyntax/Declaration.hs
View file

@ -1,5 +1,6 @@
module SourceSyntax.Declaration where
import Data.Binary
import qualified SourceSyntax.Expression as Expr
import SourceSyntax.Type
import SourceSyntax.PrettyPrint
@ -7,15 +8,30 @@ import Text.PrettyPrint as P
data Declaration tipe var
= Definition (Expr.Def tipe var)
| Datatype String [String] [(String,[Type])]
| TypeAlias String [String] Type
| ImportEvent String (Expr.LExpr tipe var) String Type
| ExportEvent String String Type
| Datatype String [String] [(String,[Type])] [Derivation]
| TypeAlias String [String] Type [Derivation]
| Port String Type (Maybe (Expr.LExpr tipe var))
| Fixity Assoc Int String
deriving (Eq, Show)
data Assoc = L | N | R
deriving (Eq)
deriving (Eq)
data Derivation = Json | Binary | RecordConstructor
deriving (Eq, Show)
instance Binary Derivation where
get = do n <- getWord8
return $ case n of
0 -> Json
1 -> Binary
2 -> RecordConstructor
put derivation =
case derivation of
Json -> putWord8 0
Binary -> putWord8 1
RecordConstructor -> putWord8 2
instance Show Assoc where
show assoc =
@ -29,19 +45,37 @@ instance Pretty (Declaration t v) where
case decl of
Definition def -> pretty def
Datatype tipe tvars ctors ->
Datatype tipe tvars ctors deriveables ->
P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
(P.sep $ zipWith join ("=" : repeat "|") ctors)
(P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
where
join c ctor = P.text c <+> prettyCtor ctor
prettyCtor (name, tipes) =
P.hang (P.text name) 2 (P.sep (map prettyParens tipes))
TypeAlias name tvars tipe ->
let alias = P.text name <+> P.hsep (map P.text tvars) in
P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)
TypeAlias name tvars tipe deriveables ->
alias <+> prettyDeriving deriveables
where
name' = P.text name <+> P.hsep (map P.text tvars)
alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
-- TODO: Actually write out the contained data in these cases.
ImportEvent _ _ _ _ -> P.text (show decl)
ExportEvent _ _ _ -> P.text (show decl)
Fixity _ _ _ -> P.text (show decl)
Port name tipe maybeExpr ->
let port = P.text "port" <+> P.text name in
P.vcat [ port <+> P.colon <+> pretty tipe
, maybe P.empty (\expr -> port <+> P.equals <+> pretty expr) maybeExpr
]
Fixity assoc prec op -> P.text "infix" <> assoc' <+> P.int prec <+> P.text op
where
assoc' = case assoc of
L -> P.text "l"
N -> P.empty
R -> P.text "r"
prettyDeriving :: [Derivation] -> Doc
prettyDeriving deriveables =
case deriveables of
[] -> P.empty
[d] -> P.text "deriving" <+> P.text (show d)
ds -> P.text "deriving" <+>
P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)

12
compiler/SourceSyntax/Module.hs
View file

@ -49,21 +49,21 @@ data MetadataModule t v = MetadataModule {
program :: LExpr t v,
types :: Map.Map String Type,
fixities :: [(Assoc, Int, String)],
aliases :: [(String, [String], Type)],
datatypes :: [ (String, [String], [(String,[Type])]) ],
foreignImports :: [(String, LExpr t v, String, Type)],
foreignExports :: [(String, String, Type)]
aliases :: [Alias],
datatypes :: [ADT],
ports :: [(String, Type, Maybe (LExpr t v))]
} deriving Show
type Interfaces = Map.Map String ModuleInterface
type ADT = (String, [String], [(String,[Type])])
type ADT = (String, [String], [(String,[Type])], [Derivation])
type Alias = (String, [String], Type, [Derivation])
data ModuleInterface = ModuleInterface {
iVersion :: Version.Version,
iTypes :: Map.Map String Type,
iImports :: [(String, ImportMethod)],
iAdts :: [ADT],
iAliases :: [(String, [String], Type)],
iAliases :: [Alias],
iFixities :: [(Assoc, Int, String)]
} deriving Show

30
compiler/Transform/Canonicalize.hs
View file

@ -26,11 +26,11 @@ interface moduleName iface =
, iFixities = iFixities iface -- cannot have canonicalized operators while parsing
}
where
both f g (a,b,c) = (f a, b, g c)
both f g (a,b,c,d) = (f a, b, g c, d)
prefix name = moduleName ++ "." ++ name
pair name = (name, moduleName ++ "." ++ name)
canon (name,_,_) = pair name
canon (name,_,_,_) = pair name
canons = Map.fromList $ concat
[ map canon (iAdts iface), map canon (iAliases iface) ]
@ -56,31 +56,31 @@ metadataModule ifaces modul =
[] -> Right ()
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
program' <- rename initialEnv (program modul)
aliases' <- mapM (third renameType') (aliases modul)
datatypes' <- mapM (third (mapM (second (mapM renameType')))) (datatypes modul)
exports' <- mapM (third renameType') (foreignExports modul)
imports' <- mapM (twoAndFour (rename initialEnv) renameType') (foreignImports modul)
aliases' <- mapM (threeOfFour renameType') (aliases modul)
datatypes' <- mapM (threeOfFour (mapM (two2 (mapM renameType')))) (datatypes modul)
ports' <- mapM (two3 renameType') (ports modul)
return $ modul { program = program'
, aliases = aliases'
, datatypes = datatypes'
, foreignExports = exports'
, foreignImports = imports' }
, ports = ports' }
where
second f (a,b) = (,) a `fmap` f b
third f (a,b,c) = (,,) a b `fmap` f c
twoAndFour f g (a,b,c,d) = do b' <- f b
d' <- g d
return (a,b',c,d')
two2 f (a,b) = (,) a `fmap` f b
two3 f (a,b,c) = (,,) a `fmap` f b `ap` return c
threeOfFour f (a,b,c,d) = (,,,) a b `fmap` f c `ap` return d
twoAndFour f g (a,b,c,d) =
do b' <- f b
d' <- g d
return (a,b',c,d')
renameType' =
Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
get1 (a,_,_) = a
get1 (a,_,_,_) = a
canon (name, importMethod) =
let pair pre var = (pre ++ drop (length name + 1) var, var)
iface = ifaces Map.! name
allNames = concat [ Map.keys (iTypes iface)
, map get1 (iAliases iface)
, concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
, concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]
in case importMethod of
As alias -> map (pair (alias ++ ".")) allNames
Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames

52
compiler/Transform/Check.hs
View file

@ -1,7 +1,7 @@
module Transform.Check (mistakes) where
import Transform.SortDefinitions (boundVars)
import SourceSyntax.Declaration (Declaration(..))
import qualified SourceSyntax.Declaration as D
import SourceSyntax.Expression
import SourceSyntax.Pattern
import SourceSyntax.Location
@ -14,19 +14,20 @@ import qualified Data.Set as Set
import Text.PrettyPrint as P
mistakes :: [Declaration t v] -> [Doc]
mistakes :: [D.Declaration t v] -> [Doc]
mistakes decls =
concat [ infiniteTypeAliases decls
, illFormedTypes decls
, map P.text (duplicateConstructors decls)
, map P.text (concatMap findErrors (getLets decls)) ]
, map P.text (concatMap findErrors (getLets decls))
, badDerivations decls ]
where
findErrors defs = duplicates defs ++ badOrder defs
getLets :: [Declaration t v] -> [[Def t v]]
getLets :: [D.Declaration t v] -> [[Def t v]]
getLets decls = defs : concatMap defLets defs
where
defs = [ d | Definition d <- decls ]
defs = [ d | D.Definition d <- decls ]
defLets def =
case def of
@ -69,13 +70,13 @@ duplicates defs =
defMsg = dupErr "definition of"
annMsg = dupErr "type annotation for"
duplicateConstructors :: [Declaration t v] -> [String]
duplicateConstructors :: [D.Declaration t v] -> [String]
duplicateConstructors decls =
map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
where
typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
typeCtors = List.sort [ name | D.Datatype name _ _ _ <- decls ]
dataCtors = List.sort . concat $
[ map fst patterns | Datatype _ _ patterns <- decls ]
[ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
dataMsg = dupErr "definition of data constructor"
typeMsg = dupErr "definition of type constructor"
@ -96,11 +97,32 @@ badOrder defs = go defs
_ -> []
illFormedTypes :: [Declaration t v] -> [Doc]
badDerivations :: [D.Declaration t v] -> [Doc]
badDerivations decls = concatMap badDerivation derivations
where
derivations =
[ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ] ++
[ (decl, tvars, derives) | decl@(D.Datatype name tvars _ derives) <- decls ]
badDerivation (decl, tvars, derives) =
case (tvars, derives) of
(_:_, _)
| D.Json `elem` derives -> [report decl D.Json]
| D.Binary `elem` derives -> [report decl D.Binary]
_ -> []
report decl derive =
P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
, P.text "Make sure all type variables are replaced with concrete types:"
, P.text "\n"
, nest 4 (pretty decl)
]
illFormedTypes :: [D.Declaration t v] -> [Doc]
illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
where
aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors _) <- decls ]
freeVars tipe =
case tipe of
@ -141,9 +163,9 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
quote tvar = "'" ++ tvar ++ "'"
infiniteTypeAliases :: [Declaration t v] -> [Doc]
infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
infiniteTypeAliases decls =
[ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
[ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]
where
isInfinite name tipe =
let infinite = isInfinite name in
@ -154,11 +176,11 @@ infiniteTypeAliases decls =
T.EmptyRecord -> False
T.Record fields ext -> infinite ext || any (infinite . snd) fields
report decl@(TypeAlias name args tipe) =
report decl@(D.TypeAlias name args tipe derivations) =
P.vcat [ P.text $ eightyCharLines 0 msg1
, indented decl
, P.text $ eightyCharLines 0 msg2
, indented (Datatype name args [(name,[tipe])])
, indented (D.Datatype name args [(name,[tipe])] derivations)
, P.text $ eightyCharLines 0 msg3 ++ "\n"
]
where

2
compiler/Transform/Optimize.hs
View file

@ -19,7 +19,7 @@ class Simplify a where
instance Simplify (Declaration t v) where
simp (Definition def) = Definition (simp def)
simp (ImportEvent js b elm t) = ImportEvent js (simp b) elm t
simp (Port name tipe maybe) = Port name tipe (simp `fmap` maybe)
simp stmt = stmt
instance Simplify (Def t v) where

13
compiler/Transform/SafeNames.hs
View file

@ -64,15 +64,12 @@ metadataModule modul =
, imports = map (first var) (imports modul)
, program = expression (program modul)
, aliases =
let makeSafe (name, tvars, tipe) = (var name, tvars, tipe)
let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)
in map makeSafe (aliases modul)
, datatypes =
let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)
let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)
in map makeSafe (datatypes modul)
, foreignImports =
let makeSafe (js,expr,elm,tipe) = (js, expression expr, var elm, tipe)
in map makeSafe (foreignImports modul)
, foreignExports =
let makeSafe (js,elm,tipe) = (js, var elm, tipe)
in map makeSafe (foreignExports modul)
, ports =
let makeSafe (name,tipe,expr) = (name, tipe, expression `fmap` expr)
in map makeSafe (ports modul)
}

8
compiler/Type/Alias.hs
View file

@ -9,7 +9,7 @@ import qualified Data.List as List
import SourceSyntax.Type
import SourceSyntax.Module
type Rules = ([(String,[String],Type)], Type -> Type)
type Rules = ([Alias], Type -> Type)
rules interfaces moduleAliases moduleImports =
(collect interfaces moduleAliases, localizer moduleImports)
@ -20,7 +20,7 @@ collect interfaces moduleAliases =
rawAliases =
moduleAliases ++ concatMap iAliases (Map.elems interfaces)
isPrimitive (_,_,tipe) =
isPrimitive (_,_,tipe,_) =
case tipe of
Data _ [] -> True
_ -> False
@ -62,13 +62,13 @@ realias (aliases,localize) tipe = localize (canonicalRealias aliases tipe)
-- Realias using canonical aliases, so results will have aliases
-- that are fully qualified and possible to compare.
canonicalRealias :: [(String,[String],Type)] -> Type -> Type
canonicalRealias :: [Alias] -> Type -> Type
canonicalRealias aliases tipe =
case concatMap tryRealias aliases of
[] -> if tipe == tipe' then tipe else f tipe'
tipes -> f (bestType tipes)
where
tryRealias (name, args, aliasTipe) =
tryRealias (name, args, aliasTipe, _) =
case diff aliasTipe tipe of
Nothing -> []
Just kvs ->

17
compiler/Type/Constrain/Declaration.hs
View file

@ -22,7 +22,7 @@ toDefs decl =
case decl of
Definition def -> [def]
Datatype name tvars constructors -> concatMap toDefs constructors
Datatype name tvars constructors _ -> concatMap toDefs constructors
where
toDefs (ctor, tipes) =
let vars = take (length tipes) arguments
@ -32,7 +32,7 @@ toDefs decl =
, Src.Def (P.PVar ctor) $ buildFunction body vars
]
TypeAlias name tvars tipe@(Type.Record fields ext) ->
TypeAlias name tvars tipe@(Type.Record fields ext) _ ->
[ Src.TypeAnnotation name $ foldr Type.Lambda tipe args
, Src.Def (P.PVar name) $ buildFunction record vars ]
where
@ -50,14 +50,13 @@ toDefs decl =
-- Type aliases must be added to an extended equality dictionary,
-- but they do not require any basic constraints.
TypeAlias _ _ _ -> []
-- TODO: with the ability to derive code, you may need to generate stuff!
TypeAlias _ _ _ _ -> []
ImportEvent _ expr@(L.L s _) name tipe ->
[ Src.TypeAnnotation name tipe
, Src.Def (P.PVar name) (L.L s $ Src.App (L.L s $ Src.Var "constant") expr) ]
ExportEvent _ name tipe ->
[ Src.TypeAnnotation name tipe ]
Port name tipe maybe ->
Src.TypeAnnotation name tipe : case maybe of
Nothing -> []
Just expr -> [ Src.Def (P.PVar name) expr ]
-- no constraints are needed for fixity declarations
Fixity _ _ _ -> []

10
compiler/Type/Environment.hs
View file

@ -13,7 +13,7 @@ import qualified Data.UnionFind.IO as UF
import qualified Text.PrettyPrint as PP
import qualified SourceSyntax.Type as Src
import SourceSyntax.Module (ADT)
import SourceSyntax.Module (ADT, Alias)
import Type.Type
type TypeDict = Map.Map String Type
@ -26,10 +26,10 @@ data Environment = Environment {
value :: TypeDict
}
initialEnvironment :: [ADT] -> [(String, [String], Src.Type)] -> IO Environment
initialEnvironment :: [ADT] -> [Alias] -> IO Environment
initialEnvironment datatypes aliases = do
types <- makeTypes datatypes
let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases
env = Environment {
constructor = Map.empty,
value = Map.empty,
@ -42,7 +42,7 @@ makeTypes :: [ADT] -> IO TypeDict
makeTypes datatypes =
Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
where
nameAndKind (name, tvars, _) = (name, length tvars)
nameAndKind (name, tvars, _, _) = (name, length tvars)
makeCtor (name, kind) = do
ctor <- VarN <$> namedVar Constant name
@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins
ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
ctorToType env (name, tvars, ctors) =
ctorToType env (name, tvars, ctors, derivations) =
zip (map fst ctors) (map inst ctors)
where
inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)

27
libraries/Native/Utils.js
View file

@ -207,6 +207,30 @@ Elm.Native.Utils.make = function(elm) {
return Tuple2(posx, posy);
}
function checkPorts(moduleName, ports) {
var expected = {};
for (var i = ports.length; i--; ) {
expected[ports[i]] = 1;
}
for (var key in elm.ports_in) {
expected[key] = expected[key] || 0;
expected[key] -= 1;
}
var missing = [];
var extra = [];
for (var key in expected) {
var result = expected[key];
if (result > 0) missing.push(key);
if (result < 0) extra.push(key);
}
if (missing.length > 0) {
throw new Error("Module " + moduleName + " requires inputs for these ports: " + missing.join(', '));
}
if (extra.length > 0) {
throw new Error("Module " + moduleName + " has been given ports that do not exist: " + extra.join(', '));
}
}
return elm.Native.Utils.values = {
eq:eq,
cmp:cmp,
@ -226,6 +250,7 @@ Elm.Native.Utils.make = function(elm) {
mod : F2(mod),
htmlHeight: F2(htmlHeight),
getXY: getXY,
toFloat: function(x) { return +x; }
toFloat: function(x) { return +x; },
checkPorts: checkPorts
};
};

19
runtime/Init.js
View file

@ -2,7 +2,7 @@
(function() {
'use strict';
Elm.fullscreen = function(module) {
Elm.fullscreen = function(module, ports) {
var style = document.createElement('style');
style.type = 'text/css';
style.innerHTML = "html,head,body { padding:0; margin:0; }" +
@ -10,24 +10,24 @@ Elm.fullscreen = function(module) {
document.head.appendChild(style);
var container = document.createElement('div');
document.body.appendChild(container);
return init(ElmRuntime.Display.FULLSCREEN, container, module);
return init(ElmRuntime.Display.FULLSCREEN, container, module, ports);
};
Elm.embed = function(module, container) {
Elm.embed = function(module, container, ports) {
var tag = container.tagName;
if (tag !== 'DIV') {
throw new Error('Elm.node must be given a DIV, not a ' + tag + '.');
} else if (container.hasChildNodes()) {
throw new Error('Elm.node must be given an empty DIV. No children allowed!');
}
return init(ElmRuntime.Display.COMPONENT, container, module);
return init(ElmRuntime.Display.COMPONENT, container, module, ports);
};
Elm.worker = function(module) {
return init(ElmRuntime.Display.NONE, {}, module);
Elm.worker = function(module, ports) {
return init(ElmRuntime.Display.NONE, {}, module, ports);
};
function init(display, container, module, moduleToReplace) {
function init(display, container, module, moduleToReplace, ports) {
// defining state needed for an instance of the Elm RTS
var inputs = [];
@ -67,7 +67,8 @@ function init(display, container, module, moduleToReplace) {
display:display,
id:ElmRuntime.guid(),
addListener:addListener,
inputs:inputs
inputs:inputs,
ports_in:ports
};
// Set up methods to communicate with Elm program from JS.
@ -123,7 +124,7 @@ function init(display, container, module, moduleToReplace) {
}
reportAnyErrors();
return { send:send, recv:recv, swap:swap };
return { send:send, recv:recv, swap:swap, ports:elm.ports_out };
};
function filterListeners(inputs, listeners) {