740702c · elk · git.iko.soy

compiler/Build/Source.hs+1−2

compare with master

unifiedsplit

@@ -56,8 +56,7 @@ build noPrelude interfaces source =

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,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/Generate/JavaScript.hs+5−25

@@ -299,10 +299,9 @@ 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+ , concatMap jsPort (ports modul)

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

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

305− , map exportEvent $ foreignExports modul

306 , [ jsExports ]

305 , [ jsExports ]

307 , [ ReturnStmt () (Just thisModule) ]

306 , [ ReturnStmt () (Just thisModule) ]

308 ]

307 ]

@@ -332,29 +331,10 @@ generate unsafeModule =

332

331

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

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

334

333

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

334+ jsPort (name, _, maybe) =

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

335+ case maybe of

337− , ExprStmt () $

336+ Nothing -> error "in-ports are not defined yet"

338− obj "document.addEventListener" `call`

337+ Just expr -> error "out-ports are not defined yet"

339− [ addId js

340− , function ["_e"]

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

342− ]

343− ]

344−

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 ]

358

338

359binop span op e1 e2 =

339binop span op e1 e2 =

360 case op of

340 case op of

compiler/Parse/Declaration.hs+20−64

@@ -15,7 +15,7 @@ import qualified SourceSyntax.Declaration as D

15

16

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

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

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

19

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

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

@@ -56,67 +56,23 @@ infixDecl = do

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

57

58

59−foreignDef :: IParser (D.Declaration t v)

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

60−foreignDef = do

60+port =

61− try (reserved "foreign")

62− whitespace

63− importEvent <|> exportEvent

64−

65−exportEvent :: IParser (D.Declaration t v)

66−exportEvent = do

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

61+ do try (reserved "port")

68− eventName <- jsVar

69− whitespace

62+ whitespace

70− elmVar <- lowVar

63+ name <- lowVar

71− padded hasType

64+ padded hasType

72− tipe <- Type.expr

65+ tipe <- Type.expr

73− case tipe of

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

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

75− case isExportable t of

76− Nothing -> return (D.ExportEvent eventName elmVar tipe)

77− Just err -> fail err

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

79−

80−importEvent :: IParser (D.Declaration t v)

81−importEvent = do

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

83− eventName <- jsVar

84− baseValue <- padded Expr.term

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

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

87− padded hasType

67+ padded equals

88− tipe <- Type.expr

68+ Just <$> Expr.expr

89− case tipe of

69+ , return Nothing

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

70+ ]

91− case isExportable t of

71+ return $ D.Port name tipe expr

92− Nothing -> return (D.ImportEvent eventName baseValue elmVar tipe)

93− Just err -> fail err

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

95−

96−jsVar :: IParser String

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

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

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

100− fail $ "'" ++ v ++

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

102−

103−isExportable tipe =

104− case tipe of

105− T.Lambda _ _ ->

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

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

108−

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

110−

111− T.Data name []

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

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

114−

115− T.Data name _ ->

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

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

118−

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

120 where

72 where

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

73+ outPort name = do

122− 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/SourceSyntax/Declaration.hs+14−6

@@ -10,8 +10,7 @@ data Declaration tipe var

10 = Definition (Expr.Def tipe var)

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

12 | TypeAlias String [String] Type [Derivation]

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

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

14− | ExportEvent String String Type

15 | Fixity Assoc Int String

14 | Fixity Assoc Int String

16 deriving (Eq, Show)

15 deriving (Eq, Show)

17

16

@@ -60,11 +59,20 @@ instance Pretty (Declaration t v) where

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

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

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

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

62

61

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

62+ Port name tipe maybeExpr ->

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

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

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

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

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

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"

74+

75+prettyDeriving :: [Derivation] -> Doc

68prettyDeriving deriveables =

76prettyDeriving deriveables =

69 case deriveables of

77 case deriveables of

70 [] -> P.empty

78 [] -> P.empty

compiler/SourceSyntax/Module.hs+1−2

@@ -51,8 +51,7 @@ data MetadataModule t v = MetadataModule {

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

52 aliases :: [Alias],

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

compiler/Transform/Canonicalize.hs+6−10

@@ -57,20 +57,16 @@ metadataModule ifaces modul =

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

58 program' <- rename initialEnv (program modul)

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

60− datatypes' <- mapM (threeOfFour (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

71− threeOfFour f (a,b,c,d) =

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

72− do c' <- f c

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

74 twoAndFour f g (a,b,c,d) =

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

75 do b' <- f b

71 do b' <- f b

76 d' <- g d

72 d' <- g d

compiler/Transform/SafeNames.hs+3−6

@@ -69,10 +69,7 @@ metadataModule modul =

69 , datatypes =

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/Constrain/Declaration.hs+4−6

@@ -53,12 +53,10 @@ toDefs decl =

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

54 TypeAlias _ _ _ _ -> []

55

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

56+ Port name tipe maybe ->

57− [ Src.TypeAnnotation name tipe

57+ Src.TypeAnnotation name tipe : case maybe of

58+ Nothing -> []

58− , 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 ]

59−

60− ExportEvent _ name tipe ->

61− [ Src.TypeAnnotation name tipe ]

62

60

63 -- no constraints are needed for fixity declarations

61 -- no constraints are needed for fixity declarations

64 Fixity _ _ _ -> []

62 Fixity _ _ _ -> []