5111919 · elk · git.iko.soy

src/AST/Declaration.hs+54−24

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

22module AST.Declaration where

33

44import Data.Binary

5+import qualified AST.Expression.General as General

56import qualified AST.Expression.Source as Source

67import qualified AST.Expression.Valid as Valid

78import qualified AST.Expression.Canonical as Canonical

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

2829-- DECLARATION PHASES

2930

3031type SourceDecl =

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

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

3233

3334

3435type ValidDecl =

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

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

3637

3738

3839type CanonicalDecl =

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

4142

4243-- PORTS

4344

44−data RawPort

45+data SourcePort

4546 = PortAnnotation String T.RawType

4647 | PortDefinition String Source.Expr

4748

4849

49−data Port expr tipe

50− = Inbound String tipe

51− | Outbound String expr tipe

50+data ValidPort

51+ = In String T.RawType

52+ | Out String Valid.Expr T.RawType

5253

5354

54−type CanonicalPort =

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

55+newtype CanonicalPort

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

5657

5758

58−getName :: Port expr tipe -> String

59−getName port =

59+validPortName :: ValidPort -> String

60+validPortName port =

6061 case port of

61− Inbound name _ -> name

62− Outbound name _ _ -> name

62+ In name _ -> name

63+ Out name _ _ -> name

6364

6465

6566-- BINARY CONVERSION

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

131132 R -> P.text "r"

132133

133134

134−instance Pretty RawPort where

135+instance Pretty SourcePort where

135136 pretty port =

136137 case port of

137138 PortAnnotation name tipe ->

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

139+ prettyPortType name tipe

139140

140141 PortDefinition name expr ->

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

142+ prettyPortDef name expr

142143

143144

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

145+instance Pretty ValidPort where

145146 pretty port =

146147 case port of

147− Inbound name tipe ->

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

149−

150− Outbound name expr tipe ->

151− P.vcat

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

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

154− ]

148+ In name tipe ->

149+ prettyPortType name tipe

150+

151+ Out name expr tipe ->

152+ prettyPort name expr tipe

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+

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 =

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 =

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 =

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

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

@@ -58,17 +58,28 @@ data Expr' ann def var

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

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

6060 -- for type checking and code gen only

61− | Port String (PortImpl (Expr ann def var) var)

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

6262 | GLShader String String Literal.GLShaderTipe

6363 deriving (Show)

6464

6565

66+-- PORTS

67+

6668data PortImpl expr var

67− = Inbound (Type.PortType var)

68− | Outbound (Type.PortType var) expr

69+ = In String (Type.PortType var)

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

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

6972 deriving (Show)

7073

7174

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+

7283---- UTILITIES ----

7384

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

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

200211 GLShader _ _ _ ->

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

202213

203− Port name _ ->

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

214+ Port portImpl ->

215+ pretty portImpl

216+

217+

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

219+ pretty impl =

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

205221

206222

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

src/Generate/JavaScript.hs+7−11

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

2222import AST.Literal

2323import qualified AST.Module as Module

2424import qualified AST.Pattern as P

25−import qualified AST.Type as Type

2625import qualified AST.Variable as Var

2726

2827

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

207206 GLShader _uid src _tipe ->

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

209208

210− Port name impl ->

209+ Port impl ->

211210 case impl of

212− Inbound (Type.Normal tipe) ->

213− return (Port.inbound name tipe)

211+ In name portType ->

212+ return (Port.inbound name portType)

214213

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

216− return (Port.inboundSignal name tipe)

217−

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

214+ Out name expr portType ->

219215 do expr' <- expression expr

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

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

221217

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

218+ Task name expr portType ->

223219 do expr' <- expression expr

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

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

225221

226222

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

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

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

1−module Generate.JavaScript.Port

2− ( inbound, inboundSignal

3− , outbound, outboundSignal

4− ) where

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

52

63import qualified Data.List as List

74import Language.ECMAScript3.Syntax

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

129import Generate.JavaScript.Helpers

1310

1411

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+

1527data JSType

1628 = JSNumber

1729 | JSBoolean

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

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

5264

5365

66+_Task :: String -> Expression ()

67+_Task functionName =

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

69+

70+

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

5572check x jsType continue =

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

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

7390

7491-- INBOUND

7592

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

77−inbound name tipe =

78− _Port "inbound" `call`

79− [ string name

80− , string (show (pretty tipe))

81− , toTypeFunction tipe

82− ]

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

94+inbound name portType =

95+ case portType of

96+ T.Normal tipe ->

97+ _Port "inbound" `call`

98+ [ string name

99+ , string (show (pretty tipe))

100+ , toTypeFunction tipe

101+ ]

83102

84−

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

86−inboundSignal name tipe =

87− _Port "inboundSignal" `call`

88− [ string name

89− , string (show (pretty tipe))

90− , toTypeFunction tipe

91− ]

103+ T.Signal _root arg ->

104+ _Port "inboundSignal" `call`

105+ [ string name

106+ , string (show (pretty arg))

107+ , toTypeFunction arg

108+ ]

92109

93110

94111toTypeFunction :: CanonicalType -> Expression ()

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

178195

179196-- OUTBOUND

180197

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

182−outbound name tipe expr =

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

184−

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

199+outbound name expr portType =

200+ case portType of

201+ T.Normal tipe ->

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

185203

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

187−outboundSignal name tipe expr =

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

204+ T.Signal _ arg ->

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

189206

190207

191208fromTypeFunction :: CanonicalType -> Expression ()

src/Transform/Canonicalize.hs+15−12

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

7878 , aliases =

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

8080 , ports =

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

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

8282 }

8383

8484

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

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

204204 return (D.TypeAlias name tvars expanded')

205205

206− D.Port port ->

206+ D.Port validPort ->

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

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

209− case port of

210− D.Inbound name tipe ->

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

209+ case validPort of

210+ D.In name tipe ->

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

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

213213 return (D.Port port')

214214

215215

216− D.Outbound name expr tipe ->

216+ D.Out name expr tipe ->

217217 do expr' <- expression env expr

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

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

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

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

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

311311

312− Port name impl ->

312+ Port impl ->

313313 let portType pt =

314314 case pt of

315315 Type.Normal t ->

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

318318 Type.Signal root arg ->

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

320320 in

321− Port name <$>

321+ Port <$>

322322 case impl of

323− E.Inbound pt ->

324− E.Inbound <$> portType pt

323+ E.In name tipe ->

324+ E.In name <$> portType tipe

325325

326− E.Outbound pt expr ->

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

326+ E.Out name expr tipe ->

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

328+

329+ E.Task name expr tipe ->

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

328331

329332 GLShader uid src tipe ->

330333 return (GLShader uid src tipe)

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

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

55import Text.PrettyPrint as P

66

77import qualified AST.Declaration as D

8+import qualified AST.Expression.General as E

89import qualified AST.Expression.Canonical as Canonical

910import qualified AST.PrettyPrint as PP

1011import qualified AST.Type as T

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

2526 -> T.CanonicalType

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

2728check name maybeExpr rootType =

28− checkHelp name maybeExpr rootType rootType

29+ do impl <- checkHelp name maybeExpr rootType rootType

30+ return (D.CanonicalPort impl)

2931

3032

3133checkHelp

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

3335 -> Maybe Canonical.Expr

3436 -> T.CanonicalType

3537 -> T.CanonicalType

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

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

3739checkHelp name maybeExpr rootType tipe =

38− case tipe of

39− T.Aliased _ args t ->

40+ case (maybeExpr, tipe) of

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

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

4143

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

4355 | Var.isSignal signal ->

4456 case maybeExpr of

4557 Nothing ->

4658 do validForeignType name In arg arg

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

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

4860

4961 Just expr ->

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

5264

5365 _ ->

5466 case maybeExpr of

5567 Nothing ->

5668 do validForeignType name In rootType tipe

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

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

5870

5971 Just expr ->

6072 do validForeignType name Out rootType tipe

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

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

6274

6375

6476-- CHECK INBOUND AND OUTBOUND TYPES

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

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

329329 D.Port port ->

330330 (,) nodes $ env

331331 { _values =

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

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

333333 }

334334

335335 D.Fixity _ _ _ ->

src/Transform/Check.hs+1−1

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

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

5454

5555 portNames =

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

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

5757

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

5959 exprDups expr =

src/Transform/Declaration.hs+14−15

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

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

7070 | name == name' ->

7171 do expr' <- exprCombineAnnotations expr

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

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

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

7474

7575 _ ->

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

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

7777

7878 D.PortDefinition name _ ->

7979 Left (errorMessage "port" name)

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

125125 D.TypeAlias _ _ _ ->

126126 []

127127

128− D.Port port ->

129− case port of

130− D.Inbound name portType ->

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

132− tipe = T.portType portType

133− in

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

135−

136− D.Outbound name expr portType ->

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

138− tipe = T.portType portType

139− in

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

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

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

130+ in

131+ case impl of

132+ E.In name tipe ->

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

134+

135+ E.Out name _expr tipe ->

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

137+

138+ E.Task name _expr tipe ->

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

141140

142141 -- no constraints are needed for fixity declarations

143142 D.Fixity _ _ _ ->

src/Transform/Expression.hs+11−6

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

6969 GLShader uid src gltipe ->

7070 return $ GLShader uid src gltipe

7171

72− Port name impl ->

73− Port name <$>

72+ Port impl ->

73+ Port <$>

7474 case impl of

75− Inbound tipe ->

76− return (Inbound tipe)

75+ In name tipe ->

76+ return (In name tipe)

7777

78− Outbound tipe expr ->

79− Outbound tipe <$> go expr

78+ Out name expr tipe ->

79+ do expr' <- go expr

80+ return (Out name expr' tipe)

81+

82+ Task name expr tipe ->

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

99import qualified Data.Set as Set

1010

1111import AST.Annotation

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

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

1313import qualified AST.Expression.Canonical as Canonical

1414import qualified AST.Pattern as P

1515import qualified AST.Variable as V

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

115115 GLShader _ _ _ ->

116116 return expression

117117

118− Port name impl ->

119− return $ Port name impl

118+ Port impl ->

119+ Port <$>

120+ case impl of

121+ In _ _ ->

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

120129

121130 -- Actually do some reordering

122131 Let defs body ->

src/Transform/Substitute.hs+12−3

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

55import qualified Data.Set as Set

66

77import AST.Annotation

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

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

99import qualified AST.Expression.Canonical as Canonical

1010import qualified AST.Pattern as Pattern

1111import qualified AST.Variable as V

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

8383 GLShader _ _ _ ->

8484 expression

8585

86− Port _ _ ->

87− expression

86+ Port impl ->

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 =

177177

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

179179

180− Port _ _ ->

181− return true

180+ Port impl ->

181+ case impl of

182+ In _ _ ->

183+ return true

184+

185+ Out _ expr _ ->

186+ constrain env expr tipe

187+

188+ Task _ expr _ ->

189+ constrain env expr tipe

182190

183191

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