5111919 · elk · git.iko.soy

src/AST/Declaration.hs+54−24

compare with master

unifiedsplit

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

2module AST.Declaration where

3

4import Data.Binary

5+import qualified AST.Expression.General as General

5import qualified AST.Expression.Source as Source

6import qualified AST.Expression.Source as Source

6import qualified AST.Expression.Valid as Valid

7import qualified AST.Expression.Valid as Valid

7import qualified AST.Expression.Canonical as Canonical

8import qualified AST.Expression.Canonical as Canonical

@@ -28,11 +29,11 @@ data Assoc = L | N | R

28-- DECLARATION PHASES

29-- DECLARATION PHASES

29

30

30type SourceDecl =

31type SourceDecl =

31− Declaration' RawPort Source.Def Var.Raw Source.Expr

32+ Declaration' SourcePort Source.Def Var.Raw Source.Expr

32

33

34

34type ValidDecl =

35type ValidDecl =

35− Declaration' (Port Valid.Expr T.RawType) Valid.Def Var.Raw Valid.Expr

36+ Declaration' ValidPort Valid.Def Var.Raw Valid.Expr

36

37

38

38type CanonicalDecl =

39type CanonicalDecl =

@@ -41,25 +42,25 @@ type CanonicalDecl =

41

42

42-- PORTS

43-- PORTS

43

44

44−data RawPort

45+data SourcePort

45 = PortAnnotation String T.RawType

46 = PortAnnotation String T.RawType

46 | PortDefinition String Source.Expr

47 | PortDefinition String Source.Expr

47

48

49

49−data Port expr tipe

50+data ValidPort

50− = Inbound String tipe

51+ = In String T.RawType

51− | Outbound String expr tipe

52+ | Out String Valid.Expr T.RawType

52

53

54

54−type CanonicalPort =

55+newtype CanonicalPort

55− Port Canonical.Expr (T.PortType Var.Canonical)

56+ = CanonicalPort (General.PortImpl Canonical.Expr Var.Canonical)

56

57

58

58−getName :: Port expr tipe -> String

59+validPortName :: ValidPort -> String

59−getName port =

60+validPortName port =

60 case port of

61 case port of

61− Inbound name _ -> name

62+ In name _ -> name

62− Outbound name _ _ -> name

63+ Out name _ _ -> name

63

64

65

65-- BINARY CONVERSION

66-- BINARY CONVERSION

@@ -131,24 +132,53 @@ instance (Pretty port, Pretty def, Pretty var, Var.ToString var, Pretty expr) =>

131 R -> P.text "r"

132 R -> P.text "r"

132

133

134

134−instance Pretty RawPort where

135+instance Pretty SourcePort where

135 pretty port =

136 pretty port =

136 case port of

137 case port of

137 PortAnnotation name tipe ->

138 PortAnnotation name tipe ->

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

139+ prettyPortType name tipe

139

140

140 PortDefinition name expr ->

141 PortDefinition name expr ->

141− P.text "port" <+> P.text name <+> P.equals <+> pretty expr

142+ prettyPortDef name expr

142

143

144

144−instance (Pretty expr, Pretty tipe) => Pretty (Port expr tipe) where

145+instance Pretty ValidPort where

145 pretty port =

146 pretty port =

146 case port of

147 case port of

148+ In name tipe ->

149+ prettyPortType name tipe

150+

147− Inbound name tipe ->

151+ Out name expr tipe ->

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

152+ prettyPort name expr tipe

149−

153+

154+

155+instance Pretty CanonicalPort where

156+ pretty (CanonicalPort impl) =

157+ case impl of

158+ General.In name tipe ->

159+ prettyPortType name tipe

160+

161+ General.Out name expr tipe ->

162+ prettyPort name expr tipe

163+

150− Outbound name expr tipe ->

164+ General.Task name expr tipe ->

165+ prettyPort name expr tipe

166+

167+

168+

169+prettyPort :: (Pretty expr, Pretty tipe) => String -> expr -> tipe -> P.Doc

170+prettyPort name expr tipe =

151− P.vcat

171+ P.vcat

172+ [ prettyPortType name tipe

173+ , prettyPortDef name expr

174+ ]

175+

176+

177+prettyPortType :: (Pretty tipe) => String -> tipe -> P.Doc

178+prettyPortType name tipe =

152− [ P.text "port" <+> P.text name <+> P.colon <+> pretty tipe

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

180+

181+

182+prettyPortDef :: (Pretty expr) => String -> expr -> P.Doc

183+prettyPortDef name expr =

153− , P.hang (P.text "port" <+> P.text name <+> P.equals) 4 (pretty expr)

184+ P.hang (P.text "port" <+> P.text name <+> P.equals) 4 (pretty expr)

154− ]

src/AST/Expression/General.hs+21−5

@@ -58,17 +58,28 @@ 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− | Port String (PortImpl (Expr ann def var) var)

61+ | Port (PortImpl (Expr ann def var) var)

62 | GLShader String String Literal.GLShaderTipe

63 deriving (Show)

64

65

66+-- PORTS

67+

66data PortImpl expr var

68data PortImpl expr var

67− = Inbound (Type.PortType var)

69+ = In String (Type.PortType var)

68− | Outbound (Type.PortType var) expr

70+ | Out String expr (Type.PortType var)

71+ | Task String expr (Type.PortType var)

69 deriving (Show)

72 deriving (Show)

70

73

71

74

75+portName :: PortImpl expr var -> String

76+portName impl =

77+ case impl of

78+ In name _ -> name

79+ Out name _ _ -> name

80+ Task name _ _ -> name

81+

82+

72---- UTILITIES ----

83---- UTILITIES ----

73

84

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

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

@@ -200,8 +211,13 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

200 GLShader _ _ _ ->

211 GLShader _ _ _ ->

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

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

202

213

203− Port name _ ->

214+ Port portImpl ->

215+ pretty portImpl

216+

217+

218+instance (Pretty expr, Pretty var) => Pretty (PortImpl expr var) where

219+ pretty impl =

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

220+ P.text ("<port:" ++ portName impl ++ ">")

205

221

206

222

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

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

src/Generate/JavaScript.hs+7−11

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

22import AST.Literal

23import qualified AST.Module as Module

24import qualified AST.Pattern as P

25−import qualified AST.Type as Type

26import qualified AST.Variable as Var

25import qualified AST.Variable as Var

27

26

28

27

@@ -207,21 +206,18 @@ expression (A region expr) =

207 GLShader _uid src _tipe ->

206 GLShader _uid src _tipe ->

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

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

209

208

210− Port name impl ->

209+ Port impl ->

211 case impl of

210 case impl of

212− Inbound (Type.Normal tipe) ->

211+ In name portType ->

213− return (Port.inbound name tipe)

212+ return (Port.inbound name portType)

214

213

215− Inbound (Type.Signal _ tipe) ->

214+ Out name expr portType ->

216− return (Port.inboundSignal name tipe)

217−

218− Outbound (Type.Normal tipe) expr ->

219 do expr' <- expression expr

215 do expr' <- expression expr

220− return (Port.outbound name tipe expr')

216+ return (Port.outbound name expr' portType)

221

217

222− Outbound (Type.Signal _ tipe) expr ->

218+ Task name expr portType ->

223 do expr' <- expression expr

219 do expr' <- expression expr

224− return (Port.outboundSignal name tipe expr')

220+ return (Port.task name expr' portType)

225

221

226

222

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

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

src/Generate/JavaScript/Port.hs+43−26

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

1−module Generate.JavaScript.Port

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

2− ( inbound, inboundSignal

3− , outbound, outboundSignal

4− ) where

5

2

6import qualified Data.List as List

3import qualified Data.List as List

7import Language.ECMAScript3.Syntax

4import Language.ECMAScript3.Syntax

@@ -12,6 +9,21 @@ import qualified AST.Variable as Var

12import Generate.JavaScript.Helpers

9import Generate.JavaScript.Helpers

13

10

14

11

12+-- TASK

13+

14+task :: String -> Expression () -> T.PortType var -> Expression ()

15+task name expr portType =

16+ case portType of

17+ T.Normal _ ->

18+ _Task "perform" `call` [ expr ]

19+

20+ T.Signal _ _ ->

21+ _Task "performSignal" `call` [ string name, expr ]

22+

23+

24+

25+-- HELPERS

26+

15data JSType

27data JSType

16 = JSNumber

28 = JSNumber

17 | JSBoolean

29 | JSBoolean

@@ -51,6 +63,11 @@ _Port functionName =

51 useLazy ["Elm","Native","Port"] functionName

63 useLazy ["Elm","Native","Port"] functionName

52

64

53

65

66+_Task :: String -> Expression ()

67+_Task functionName =

68+ useLazy ["Elm","Native","Task"] functionName

69+

70+

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

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

55check x jsType continue =

72check x jsType continue =

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

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

@@ -73,22 +90,22 @@ check x jsType continue =

73

90

74-- INBOUND

91-- INBOUND

75

92

76−inbound :: String -> CanonicalType -> Expression ()

93+inbound :: String -> T.PortType Var.Canonical -> Expression ()

77−inbound name tipe =

94+inbound name portType =

95+ case portType of

96+ T.Normal tipe ->

78− _Port "inbound" `call`

97+ _Port "inbound" `call`

79− [ string name

98+ [ string name

80− , string (show (pretty tipe))

99+ , string (show (pretty tipe))

81− , toTypeFunction tipe

100+ , toTypeFunction tipe

82− ]

101+ ]

83

102

84−

103+ T.Signal _root arg ->

85−inboundSignal :: String -> CanonicalType -> Expression ()

86−inboundSignal name tipe =

87− _Port "inboundSignal" `call`

104+ _Port "inboundSignal" `call`

88− [ string name

105+ [ string name

89− , string (show (pretty tipe))

106+ , string (show (pretty arg))

90− , toTypeFunction tipe

107+ , toTypeFunction arg

91− ]

108+ ]

92

109

93

110

94toTypeFunction :: CanonicalType -> Expression ()

111toTypeFunction :: CanonicalType -> Expression ()

@@ -178,14 +195,14 @@ toTuple types x =

178

195

179-- OUTBOUND

196-- OUTBOUND

180

197

181−outbound :: String -> CanonicalType -> Expression () -> Expression ()

198+outbound :: String -> Expression () -> T.PortType Var.Canonical -> Expression ()

182−outbound name tipe expr =

199+outbound name expr portType =

200+ case portType of

201+ T.Normal tipe ->

183− _Port "outbound" `call` [ string name, fromTypeFunction tipe, expr ]

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

184−

185

203

186−outboundSignal :: String -> CanonicalType -> Expression () -> Expression ()

204+ T.Signal _ arg ->

187−outboundSignal name tipe expr =

188− _Port "outboundSignal" `call` [ string name, fromTypeFunction tipe, expr ]

205+ _Port "outboundSignal" `call` [ string name, fromTypeFunction arg, expr ]

189

206

190

207

191fromTypeFunction :: CanonicalType -> Expression ()

208fromTypeFunction :: CanonicalType -> Expression ()

src/Transform/Canonicalize.hs+15−12

@@ -78,7 +78,7 @@ moduleHelp interfaces modul@(Module.Module _ _ exports _ decls) =

78 , aliases =

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

80 , ports =

81− [ D.getName port | D.Port port <- decls ]

81+ [ E.portName impl | D.Port (D.CanonicalPort impl) <- decls ]

82 }

83

84

@@ -203,17 +203,17 @@ declaration env decl =

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

204 return (D.TypeAlias name tvars expanded')

205

206− D.Port port ->

206+ D.Port validPort ->

207 do Env.uses ["Native","Port"]

208− Env.uses ["Native","JavaScript"]

208+ Env.uses ["Native","Json"]

209− case port of

209+ case validPort of

210− D.Inbound name tipe ->

210+ D.In name tipe ->

211 do tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

212 port' <- Port.check name Nothing tipe'

213 return (D.Port port')

214

215

216− D.Outbound name expr tipe ->

216+ D.Out name expr tipe ->

217 do expr' <- expression env expr

218 tipe' <- canonicalize Canonicalize.tipe "port" name env tipe

219 port' <- Port.check name (Just expr') tipe'

@@ -309,7 +309,7 @@ expression env (A.A ann validExpr) =

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

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

311

312− Port name impl ->

312+ Port impl ->

313 let portType pt =

314 case pt of

315 Type.Normal t ->

@@ -318,13 +318,16 @@ expression env (A.A ann validExpr) =

318 Type.Signal root arg ->

319 Type.Signal <$> tipe' env root <*> tipe' env arg

320 in

321− Port name <$>

321+ Port <$>

322 case impl of

323− E.Inbound pt ->

323+ E.In name tipe ->

324− E.Inbound <$> portType pt

324+ E.In name <$> portType tipe

325

326− E.Outbound pt expr ->

326+ E.Out name expr tipe ->

327− E.Outbound <$> portType pt <*> go expr

327+ E.Out name <$> go expr <*> portType tipe

328+

329+ E.Task name expr tipe ->

330+ E.Task name <$> go expr <*> portType tipe

328

331

329 GLShader uid src tipe ->

332 GLShader uid src tipe ->

330 return (GLShader uid src tipe)

333 return (GLShader uid src tipe)

src/Transform/Canonicalize/Port.hs+21−9

@@ -5,6 +5,7 @@ import Control.Monad.Error (throwError)

5import Text.PrettyPrint as P

6

7import qualified AST.Declaration as D

8+import qualified AST.Expression.General as E

8import qualified AST.Expression.Canonical as Canonical

9import qualified AST.Expression.Canonical as Canonical

9import qualified AST.PrettyPrint as PP

10import qualified AST.PrettyPrint as PP

10import qualified AST.Type as T

11import qualified AST.Type as T

@@ -25,7 +26,8 @@ check

25 -> T.CanonicalType

26 -> T.CanonicalType

26 -> Env.Canonicalizer [P.Doc] D.CanonicalPort

27 -> Env.Canonicalizer [P.Doc] D.CanonicalPort

27check name maybeExpr rootType =

28check name maybeExpr rootType =

28− checkHelp name maybeExpr rootType rootType

29+ do impl <- checkHelp name maybeExpr rootType rootType

30+ return (D.CanonicalPort impl)

29

31

30

32

31checkHelp

33checkHelp

@@ -33,32 +35,42 @@ checkHelp

33 -> Maybe Canonical.Expr

35 -> Maybe Canonical.Expr

34 -> T.CanonicalType

36 -> T.CanonicalType

35 -> T.CanonicalType

37 -> T.CanonicalType

36− -> Env.Canonicalizer [P.Doc] D.CanonicalPort

38+ -> Env.Canonicalizer [P.Doc] (E.PortImpl Canonical.Expr Var.Canonical)

37checkHelp name maybeExpr rootType tipe =

39checkHelp name maybeExpr rootType tipe =

38− case tipe of

40+ case (maybeExpr, tipe) of

39− T.Aliased _ args t ->

41+ (_, T.Aliased _ args t) ->

40 checkHelp name maybeExpr rootType (T.dealias args t)

42 checkHelp name maybeExpr rootType (T.dealias args t)

41

43

42− T.App (T.Type signal) [arg]

44+ (Just expr, T.App (T.Type task) [ _x, _a ])

45+ | Var.isTask task ->

46+ return (E.Task name expr (T.Normal tipe))

47+

48+

49+ (Just expr, T.App (T.Type signal) [ arg@(T.App (T.Type task) [ _x, _a ]) ])

50+ | Var.isSignal signal && Var.isTask task ->

51+ return (E.Task name expr (T.Signal tipe arg))

52+

53+

54+ (_, T.App (T.Type signal) [arg])

43 | Var.isSignal signal ->

55 | Var.isSignal signal ->

44 case maybeExpr of

56 case maybeExpr of

45 Nothing ->

57 Nothing ->

46 do validForeignType name In arg arg

58 do validForeignType name In arg arg

47− return (D.Inbound name (T.Signal rootType arg))

59+ return (E.In name (T.Signal rootType arg))

48

60

49 Just expr ->

61 Just expr ->

50 do validForeignType name Out arg arg

62 do validForeignType name Out arg arg

51− return (D.Outbound name expr (T.Signal rootType arg))

63+ return (E.Out name expr (T.Signal rootType arg))

52

64

53 _ ->

65 _ ->

54 case maybeExpr of

66 case maybeExpr of

55 Nothing ->

67 Nothing ->

56 do validForeignType name In rootType tipe

68 do validForeignType name In rootType tipe

57− return (D.Inbound name (T.Normal rootType))

69+ return (E.In name (T.Normal rootType))

58

70

59 Just expr ->

71 Just expr ->

60 do validForeignType name Out rootType tipe

72 do validForeignType name Out rootType tipe

61− return (D.Outbound name expr (T.Normal rootType))

73+ return (E.Out name expr (T.Normal rootType))

62

74

63

75

64-- CHECK INBOUND AND OUTBOUND TYPES

76-- CHECK INBOUND AND OUTBOUND TYPES

src/Transform/Canonicalize/Setup.hs+1−1

@@ -329,7 +329,7 @@ addDecl moduleName info@(nodes,env) decl =

329 D.Port port ->

330 (,) nodes $ env

331 { _values =

332− addLocal (D.getName port) (_values env)

332+ addLocal (D.validPortName port) (_values env)

333 }

334

335 D.Fixity _ _ _ ->

src/Transform/Check.hs+1−1

@@ -53,7 +53,7 @@ duplicateValues decls =

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

54

55 portNames =

56− [ D.getName port | D.Port port <- decls ]

56+ [ D.validPortName port | D.Port port <- decls ]

57

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

59 exprDups expr =

src/Transform/Declaration.hs+14−15

@@ -69,11 +69,11 @@ combineAnnotations =

69 D.Port (D.PortDefinition name' expr) : restRest

70 | name == name' ->

71 do expr' <- exprCombineAnnotations expr

72− let port' = D.Outbound name expr' tipe

72+ let port' = D.Out name expr' tipe

73 (:) (D.Port port') <$> go restRest

74

75 _ ->

76− (:) (D.Port (D.Inbound name tipe)) <$> go rest

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

77

78 D.PortDefinition name _ ->

79 Left (errorMessage "port" name)

@@ -125,19 +125,18 @@ toDefs moduleName decl =

125 D.TypeAlias _ _ _ ->

126 []

127

128− D.Port port ->

128+ D.Port (D.CanonicalPort impl) ->

129+ let body = A.none (E.Port impl)

130+ in

129− case port of

131+ case impl of

130− D.Inbound name portType ->

132+ E.In name tipe ->

131− let portExpr = E.Port name (E.Inbound portType)

132− tipe = T.portType portType

133− in

134− [ definition name (A.none portExpr) tipe ]

133+ [ definition name body (T.portType tipe) ]

135−

134+

136− D.Outbound name expr portType ->

135+ E.Out name _expr tipe ->

137− let portExpr = E.Port name (E.Outbound portType expr)

136+ [ definition name body (T.portType tipe) ]

138− tipe = T.portType portType

137+

139− in

138+ E.Task name _expr tipe ->

140− [ definition name (A.none portExpr) tipe ]

139+ [ definition name body (T.portType tipe) ]

141

140

142 -- no constraints are needed for fixity declarations

141 -- no constraints are needed for fixity declarations

143 D.Fixity _ _ _ ->

142 D.Fixity _ _ _ ->

src/Transform/Expression.hs+11−6

@@ -69,11 +69,16 @@ crawlLet defsTransform annotatedExpression =

69 GLShader uid src gltipe ->

70 return $ GLShader uid src gltipe

71

72− Port name impl ->

72+ Port impl ->

73− Port name <$>

73+ Port <$>

74 case impl of

75− Inbound tipe ->

75+ In name tipe ->

76− return (Inbound tipe)

76+ return (In name tipe)

77

78− Outbound tipe expr ->

78+ Out name expr tipe ->

79+ do expr' <- go expr

80+ return (Out name expr' tipe)

81+

82+ Task name expr tipe ->

79− Outbound tipe <$> go expr

83+ do expr' <- go expr

84+ return (Task name expr' tipe)

src/Transform/SortDefinitions.hs+12−3

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

9import qualified Data.Set as Set

10

11import AST.Annotation

12−import AST.Expression.General (Expr'(..))

12+import AST.Expression.General (Expr'(..), PortImpl(..))

13import qualified AST.Expression.Canonical as Canonical

14import qualified AST.Pattern as P

15import qualified AST.Variable as V

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

115 GLShader _ _ _ ->

116 return expression

117

118− Port name impl ->

118+ Port impl ->

119+ Port <$>

120+ case impl of

121+ In _ _ ->

119− return $ Port name impl

122+ return impl

123+

124+ Out name expr tipe ->

125+ (\e -> Out name e tipe) <$> reorder expr

126+

127+ Task name expr tipe ->

128+ (\e -> Task name e tipe) <$> reorder expr

120

129

121 -- Actually do some reordering

130 -- Actually do some reordering

122 Let defs body ->

131 Let defs body ->

src/Transform/Substitute.hs+12−3

@@ -5,7 +5,7 @@ import Control.Arrow (second, (***))

5import qualified Data.Set as Set

6

7import AST.Annotation

8−import AST.Expression.General (Expr'(..))

8+import AST.Expression.General (Expr'(..), PortImpl(..))

9import qualified AST.Expression.Canonical as Canonical

10import qualified AST.Pattern as Pattern

11import qualified AST.Variable as V

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

83 GLShader _ _ _ ->

84 expression

85

86− Port _ _ ->

86+ Port impl ->

87− expression

87+ Port $

88+ case impl of

89+ In _ _ ->

90+ impl

91+

92+ Out name expr tipe ->

93+ Out name (f expr) tipe

94+

95+ Task name expr tipe ->

96+ Task name (f expr) tipe

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

@@ -177,8 +177,16 @@ constrain env (A region expression) tipe =

177

178 return $ clet schemes (clet letScheme (c1 /\ c))

179

180− Port _ _ ->

180+ Port impl ->

181+ case impl of

182+ In _ _ ->

181− return true

183+ return true

184+

185+ Out _ expr _ ->

186+ constrain env expr tipe

187+

188+ Task _ expr _ ->

189+ constrain env expr tipe

182

190

183

191

184expandPattern :: Canonical.Def -> [Canonical.Def]

192expandPattern :: Canonical.Def -> [Canonical.Def]