cbe557d · elk · git.iko.soy

elm-compiler.cabal+2−2

compare with master

unifiedsplit

@@ -63,17 +63,17 @@ Library

63 Elm.Compiler.Type.Extract,

64 Elm.Compiler.Version,

65 Generate.JavaScript,

66− Generate.JavaScript.Foreign,

67 Generate.JavaScript.Helpers,

66 Generate.JavaScript.Helpers,

67+ Generate.JavaScript.Port,

68 Generate.JavaScript.Variable,

69 Generate.Cases,

70 Transform.AddDefaultImports,

71 Transform.Canonicalize,

72 Transform.Canonicalize.Environment,

73+ Transform.Canonicalize.Port,

73 Transform.Canonicalize.Setup,

74 Transform.Canonicalize.Setup,

74 Transform.Canonicalize.Type,

75 Transform.Canonicalize.Type,

75 Transform.Canonicalize.Variable,

76 Transform.Canonicalize.Variable,

76− Transform.Canonicalize.Wire,

77 Transform.Check,

78 Transform.Expression,

79 Transform.Declaration,

src/AST/Declaration.hs+9−103

@@ -13,11 +13,11 @@ import Text.PrettyPrint as P

13

14-- DECLARATIONS

15

16−data Declaration' wire def var

16+data Declaration' portType def var

17 = Definition def

18 | Datatype String [String] [(String, [T.Type var])]

19 | TypeAlias String [String] (T.Type var)

20− | Wire wire

20+ | Port String portType

21 | Fixity Assoc Int String

22

23

@@ -28,48 +28,15 @@ data Assoc = L | N | R

28-- DECLARATION PHASES

29

30type SourceDecl =

31− Declaration' RawWire Source.Def Var.Raw

31+ Declaration' T.RawType Source.Def Var.Raw

32

33

34type ValidDecl =

35− Declaration' ValidWire Valid.Def Var.Raw

35+ Declaration' T.RawType Valid.Def Var.Raw

36

37

38type CanonicalDecl =

39− Declaration' CanonicalWire Canonical.Def Var.Canonical

39+ Declaration' (T.PortType Var.Canonical) Canonical.Def Var.Canonical

40−

41−

42−-- WIRES

43−

44−data RawWire

45− = InputAnnotation String T.RawType

46− | OutputAnnotation String T.RawType

47− | OutputDefinition String Source.Expr

48− | LoopbackAnnotation String T.RawType

49− | LoopbackDefinition String Source.Expr

50−

51−

52−data Wire expr var input

53− = Input String (T.Type var)

54− | Output String expr (T.Type var)

55− | Loopback input

56−

57−

58−data ValidLoopback =

59− ValidLoopback String (Maybe Valid.Expr) T.RawType

60−

61−

62−data CanonicalLoopback

63− = Address String T.CanonicalType

64− | Task String T.CanonicalType Canonical.Expr T.CanonicalType

65−

66−

67−type ValidWire =

68− Wire Valid.Expr Var.Raw ValidLoopback

69−

70−

71−type CanonicalWire =

72− Wire Canonical.Expr Var.Canonical CanonicalLoopback

73

40

74

41

75-- BINARY CONVERSION

42-- BINARY CONVERSION

@@ -101,8 +68,8 @@ assocToString assoc =

101 R -> "right"

68 R -> "right"

102

69

103

70

104−instance (Pretty wire, Pretty def, Pretty var, Var.ToString var) =>

71+instance (Pretty portType, Pretty def, Pretty var, Var.ToString var) =>

105− Pretty (Declaration' wire def var) where

72+ Pretty (Declaration' portType def var) where

106 pretty decl =

73 pretty decl =

107 case decl of

74 case decl of

108 Definition def -> pretty def

75 Definition def -> pretty def

@@ -128,7 +95,8 @@ instance (Pretty wire, Pretty def, Pretty var, Var.ToString var) =>

128 name' =

95 name' =

129 P.text name <+> P.hsep (map P.text tvars)

96 P.text name <+> P.hsep (map P.text tvars)

130

97

131− Wire wire -> pretty wire

98+ Port name tipe ->

99+ P.text "port" <+> P.text name <+> P.colon <+> pretty tipe

132

100

133 Fixity assoc prec op ->

101 Fixity assoc prec op ->

134 P.text "infix" <> assoc' <+> P.int prec <+> P.text op

102 P.text "infix" <> assoc' <+> P.int prec <+> P.text op

@@ -138,65 +106,3 @@ instance (Pretty wire, Pretty def, Pretty var, Var.ToString var) =>

138 L -> P.text "l"

106 L -> P.text "l"

139 N -> P.empty

107 N -> P.empty

140 R -> P.text "r"

108 R -> P.text "r"

141−

142−

143−instance Pretty RawWire where

144− pretty wire =

145− case wire of

146− InputAnnotation name tipe ->

147− prettyWire "foreign input" name ":" tipe

148−

149− OutputAnnotation name tipe ->

150− prettyWire "foreign output" name ":" tipe

151−

152− OutputDefinition name expr ->

153− prettyWire "foreign output" name "=" expr

154−

155− LoopbackAnnotation name tipe ->

156− prettyWire "input" name ":" tipe

157−

158− LoopbackDefinition name expr ->

159− prettyWire "input" name "from" expr

160−

161−

162−instance (Pretty expr, Pretty var, Var.ToString var, Pretty input) =>

163− Pretty (Wire expr var input) where

164− pretty wire =

165− case wire of

166− Input name tipe ->

167− prettyWire "foreign input" name ":" tipe

168−

169− Output name expr tipe ->

170− P.vcat

171− [ prettyWire "foreign output" name ":" tipe

172− , prettyWire "foreign output" name "=" expr

173− ]

174−

175− Loopback input ->

176− pretty input

177−

178−

179−instance Pretty ValidLoopback where

180− pretty (ValidLoopback name maybeExpr tipe) =

181− P.vcat

182− [ prettyWire "input" name ":" tipe

183− , maybe P.empty (prettyWire "input" name "with") maybeExpr

184− ]

185−

186−

187−instance Pretty CanonicalLoopback where

188− pretty input =

189− case input of

190− Address name tipe ->

191− prettyWire "input" name ":" tipe

192−

193− Task name _taskType expr resultType ->

194− P.vcat

195− [ prettyWire "input" name ":" resultType

196− , prettyWire "input" name "with" expr

197− ]

198−

199−

200−prettyWire :: (Pretty a) => String -> String -> String -> a -> Doc

201−prettyWire keyword name op e =

202− P.text keyword <+> P.text name <+> P.text op <+> pretty e

src/AST/Expression/General.hs+4−22

@@ -10,7 +10,7 @@ module AST.Expression.General where

10

11import AST.PrettyPrint

12import Text.PrettyPrint as P

13−import AST.Type (Type)

13+import AST.Type (Type, PortType)

14

15import qualified AST.Annotation as Annotation

16import qualified AST.Helpers as Help

@@ -58,20 +58,11 @@ data Expr' ann def var

58 | Modify (Expr ann def var) [(String, Expr ann def var)]

59 | Record [(String, Expr ann def var)]

60 -- for type checking and code gen only

61− | Input String (Type var)

61+ | Port String (PortType var)

62− | Output String (Type var) (Expr ann def var)

63− | LoopbackIn String Source

64− | LoopbackOut String (Expr ann def var)

65 | GLShader String String Literal.GLShaderTipe

62 | GLShader String String Literal.GLShaderTipe

66 deriving (Show)

63 deriving (Show)

67

64

68

65

69−data Source

70− = Address

71− | TaskStream

72− deriving (Show)

73−

74−

75---- UTILITIES ----

66---- UTILITIES ----

76

67

77rawVar :: String -> Expr' ann def Var.Raw

68rawVar :: String -> Expr' ann def Var.Raw

@@ -202,17 +193,8 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

202 GLShader _ _ _ ->

193 GLShader _ _ _ ->

203 P.text "[glsl| ... |]"

194 P.text "[glsl| ... |]"

204

195

205− Input name _ ->

206− P.text ("<input:" ++ name ++ ">")

207−

208− Output name _ _ ->

209− P.text ("<output:" ++ name ++ ">")

210−

211− LoopbackIn name _ ->

196+ Port name _ ->

212− P.text ("<loopback-in:" ++ name ++ ">")

197+ P.text ("<port:" ++ name ++ ">")

213−

214− LoopbackOut name _ ->

215− P.text ("<loopback-out:" ++ name ++ ">")

216

198

217

199

218collectApps :: Expr ann def var -> [Expr ann def var]

200collectApps :: Expr ann def var -> [Expr ann def var]

src/AST/Type.hs+33−2

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

1module AST.Type

2− ( Type(..), RawType, CanonicalType

2+ ( Type(..), RawType, CanonicalType, PortType(..)

3− , fieldMap, recordOf, listOf, tupleOf

3+ , portTypeToType, fieldMap, recordOf, listOf, tupleOf

4 , deepDealias, dealias

5 , collectLambdas

6 , prettyParens

@@ -37,6 +37,24 @@ type CanonicalType =

37 Type Var.Canonical

38

39

40+data PortType var

41+ = Inbound (Type var)

42+ | Internal (Type var)

43+ | Outbound (Type var)

44+ deriving (Show)

45+

46+

47+portTypeToType :: PortType Var.Canonical -> CanonicalType

48+portTypeToType portType =

49+ let makeType name tipe =

50+ App (Type (Var.fromModule ["Port"] name)) [tipe]

51+ in

52+ case portType of

53+ Inbound tipe -> makeType "InboundPort" tipe

54+ Internal tipe -> makeType "Port" tipe

55+ Outbound tipe -> makeType "OutboundPort" tipe

56+

57+

40fieldMap :: [(String,a)] -> Map.Map String [a]

58fieldMap :: [(String,a)] -> Map.Map String [a]

41fieldMap fields =

59fieldMap fields =

42 let add r (field,tipe) =

60 let add r (field,tipe) =

@@ -119,6 +137,19 @@ replace typeTable t =

119

137

120-- PRETTY PRINTING

138-- PRETTY PRINTING

121

139

140+instance (Pretty var, Var.ToString var) => Pretty (PortType var) where

141+ pretty portType =

142+ case portType of

143+ Inbound tipe ->

144+ P.text "InboundPort" <+> pretty tipe

145+

146+ Internal tipe ->

147+ P.text "Port" <+> pretty tipe

148+

149+ Outbound tipe ->

150+ P.text "OutboundPort" <+> pretty tipe

151+

152+

122instance (Var.ToString var, Pretty var) => Pretty (Type var) where

153instance (Var.ToString var, Pretty var) => Pretty (Type var) where

123 pretty tipe =

154 pretty tipe =

124 case tipe of

155 case tipe of

src/AST/Variable.hs−25

@@ -63,31 +63,6 @@ isArray =

63 is ["Array"] "Array"

64

65

66−isStream :: Canonical -> Bool

67−isStream =

68− is ["Signal"] "Stream"

69−

70−

71−isAddress :: Canonical -> Bool

72−isAddress =

73− is ["Stream"] "Address"

74−

75−

76−isVarying :: Canonical -> Bool

77−isVarying =

78− is ["Signal"] "Varying"

79−

80−

81−isTask :: Canonical -> Bool

82−isTask =

83− is ["Task"] "Task"

84−

85−

86−isResult :: Canonical -> Bool

87−isResult =

88− is ["Result"] "Result"

89−

90−

91isList :: Canonical -> Bool

66isList :: Canonical -> Bool

92isList v =

67isList v =

93 v == Canonical BuiltIn "List"

68 v == Canonical BuiltIn "List"

src/Docs.hs+1−1

@@ -211,7 +211,7 @@ collectInfo (comment, decl) info =

211 in

212 info { infixes = Map.insert name infixInfo (infixes info) }

213

214− Decl.Wire _ ->

214+ Decl.Port _ _ ->

215 error errorMessage

216

217

src/Generate/JavaScript.hs+10−17

@@ -11,7 +11,7 @@ import Language.ECMAScript3.Syntax

11

12import Generate.JavaScript.Helpers as Help

13import qualified Generate.Cases as Case

14−import qualified Generate.JavaScript.Foreign as Foreign

14+import qualified Generate.JavaScript.Port as Port

15import qualified Generate.JavaScript.Variable as Var

16

17import AST.Annotation

@@ -22,6 +22,7 @@ import qualified AST.Module as Module

22import qualified AST.Helpers as Help

23import AST.Literal

24import qualified AST.Pattern as P

25+import qualified AST.Type as T

25import qualified AST.Variable as Var

26import qualified AST.Variable as Var

26

27

28

@@ -30,7 +31,6 @@ internalImports name =

30 [ varDecl "_N" (obj ["Elm","Native"])

31 [ varDecl "_N" (obj ["Elm","Native"])

31 , include "_U" "Utils"

32 , include "_U" "Utils"

32 , include "_L" "List"

33 , include "_L" "List"

33− , include "_P" "Ports"

34 , varDecl Help.localModuleName (string (Module.nameToString name))

35 ]

36 where

@@ -207,24 +207,17 @@ expression (A region expr) =

207 GLShader _uid src _tipe ->

208 return $ ObjectLit () [(PropString () "src", literal (Str src))]

209

210− Input name tipe ->

210+ Port name portType ->

211+ case portType of

212+ T.Inbound tipe ->

211− return (Foreign.input name tipe)

213+ return (Port.inbound name tipe)

212

214

213− Output name tipe value ->

215+ T.Internal _ ->

214− do value' <- expression value

216+ return (Port.internal name)

215− return (Foreign.output name tipe value')

216−

217− LoopbackIn name source ->

218− case source of

219− Address ->

220− return $ obj ["_P","input"] `call` [ string name ]

221

217

222− TaskStream ->

218+ T.Outbound tipe ->

223− return $ obj ["_P","loopbackIn"] `call` [ string name ]

219+ return (Port.outbound name tipe)

224

220

225− LoopbackOut name expr ->

226− do expr' <- expression expr

227− return $ obj ["_P","loopbackOut"] `call` [ string name, expr' ]

228

221

229

222

230definition :: Canonical.Def -> State Int [Statement ()]

223definition :: Canonical.Def -> State Int [Statement ()]

src/Generate/JavaScript/Foreign.hs → src/Generate/JavaScript/Port.hsrenamed+22−36

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

1−module Generate.JavaScript.Foreign (input, output) where

1+module Generate.JavaScript.Port (inbound, internal, outbound) where

2

3import qualified Data.List as List

4import Generate.JavaScript.Helpers

@@ -42,6 +42,11 @@ _Maybe functionName =

42 useLazy ["Elm","Maybe"] functionName

43

44

45+_Port :: String -> Expression ()

46+_Port functionName =

47+ useLazy ["Elm","Native","Port"] functionName

48+

49+

45check :: Expression () -> JSType -> Expression () -> Expression ()

50check :: Expression () -> JSType -> Expression () -> Expression ()

46check x jsType continue =

51check x jsType continue =

47 CondExpr () (jsFold OpLOr checks x) continue throw

52 CondExpr () (jsFold OpLOr checks x) continue throw

@@ -62,26 +67,22 @@ check x jsType continue =

62 [jsFold OpLAnd (typeof "object" : map member fields)]

67 [jsFold OpLAnd (typeof "object" : map member fields)]

63

68

64

69

65−-- INPUT

70+-- INTERNAL

66

71

67−input :: String -> CanonicalType -> Expression ()

72+internal :: String -> Expression ()

68−input name tipe =

73+internal name =

69− let args t =

74+ _Port "port" `call` [ string name ]

70− [ string name, string (show (pretty t)), toTypeFunction t ]

71− in

72− case tipe of

73− Aliased _ args t ->

74− input name (dealias args t)

75

76− App (Type signal) [t]

77− | Var.isStream signal ->

78− obj ["_P","inputStream"] `call` args t

79

76

80− | Var.isVarying signal ->

77+-- INBOUND

81− obj ["_P","inputVarying"] `call` args t

82

78

83− _ ->

79+inbound :: String -> CanonicalType -> Expression ()

84− obj ["_P","inputValue"] `call` args tipe

80+inbound name tipe =

81+ _Port "inbound" `call`

82+ [ string name

83+ , string (show (pretty tipe))

84+ , toTypeFunction tipe

85+ ]

85

86

87

87toTypeFunction :: CanonicalType -> Expression ()

88toTypeFunction :: CanonicalType -> Expression ()

@@ -169,26 +170,11 @@ toTuple types x =

169 )

170 )

170

171

172

172−-- OUTPUT

173+-- OUTBOUND

173−

174−output :: String -> CanonicalType -> Expression () -> Expression ()

175−output name tipe value =

176− let args t =

177− [ string name, fromTypeFunction t, value ]

178− in

179− case tipe of

180− Aliased _ args t ->

181− output name (dealias args t) value

182−

183− App (Type signal) [t]

184− | Var.isStream signal ->

185− obj ["_P","outputStream"] `call` args t

186−

187− | Var.isVarying signal ->

188− obj ["_P","outputVarying"] `call` args t

189

174

190− _ ->

175+outbound :: String -> CanonicalType -> Expression ()

191− obj ["_P","outputValue"] `call` args tipe

176+outbound name tipe =

177+ _Port "outbound" `call` [ string name, fromTypeFunction tipe ]

192

178

193

179

194fromTypeFunction :: CanonicalType -> Expression ()

180fromTypeFunction :: CanonicalType -> Expression ()

src/Parse/Declaration.hs+6−37

@@ -12,7 +12,7 @@ import qualified Parse.Type as Type

12

13declaration :: IParser D.SourceDecl

14declaration =

15− typeDecl <|> infixDecl <|> foreign <|> input <|> definition

15+ typeDecl <|> infixDecl <|> port <|> definition

16

17

18definition :: IParser D.SourceDecl

@@ -54,42 +54,11 @@ infixDecl =

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

55

56

57−foreign :: IParser D.SourceDecl

57+port :: IParser D.SourceDecl

58−foreign =

58+port =

59− do try (reserved "foreign")

59+ do try (reserved "port")

60− whitespace

61− choice

62− [ do name <- wireBegining "input"

63− wireEnding (D.InputAnnotation name) hasType Type.expr

64− , do name <- wireBegining "output"

65− choice

66− [ wireEnding (D.OutputAnnotation name) hasType Type.expr

67− , wireEnding (D.OutputDefinition name) equals Expr.expr

68− ]

69− ]

70−

71−

72−input :: IParser D.SourceDecl

73−input =

74− do name <- wireBegining "input"

75− choice

76− [ wireEnding (D.LoopbackAnnotation name) hasType Type.expr

77− , wireEnding (D.LoopbackDefinition name) (string "from") Expr.expr

78− ]

79−

80−

81−wireBegining :: String -> IParser String

82−wireBegining keyword =

83− do try (reserved keyword)

84 whitespace

60 whitespace

85 name <- lowVar

61 name <- lowVar

86 whitespace

62 whitespace

87− return name

63+ tipe <- Type.expr <?> "a type"

88−

64+ return (D.Port name tipe)

89−

90−wireEnding :: (a -> D.RawWire) -> IParser String -> IParser a -> IParser D.SourceDecl

91−wireEnding makeWire op valueParser =

92− do op

93− whitespace

94− value <- valueParser

95− return (D.Wire (makeWire value))

src/Parse/Helpers.hs+1−2

@@ -31,9 +31,8 @@ reserveds =

31 , "type"

32 , "module", "where"

33 , "import", "as", "hiding", "exposing"

34− , "export"

34+ , "port", "export", "foreign"

35 , "deriving"

36− , "input", "output", "foreign"

37 ]

36 ]

38

37

39

38

src/Transform/Canonicalize.hs+12−40

@@ -26,7 +26,7 @@ import qualified Transform.Canonicalize.Environment as Env

26import qualified Transform.Canonicalize.Setup as Setup

27import qualified Transform.Canonicalize.Type as Canonicalize

28import qualified Transform.Canonicalize.Variable as Canonicalize

29−import qualified Transform.Canonicalize.Wire as Wire

29+import qualified Transform.Canonicalize.Port as Port

30import qualified Transform.SortDefinitions as Transform

31import qualified Transform.Declaration as Transform

32

@@ -77,17 +77,9 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

77 , aliases =

78 Map.fromList [ (name,(tvs,alias)) | D.TypeAlias name tvs alias <- decls ]

79 , ports =

80− [ wireName wire | D.Wire wire <- decls ]

80+ [ name | D.Port name _ <- decls ]

81 }

82

83− wireName :: D.CanonicalWire -> String

84− wireName wire =

85− case wire of

86− D.Input name _ -> name

87− D.Output name _ _ -> name

88− D.Loopback (D.Address name _) -> name

89− D.Loopback (D.Task name _ _ _) -> name

90−

91

83

92resolveExports

84resolveExports

93 :: [Var.Value]

85 :: [Var.Value]

@@ -210,27 +202,12 @@ declaration env decl =

210 do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

202 do expanded' <- canonicalize Canonicalize.tipe "type alias" name env expanded

211 return (D.TypeAlias name tvars expanded')

203 return (D.TypeAlias name tvars expanded')

212

204

213− D.Wire wire ->

205+ D.Port name tipe ->

214 do Env.uses ["Native","Ports"]

206 do Env.uses ["Native","Ports"]

215 Env.uses ["Native","Json"]

207 Env.uses ["Native","Json"]

216− D.Wire <$>

208+ tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

217− case wire of

209+ portType <- Port.check name tipe'

218− D.Input name tipe ->

210+ return $ D.Port name portType

219− do tipe' <- canonicalize Canonicalize.tipe "foreign input" name env tipe

220− Wire.checkForeignInput name tipe'

221− return (D.Input name tipe')

222−

223− D.Output name expr tipe ->

224− do expr' <- expression env expr

225− tipe' <- canonicalize Canonicalize.tipe "foreign output" name env tipe

226− Wire.checkForeignOutput name tipe'

227− return (D.Output name expr' tipe')

228−

229− D.Loopback (D.ValidLoopback name maybeExpr tipe) ->

230− do maybeExpr' <- T.traverse (expression env) maybeExpr

231− tipe' <- canonicalize Canonicalize.tipe "input" name env tipe

232− input' <- Wire.input name maybeExpr' tipe'

233− return (D.Loopback input')

234

211

235 D.Fixity assoc prec op ->

212 D.Fixity assoc prec op ->

236 return $ D.Fixity assoc prec op

213 return $ D.Fixity assoc prec op

@@ -322,17 +299,12 @@ expression env (A.A ann validExpr) =

322 (,) <$> format (pattern env p)

299 (,) <$> format (pattern env p)

323 <*> expression (Env.addPattern p env) b

300 <*> expression (Env.addPattern p env) b

324

301

325− Input name tipe ->

302+ Port name portType ->

326− Input name <$> tipe' env tipe

303+ Port name <$>

327−

304+ case portType of

328− Output name tipe expr ->

305+ Type.Inbound tipe -> Type.Inbound <$> tipe' env tipe

329− Output name <$> tipe' env tipe <*> go expr

306+ Type.Internal tipe -> Type.Internal <$> tipe' env tipe

330−

307+ Type.Outbound tipe -> Type.Outbound <$> tipe' env tipe

331− LoopbackIn name source ->

332− return (LoopbackIn name source)

333−

334− LoopbackOut name expr ->

335− LoopbackOut name <$> go expr

336

308

337 GLShader uid src tipe ->

309 GLShader uid src tipe ->

338 return (GLShader uid src tipe)

310 return (GLShader uid src tipe)

src/Transform/Canonicalize/Port.hsnew file+144

@@ -0,0 +1,144 @@

1+module Transform.Canonicalize.Port (check) where

2+

3+import Control.Applicative ((<$>))

4+import Control.Monad.Error (throwError)

5+import Text.PrettyPrint as P

6+

7+import qualified AST.PrettyPrint as PP

8+import qualified AST.Type as T

9+import qualified AST.Variable as Var

10+import qualified Transform.Canonicalize.Environment as Env

11+

12+

13+throw :: [Doc] -> Env.Canonicalizer [P.Doc] a

14+throw err =

15+ throwError [ P.vcat err ]

16+

17+

18+-- CHECK FOR PORT

19+

20+check

21+ :: String

22+ -> T.CanonicalType

23+ -> Env.Canonicalizer [P.Doc] (T.PortType Var.Canonical)

24+check name tipe =

25+ checkHelp name tipe tipe

26+

27+

28+checkHelp

29+ :: String

30+ -> T.CanonicalType

31+ -> T.CanonicalType

32+ -> Env.Canonicalizer [P.Doc] (T.PortType Var.Canonical)

33+checkHelp name rootType tipe =

34+ case tipe of

35+ T.Aliased alias _ arg

36+ | Var.is ["Port"] "Port" alias ->

37+ return (T.Internal arg)

38+

39+ | Var.is ["Port"] "InboundPort" alias ->

40+ do validForeignType name In arg arg

41+ return (T.Inbound arg)

42+

43+ | Var.is ["Port"] "OutboundPort" alias ->

44+ do validForeignType name Out arg arg

45+ return (T.Outbound arg)

46+

47+ | otherwise ->

48+ checkHelp name rootType arg

49+

50+ _ ->

51+ throw $

52+ [ P.text "Port Error:"

53+ , P.nest 4 $

54+ P.vcat $

55+ [ P.text ("The port named '" ++ name ++ "' has an invalid type.\n")

56+ , P.nest 4 (PP.pretty tipe) <> P.text "\n"

57+ , P.text "It must be a Port, InboundPort, or OutboundPort."

58+ , P.text "See the Port module for more details:"

59+ , P.text "<http://package.elm-lang.org/packages/elm-lang/core/latest/Port>"

60+ ]

61+ ]

62+

63+

64+-- CHECK INBOUND AND OUTBOUND TYPES

65+

66+data Direction = In | Out

67+

68+

69+validForeignType

70+ :: String

71+ -> Direction

72+ -> T.CanonicalType

73+ -> T.CanonicalType

74+ -> Env.Canonicalizer [P.Doc] ()

75+validForeignType name portKind rootType tipe =

76+ let valid localType =

77+ validForeignType name portKind rootType localType

78+

79+ err hint =

80+ throw (foreignError name portKind rootType tipe hint)

81+ in

82+ case tipe of

83+ T.Aliased _ args t ->

84+ valid (T.dealias args t)

85+

86+ T.Type v ->

87+ case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

88+ True -> return ()

89+ False -> err "It contains an unsupported type"

90+

91+ T.App t [] ->

92+ valid t

93+

94+ T.App (T.Type v) [t]

95+ | Var.isMaybe v -> valid t

96+ | Var.isArray v -> valid t

97+ | Var.isList v -> valid t

98+

99+ T.App (T.Type v) ts

100+ | Var.isTuple v -> mapM_ valid ts

101+

102+ T.App _ _ ->

103+ err "It contains an unsupported type"

104+

105+ T.Var _ ->

106+ err "It contains a free type variable"

107+

108+ T.Lambda _ _ ->

109+ err "It contains functions"

110+

111+ T.Record _ (Just _) ->

112+ err "It contains extended records with free type variables"

113+

114+ T.Record fields Nothing ->

115+ mapM_ (\(k,v) -> (,) k <$> valid v) fields

116+

117+

118+foreignError

119+ :: String

120+ -> Direction

121+ -> T.CanonicalType

122+ -> T.CanonicalType

123+ -> String

124+ -> [P.Doc]

125+foreignError name portKind rootType localType problemMessage =

126+ [ P.text ("Port Error:")

127+ , P.nest 4 $

128+ P.vcat

129+ [ txt [ "The ", port, " named '", name, "' has an invalid type.\n" ]

130+ , P.nest 4 (PP.pretty rootType) <> P.text "\n"

131+ , txt [ problemMessage, ":\n" ]

132+ , P.nest 4 (PP.pretty localType) <> P.text "\n"

133+ , txt [ "Acceptable values for ", port, "s include:" ]

134+ , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays," ]

135+ , txt [ " Tuples, unit values, Json.Values, and concrete records." ]

136+ ]

137+ ]

138+ where

139+ port =

140+ case portKind of

141+ In -> "inbound port"

142+ Out -> "outbound port"

143+

144+ txt = P.text . concat

src/Transform/Canonicalize/Setup.hs+7−17

@@ -245,16 +245,12 @@ addTypeAlias moduleName env scc =

245 ]

246

247

248−typeAlias

249− :: (String, [String], Type.Type var)

248+typeAlias :: (String, [String], Type.Type var) -> D.Declaration' pk def var

250− -> D.Declaration' wire def var

251typeAlias (n,ts,t) =

249typeAlias (n,ts,t) =

252 D.TypeAlias n ts t

250 D.TypeAlias n ts t

253

251

254

252

255−datatype

256− :: (String, [String], Type.Type var)

253+datatype :: (String, [String], Type.Type var) -> D.Declaration' pk def var

257− -> D.Declaration' wire def var

258datatype (n,ts,t) =

254datatype (n,ts,t) =

259 D.Datatype n ts [(n,[t])]

255 D.Datatype n ts [(n,[t])]

260

256

@@ -326,17 +322,11 @@ addDecl moduleName info@(nodes,env) decl =

326 _values env

322 _values env

327 }

323 }

328

324

329− D.Wire wire ->

330− let wireName =

331− case wire of

332− D.Input name _ -> name

325+ D.Port name _ ->

333− D.Output name _ _ -> name

334− D.Loopback (D.ValidLoopback name _ _) -> name

335− in

336− (,) nodes $ env

326+ (,) nodes $ env

337− { _values =

327+ { _values =

338− addLocal wireName (_values env)

328+ addLocal name (_values env)

339− }

329+ }

340

330

341 D.Fixity _ _ _ ->

331 D.Fixity _ _ _ ->

342 info

332 info

src/Transform/Canonicalize/Wire.hsdeleted−207

@@ -1,207 +0,0 @@

1−module Transform.Canonicalize.Wire (checkForeignInput, checkForeignOutput, input) where

2−

3−import Control.Applicative ((<$>))

4−import Control.Monad.Error (forM_, throwError)

5−import Text.PrettyPrint as P

6−

7−import qualified AST.Declaration as D

8−import qualified AST.Expression.Canonical as Canonical

9−import qualified AST.PrettyPrint as PP

10−import qualified AST.Type as ST

11−import qualified AST.Variable as Var

12−import qualified Transform.Canonicalize.Environment as Env

13−

14−

15−throw :: [Doc] -> Env.Canonicalizer [P.Doc] a

16−throw err =

17− throwError [ P.vcat err ]

18−

19−

20−checkForeignInput :: String -> ST.CanonicalType -> Env.Canonicalizer [P.Doc] ()

21−checkForeignInput name tipe =

22− checkForeign In name tipe tipe

23−

24−

25−checkForeignOutput :: String -> ST.CanonicalType -> Env.Canonicalizer [P.Doc] ()

26−checkForeignOutput name tipe =

27− checkForeign Out name tipe tipe

28−

29−

30−data Direction = In | Out

31−

32−

33−checkForeign

34− :: Direction

35− -> String

36− -> ST.CanonicalType

37− -> ST.CanonicalType

38− -> Env.Canonicalizer [P.Doc] ()

39−checkForeign direction name rootType tipe =

40− case tipe of

41− ST.Aliased _ args t ->

42− checkForeign direction name rootType (ST.dealias args t)

43−

44− ST.App (ST.Type signal) [t]

45− | Var.isStream signal ->

46− validForeignType False (Just Stream) direction name rootType t

47−

48− | Var.isVarying signal ->

49− validForeignType False (Just Varying) direction name rootType t

50−

51− _ ->

52− validForeignType False Nothing direction name rootType tipe

53−

54−

55−data Signal = Stream | Varying

56−

57−

58−validForeignType

59− :: Bool

60− -> Maybe Signal

61− -> Direction

62− -> String

63− -> ST.CanonicalType

64− -> ST.CanonicalType

65− -> Env.Canonicalizer [P.Doc] ()

66−validForeignType seenFunc seenSignal direction name rootType tipe =

67− let valid localType =

68− validForeignType seenFunc seenSignal direction name rootType localType

69−

70− err kind =

71− throw (foreignError name direction rootType tipe kind)

72− in

73− case tipe of

74− ST.Aliased _ args t ->

75− valid (ST.dealias args t)

76−

77− ST.Type v ->

78− case any ($ v) [ Var.isJson, Var.isPrimitive, Var.isTuple ] of

79− True -> return ()

80− False -> err "It contains an unsupported type"

81−

82− ST.App t [] ->

83− valid t

84−

85− ST.App (ST.Type v) [t]

86− | Var.isMaybe v -> valid t

87− | Var.isArray v -> valid t

88− | Var.isList v -> valid t

89−

90− ST.App (ST.Type v) ts

91− | Var.isTuple v -> mapM_ valid ts

92−

93− ST.App _ _ ->

94− err "It contains an unsupported type"

95−

96− ST.Var _ ->

97− err "It contains a free type variable"

98−

99− ST.Lambda _ _ ->

100− case direction of

101− In -> err "It contains functions"

102− Out ->

103− if seenFunc

104− then err "It contains higher-order functions"

105− else

106− case seenSignal of

107− Just Stream ->

108− err "It is a streams that contains a function"

109−

110− Just Varying ->

111− err "It is a varying value that contains a function"

112−

113− Nothing ->

114− forM_ (ST.collectLambdas tipe)

115− (validForeignType True seenSignal direction name rootType)

116−

117− ST.Record _ (Just _) ->

118− err "It contains extended records with free type variables"

119−

120− ST.Record fields Nothing ->

121− mapM_ (\(k,v) -> (,) k <$> valid v) fields

122−

123−

124−foreignError

125− :: String

126− -> Direction

127− -> ST.CanonicalType

128− -> ST.CanonicalType

129− -> String

130− -> [P.Doc]

131−foreignError name direction rootType localType problemMessage =

132− [ P.text ("Foreign " ++ dir "Input" "Output" ++ " Error:")

133− , P.nest 4 $

134− P.vcat

135− [ txt [ "The foreign ", wire, " named '", name, "' has an invalid type.\n" ]

136− , P.nest 4 (PP.pretty rootType) <> P.text "\n"

137− , txt [ problemMessage, ":\n" ]

138− , P.nest 4 (PP.pretty localType) <> P.text "\n"

139− , txt [ "Acceptable values for foreign ", wire, "s include:" ]

140− , txt [ " Ints, Floats, Bools, Strings, Maybes, Lists, Arrays, Tuples, unit values," ]

141− , txt [ " Json.Values, ", dir "" "first-order functions, tasks, ", "and concrete records." ]

142− ]

143− ]

144− where

145− dir inMsg outMsg =

146− case direction of

147− In -> inMsg

148− Out -> outMsg

149−

150− txt = P.text . concat

151−

152− wire =

153− dir "input" "output"

154−

155−

156−input

157− :: String

158− -> Maybe Canonical.Expr

159− -> ST.CanonicalType

160− -> Env.Canonicalizer [P.Doc] D.CanonicalLoopback

161−input name maybeExpr tipe =

162− case maybeExpr of

163− Nothing ->

164− case ST.deepDealias tipe of

165− ST.Record

166− [ ("address", ST.App (ST.Type address) [a])

167− , ("stream", ST.App (ST.Type stream) [b])

168− ]

169− Nothing

170− | Var.isStream stream && Var.isAddress address && a == b ->

171− return (D.Address name tipe)

172−

173−

174− _ ->

175− throw $ inputError name tipe $

176− [ P.text "An input like this must be a Stream.Input" ]

177−

178− Just expr ->

179− case ST.deepDealias tipe of

180− ST.App (ST.Type signal) [ ST.App (ST.Type result) [failure,success] ]

181− | Var.isStream signal && Var.isResult result ->

182− let task =

183− Var.fromModule ["Task"] "Task"

184− taskType =

185− ST.App (ST.Type signal) [ ST.App (ST.Type task) [failure,success] ]

186− in

187− return (D.Task name taskType expr tipe)

188−

189− _ ->

190− throw $ inputError name tipe $

191− [ P.text "An input that runs tasks must be a stream of results."

192− , P.text "Something like the following:\n"

193− , P.text " Stream (Result Http.Error String)"

194− , P.text " Stream (Result x ())"

195− ]

196−

197−

198−inputError :: String -> ST.CanonicalType -> [Doc] -> [Doc]

199−inputError name tipe message =

200− [ P.text "Input Error:"

201− , P.nest 4 $

202− P.vcat $

203− [ P.text ("The input named '" ++ name ++ "' has an invalid type.\n")

204− , P.nest 4 (PP.pretty tipe) <> P.text "\n"

205− ]

206− ++ message

207− ]

src/Transform/Check.hs+3−9

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

1{-# OPTIONS_GHC -Wall #-}

2module Transform.Check (mistakes) where

3

4−import qualified Control.Arrow as Arrow

5import qualified Data.List as List

4import qualified Data.List as List

6import qualified Data.Maybe as Maybe

5import qualified Data.Maybe as Maybe

7import qualified Data.Set as Set

6import qualified Data.Set as Set

@@ -42,7 +41,7 @@ dups names =

42duplicateValues :: [D.ValidDecl] -> [String]

41duplicateValues :: [D.ValidDecl] -> [String]

43duplicateValues decls =

42duplicateValues decls =

44 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

43 map msg (dups (portNames ++ concatMap Pattern.boundVarList defPatterns)) ++

45− case mapM exprDups (portExprs ++ defExprs) of

44+ case mapM exprDups defExprs of

46 Left name -> [msg name]

45 Left name -> [msg name]

47 Right _ -> []

46 Right _ -> []

48

47

@@ -53,13 +52,8 @@ duplicateValues decls =

53 (defPatterns, defExprs) =

52 (defPatterns, defExprs) =

54 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

53 unzip [ (pat,expr) | D.Definition (Valid.Definition pat expr _) <- decls ]

55

54

56− (portNames, portExprs) =

55+ portNames =

57− Arrow.second Maybe.catMaybes $ unzip $

56+ [ name | D.Port name _ <- decls ]

58− flip map [ wire | D.Wire wire <- decls ] $ \wire ->

59− case wire of

60− D.Input name _ -> (name, Nothing)

61− D.Output name expr _ -> (name, Just expr)

62− D.Loopback (D.ValidLoopback name maybeExpr _) -> (name, maybeExpr)

63

57

64 exprDups :: Valid.Expr -> Either String Valid.Expr

58 exprDups :: Valid.Expr -> Either String Valid.Expr

65 exprDups expr =

59 exprDups expr =

src/Transform/Declaration.hs+5−52

@@ -44,6 +44,9 @@ combineAnnotations =

44 D.Fixity assoc prec op : rest ->

45 (:) (D.Fixity assoc prec op) <$> go rest

46

47+ D.Port name tipe : rest ->

48+ (:) (D.Port name tipe) <$> go rest

49+

47 -- combine definitions

50 -- combine definitions

48 D.Definition def : defRest ->

51 D.Definition def : defRest ->

49 case def of

52 case def of

@@ -62,38 +65,6 @@ combineAnnotations =

62

65

63 _ -> Left (errorMessage "value" name)

66 _ -> Left (errorMessage "value" name)

64

67

65− -- combine wires

66− D.Wire wire : wireRest ->

67− case wire of

68− D.InputAnnotation name tipe ->

69− (:) (D.Wire (D.Input name tipe)) <$> go wireRest

70−

71− D.OutputDefinition name _ ->

72− Left (errorMessage "foreign output" name)

73−

74− D.OutputAnnotation name tipe ->

75− case wireRest of

76− D.Wire (D.OutputDefinition name' expr) : rest | name == name' ->

77− do expr' <- exprCombineAnnotations expr

78− (:) (D.Wire (D.Output name expr' tipe)) <$> go rest

79−

80− _ ->

81− Left (errorMessage "foreign output" name)

82−

83− D.LoopbackDefinition name _tipe ->

84− Left (errorMessage "input" name)

85−

86− D.LoopbackAnnotation name tipe ->

87− case wireRest of

88− D.Wire (D.LoopbackDefinition name' expr) : rest | name == name' ->

89− do expr' <- exprCombineAnnotations expr

90− let loop = D.ValidLoopback name (Just expr') tipe

91− (:) (D.Wire (D.Loopback loop)) <$> go rest

92−

93− _ ->

94− do let loop = D.ValidLoopback name Nothing tipe

95− (:) (D.Wire (D.Loopback loop)) <$> go wireRest

96−

97

68

98toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

69toExpr :: Module.Name -> [D.CanonicalDecl] -> [Canonical.Def]

99toExpr moduleName =

70toExpr moduleName =

@@ -141,26 +112,8 @@ toDefs moduleName decl =

141 D.TypeAlias _ _ _ ->

112 D.TypeAlias _ _ _ ->

142 []

113 []

143

114

144− D.Wire wire ->

115+ D.Port name tipe ->

145− case wire of

146− D.Output name expr@(A.A s _) tipe ->

147− [ definition name (A.A s $ E.Output name tipe expr) tipe ]

148−

149− D.Input name tipe ->

150− [ definition name (A.none $ E.Input name tipe) tipe ]

116+ [ definition name (A.none $ E.Port name tipe) (T.portTypeToType tipe) ]

151−

152− D.Loopback input ->

153− case input of

154− D.Address name tipe ->

155− [ definition name (A.none $ E.LoopbackIn name E.Address) tipe ]

156−

157− D.Task name taskType expr resultType ->

158− let dummyName =

159− "$" ++ name ++ "$effect"

160− in

161− [ definition name (A.none $ E.LoopbackIn name E.TaskStream) resultType

162− , definition dummyName (A.none $ E.LoopbackOut name expr) taskType

163− ]

164

117

165 -- no constraints are needed for fixity declarations

118 -- no constraints are needed for fixity declarations

166 D.Fixity _ _ _ ->

119 D.Fixity _ _ _ ->

src/Transform/Expression.hs+2−11

@@ -69,14 +69,5 @@ crawlLet defsTransform annotatedExpression =

69 GLShader uid src gltipe ->

70 return $ GLShader uid src gltipe

71

72− Input name tipe ->

72+ Port name tipe ->

73− return $ Input name tipe

74−

75− Output name tipe expr ->

76− Output name tipe <$> go expr

73+ return $ Port name tipe

77−

78− LoopbackIn name source ->

79− return (LoopbackIn name source)

80−

81− LoopbackOut name expr ->

82− LoopbackOut name <$> go expr

src/Transform/SortDefinitions.hs+2−11

@@ -115,17 +115,8 @@ reorder (A ann expression) =

115 GLShader _ _ _ ->

116 return expression

117

118− Input name tipe ->

118+ Port name tipe ->

119− return $ Input name tipe

119+ return $ Port name tipe

120−

121− Output name tipe signal ->

122− Output name tipe <$> reorder signal

123−

124− LoopbackIn name source ->

125− return $ LoopbackIn name source

126−

127− LoopbackOut name expr ->

128− LoopbackOut name <$> reorder expr

129

120

130 -- Actually do some reordering

121 -- Actually do some reordering

131 Let defs body ->

122 Let defs body ->

src/Transform/Substitute.hs+1−10

@@ -83,14 +83,5 @@ subst old new expression =

83 GLShader _ _ _ ->

84 expression

85

86− Input _ _ ->

86+ Port _ _ ->

87 expression

88−

89− Output name tipe expr ->

90− Output name tipe (f expr)

91−

92− LoopbackIn _ _ ->

93− expression

94−

95− LoopbackOut name expr ->

96− LoopbackOut name (f expr)

src/Type/Constrain/Expression.hs+1−10

@@ -165,18 +165,9 @@ constrain env (A region expr) tipe =

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

166 (c1 /\ c))

167

168− Input _ _ ->

168+ Port _ _ ->

169 return true

170

171− Output _ _ signal ->

172− constrain env signal tipe

173−

174− LoopbackIn _ _ ->

175− return true

176−

177− LoopbackOut _ expr ->

178− constrain env expr tipe

179−

180

171

181constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

172constrainDef env info (Canonical.Definition pattern expr maybeTipe) =

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

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