8036fca · elk · git.iko.soy

elm-compiler.cabal+1

compare with master

unifiedsplit

@@ -73,6 +73,7 @@ Library

73 Transform.Canonicalize.Setup,

74 Transform.Canonicalize.Type,

75 Transform.Canonicalize.Variable,

76+ Transform.Canonicalize.Wire,

76 Transform.Check,

77 Transform.Check,

77 Transform.Expression,

78 Transform.Expression,

78 Transform.Declaration,

79 Transform.Declaration,

src/AST/Declaration.hs+65−35

@@ -11,6 +11,8 @@ import AST.PrettyPrint

11import Text.PrettyPrint as P

12

13

14+-- DECLARATIONS

15+

14data Declaration' wire def var

16data Declaration' wire def var

15 = Definition def

17 = Definition def

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

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

@@ -23,6 +25,22 @@ data Assoc = L | N | R

23 deriving (Eq)

25 deriving (Eq)

24

26

25

27

28+-- DECLARATION PHASES

29+

30+type SourceDecl =

31+ Declaration' RawWire Source.Def Var.Raw

32+

33+

34+type ValidDecl =

35+ Declaration' ValidWire Valid.Def Var.Raw

36+

37+

38+type CanonicalDecl =

39+ Declaration' CanonicalWire Canonical.Def Var.Canonical

40+

41+

42+-- WIRES

43+

26data RawWire

44data RawWire

27 = InputAnnotation String T.RawType

45 = InputAnnotation String T.RawType

28 | OutputAnnotation String T.RawType

46 | OutputAnnotation String T.RawType

@@ -31,38 +49,27 @@ data RawWire

31 | LoopbackDefinition String Source.Expr

49 | LoopbackDefinition String Source.Expr

32

50

33

51

34−data Wire expr var

52+data Wire expr var loopback

53+ = Input String (T.Type var)

35− = Output String expr (T.Type var)

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

36− | Input String (T.Type var)

55+ | Loopback loopback

37− | Loopback String (Maybe expr) (T.Type var)

38

56

39

57

40−type SourceDecl =

58+data ValidLoopback =

41− Declaration' RawWire Source.Def Var.Raw

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

42

60

43

61

44−type ValidDecl =

62+data CanonicalLoopback

45− Declaration' (Wire Valid.Expr Var.Raw) Valid.Def Var.Raw

63+ = Mailbox String T.CanonicalType

64+ | Promise String T.CanonicalType Canonical.Expr T.CanonicalType

46

65

47

66

48−type CanonicalDecl =

67+type ValidWire =

49− Declaration' (Wire Canonical.Expr Var.Canonical) Canonical.Def Var.Canonical

68+ Wire Valid.Expr Var.Raw ValidLoopback

50

69

51

70

52−wireName :: Wire expr var -> String

71+type CanonicalWire =

53−wireName wire =

72+ Wire Canonical.Expr Var.Canonical CanonicalLoopback

54− case wire of

55− Input name _ -> name

56− Output name _ _ -> name

57− Loopback name _ _ -> name

58−

59−

60−assocToString :: Assoc -> String

61−assocToString assoc =

62− case assoc of

63− L -> "left"

64− N -> "non"

65− R -> "right"

66

73

67

74

68-- BINARY CONVERSION

75-- BINARY CONVERSION

@@ -86,6 +93,14 @@ instance Binary Assoc where

86

93

87-- PRETTY STRINGS

94-- PRETTY STRINGS

88

95

96+assocToString :: Assoc -> String

97+assocToString assoc =

98+ case assoc of

99+ L -> "left"

100+ N -> "non"

101+ R -> "right"

102+

103+

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

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

90 Pretty (Declaration' wire def var) where

105 Pretty (Declaration' wire def var) where

91 pretty decl =

106 pretty decl =

@@ -141,10 +156,11 @@ instance Pretty RawWire where

141 prettyWire "loopback" name ":" tipe

156 prettyWire "loopback" name ":" tipe

142

157

143 LoopbackDefinition name expr ->

158 LoopbackDefinition name expr ->

144− prettyWire "loopback" name "=" expr

159+ prettyWire "loopback" name "<-" expr

145

160

146

161

147−instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Wire expr var) where

162+instance (Pretty expr, Pretty var, Var.ToString var, Pretty loopback) =>

163+ Pretty (Wire expr var loopback) where

148 pretty wire =

164 pretty wire =

149 case wire of

165 case wire of

150 Input name tipe ->

166 Input name tipe ->

@@ -156,15 +172,29 @@ instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Wire expr var) w

156 , prettyWire "output" name "=" expr

172 , prettyWire "output" name "=" expr

157 ]

173 ]

158

174

159− Loopback name maybeExpr tipe ->

175+ Loopback loopback ->

176+ pretty loopback

177+

178+

179+instance Pretty ValidLoopback where

180+ pretty (ValidLoopback name maybeExpr tipe) =

160− P.vcat

181+ P.vcat

161− [ prettyWire "loopback" name ":" tipe

182+ [ prettyWire "loopback" name ":" tipe

183+ , maybe P.empty (prettyWire "loopback" name "<-") maybeExpr

184+ ]

185+

186+

187+instance Pretty CanonicalLoopback where

188+ pretty loopback =

162− , case maybeExpr of

189+ case loopback of

163− Just expr ->

190+ Mailbox name tipe ->

164− prettyWire "loopback" name "<-" expr

191+ prettyWire "loopback" name ":" tipe

165− Nothing ->

192+

166− P.empty

193+ Promise name _promiseType expr resultType ->

194+ P.vcat

195+ [ prettyWire "loopback" name ":" resultType

196+ , prettyWire "loopback" name "<-" expr

167− ]

197+ ]

168

198

169

199

170prettyWire :: (Pretty a) => String -> String -> String -> a -> Doc

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

src/AST/Expression/General.hs+13−3

@@ -60,11 +60,18 @@ data Expr' ann def var

60 -- for type checking and code gen only

61 | Input String (Type var)

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

63− | Loopback String (Type var) (Maybe (Expr ann def var))

63+ | LoopbackIn String Source

64+ | LoopbackOut String (Expr ann def var)

64 | GLShader String String Literal.GLShaderTipe

65 | GLShader String String Literal.GLShaderTipe

65 deriving (Show)

66 deriving (Show)

66

67

68

69+data Source

70+ = Mailbox

71+ | PromiseStream

72+ deriving (Show)

73+

74+

68---- UTILITIES ----

75---- UTILITIES ----

69

76

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

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

@@ -201,8 +208,11 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

201 Output name _ _ ->

208 Output name _ _ ->

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

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

203

210

204− Loopback name _ _ ->

211+ LoopbackIn name _ ->

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

213+

214+ LoopbackOut name _ ->

205− P.text ("<loopback:" ++ name ++ ">")

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

206

216

207

217

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

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

src/Generate/JavaScript.hs+9−5

@@ -214,13 +214,17 @@ expression (A region expr) =

214 do value' <- expression value

215 return (Foreign.output name tipe value')

216

217− Loopback name tipe maybeExpr ->

217+ LoopbackIn name source ->

218− case maybeExpr of

218+ case source of

219− Nothing ->

219+ Mailbox ->

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

221

222− Just expr ->

222+ PromiseStream ->

223− error "run the promises"

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

224+

225+ LoopbackOut name expr ->

226+ do expr' <- expression expr

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

224

228

225

229

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

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

src/Transform/Canonicalize.hs+30−15

@@ -26,6 +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

29import qualified Transform.SortDefinitions as Transform

30import qualified Transform.SortDefinitions as Transform

30import qualified Transform.Declaration as Transform

31import qualified Transform.Declaration as Transform

31

32

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

76 , aliases =

77 , aliases =

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

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

78 , ports =

79 , ports =

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

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

80 }

81 }

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.Mailbox name _) -> name

89+ D.Loopback (D.Promise name _ _ _) -> name

90+

82

91

83resolveExports

92resolveExports

84 :: [Var.Value]

93 :: [Var.Value]

@@ -206,19 +215,22 @@ declaration env decl =

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

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

207 D.Wire <$>

216 D.Wire <$>

208 case wire of

217 case wire of

209− D.Input name t ->

218+ D.Input name tipe ->

210− do t' <- canonicalize Canonicalize.tipe "input" name env t

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

220+ Wire.checkInput name tipe'

211− return (D.Input name t')

221+ return (D.Input name tipe')

212−

222+

213− D.Output name e t ->

223+ D.Output name expr tipe ->

214− do e' <- expression env e

224+ do expr' <- expression env expr

215− t' <- canonicalize Canonicalize.tipe "output" name env t

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

226+ Wire.checkOutput name tipe'

216− return (D.Output name e' t')

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

217−

228+

218− D.Loopback name maybeExpr t ->

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

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

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

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

231+ tipe' <- canonicalize Canonicalize.tipe "loopback" name env tipe

232+ loopback' <- Wire.loopback name maybeExpr' tipe'

221− return (D.Loopback name maybeExpr' t')

233+ return (D.Loopback loopback')

222

234

223 D.Fixity assoc prec op ->

235 D.Fixity assoc prec op ->

224 return $ D.Fixity assoc prec op

236 return $ D.Fixity assoc prec op

@@ -316,8 +328,11 @@ expression env (A.A ann validExpr) =

316 Output name tipe expr ->

328 Output name tipe expr ->

317 Output name <$> tipe' env tipe <*> go expr

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

318

330

319− Loopback name tipe maybeExpr ->

331+ LoopbackIn name source ->

320− Loopback name <$> tipe' env tipe <*> T.traverse go maybeExpr

332+ return (LoopbackIn name source)

333+

334+ LoopbackOut name expr ->

335+ LoopbackOut name <$> go expr

321

336

322 GLShader uid src tipe ->

337 GLShader uid src tipe ->

323 return (GLShader uid src tipe)

338 return (GLShader uid src tipe)

src/Transform/Canonicalize/Setup.hs+10−4

@@ -327,10 +327,16 @@ addDecl moduleName info@(nodes,env) decl =

327 }

328

329 D.Wire wire ->

330+ let wireName =

331+ case wire of

332+ D.Input name _ -> name

333+ D.Output name _ _ -> name

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

335+ in

330− (,) nodes $ env

336+ (,) nodes $ env

331− { _values =

337+ { _values =

332− addLocal (D.wireName wire) (_values env)

338+ addLocal wireName (_values env)

333− }

339+ }

334

340

335 D.Fixity _ _ _ ->

341 D.Fixity _ _ _ ->

336 info

342 info

src/Transform/Canonicalize/Wire.hsnew file+207

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

1+module Transform.Canonicalize.Wire (checkInput, checkOutput, loopback) 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+checkInput :: String -> ST.CanonicalType -> Env.Canonicalizer [P.Doc] ()

21+checkInput name tipe =

22+ checkWire In name tipe tipe

23+

24+

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

26+checkOutput name tipe =

27+ checkWire Out name tipe tipe

28+

29+

30+data Direction = In | Out

31+

32+

33+checkWire

34+ :: Direction

35+ -> String

36+ -> ST.CanonicalType

37+ -> ST.CanonicalType

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

39+checkWire direction name rootType tipe =

40+ case tipe of

41+ ST.Aliased _ args t ->

42+ checkWire direction name rootType (ST.dealias args t)

43+

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

45+ | Var.isStream signal ->

46+ validWireType False (Just Stream) direction name rootType t

47+

48+ | Var.isVarying signal ->

49+ validWireType False (Just Varying) direction name rootType t

50+

51+ _ ->

52+ validWireType False Nothing direction name rootType tipe

53+

54+

55+data Signal = Stream | Varying

56+

57+

58+validWireType

59+ :: Bool

60+ -> Maybe Signal

61+ -> Direction

62+ -> String

63+ -> ST.CanonicalType

64+ -> ST.CanonicalType

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

66+validWireType seenFunc seenSignal direction name rootType tipe =

67+ let valid localType =

68+ validWireType seenFunc seenSignal direction name rootType localType

69+

70+ err kind =

71+ throw (wireError 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+ (validWireType 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+wireError

125+ :: String

126+ -> Direction

127+ -> ST.CanonicalType

128+ -> ST.CanonicalType

129+ -> String

130+ -> [P.Doc]

131+wireError name direction rootType localType problemMessage =

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

133+ , P.nest 4 $

134+ P.vcat

135+ [ txt [ "The ", 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 ", wire, "s include:" ]

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

141+ , txt [ " Json.Values, ", dir "" "first-order functions, promises, ", "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+loopback

157+ :: String

158+ -> Maybe Canonical.Expr

159+ -> ST.CanonicalType

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

161+loopback name maybeExpr tipe =

162+ case maybeExpr of

163+ Nothing ->

164+ case ST.deepDealias tipe of

165+ ST.Record

166+ [ ("mailbox", ST.App (ST.Type mailbox) [a])

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

168+ ]

169+ Nothing

170+ | Var.isStream stream && Var.isMailbox mailbox && a == b ->

171+ return (D.Mailbox name tipe)

172+

173+

174+ _ ->

175+ throw $ loopbackError name tipe $

176+ [ P.text "A loopback like this must be a WritableStream." ]

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 promise =

183+ Var.fromModule ["Promise"] "Promise"

184+ promiseType =

185+ ST.App (ST.Type signal) [ ST.App (ST.Type promise) [failure,success] ]

186+ in

187+ return (D.Promise name promiseType expr tipe)

188+

189+ _ ->

190+ throw $ loopbackError name tipe $

191+ [ P.text "A loopback that runs promises 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+loopbackError :: String -> ST.CanonicalType -> [Doc] -> [Doc]

199+loopbackError name tipe message =

200+ [ P.text "Loopback Error:"

201+ , P.nest 4 $

202+ P.vcat $

203+ [ P.text ("The loopback 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+1−1

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

59 case wire of

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

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

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

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

63

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

65 exprDups expr =

src/Transform/Declaration.hs+18−4

@@ -87,10 +87,12 @@ combineAnnotations =

87 case wireRest of

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

89 do expr' <- exprCombineAnnotations expr

90− (:) (D.Wire (D.Loopback name (Just expr') tipe)) <$> go rest

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

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

91

92

92 _ ->

93 _ ->

93− (:) (D.Wire (D.Loopback name Nothing tipe)) <$> go wireRest

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

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

94

96

95

97

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

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

@@ -143,10 +145,22 @@ toDefs moduleName decl =

143 case wire of

145 case wire of

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

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

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

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

148+

146 D.Input name tipe ->

149 D.Input name tipe ->

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

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

151+

148− D.Loopback name maybeExpr tipe ->

152+ D.Loopback loopback ->

153+ case loopback of

154+ D.Mailbox name tipe ->

149− [ definition name (A.none $ E.Loopback name tipe maybeExpr) tipe ]

155+ [ definition name (A.none $ E.LoopbackIn name E.Mailbox) tipe ]

156+

157+ D.Promise name promiseType expr resultType ->

158+ let dummyName =

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

160+ in

161+ [ definition name (A.none $ E.LoopbackIn name E.PromiseStream) resultType

162+ , definition dummyName (A.none $ E.LoopbackOut name expr) promiseType

163+ ]

150

164

151 -- no constraints are needed for fixity declarations

165 -- no constraints are needed for fixity declarations

152 D.Fixity _ _ _ ->

166 D.Fixity _ _ _ ->

src/Transform/Expression.hs+13−48

@@ -1,46 +1,16 @@

1{-# OPTIONS_GHC -Wall #-}

2−module Transform.Expression (crawlLet, checkWires) where

2+module Transform.Expression (crawlLet) where

3

4import Control.Applicative ((<$>),(<*>))

5import AST.Annotation ( Annotated(A) )

6import AST.Expression.General

7−import qualified AST.Expression.Canonical as Canonical

8−import AST.Type (Type, CanonicalType)

9

7

10

8

11crawlLet

9crawlLet

12 :: ([def] -> Either a [def'])

10 :: ([def] -> Either a [def'])

13 -> Expr ann def var

11 -> Expr ann def var

14 -> Either a (Expr ann def' var)

12 -> Either a (Expr ann def' var)

15−crawlLet =

16− crawl

17− (\_ _ -> return ())

18− (\_ _ -> return ())

19− (\_ _ _ -> return ())

20−

21−

22−checkWires

23− :: (String -> CanonicalType -> Either a ())

24− -> (String -> CanonicalType -> Either a ())

25− -> (String -> CanonicalType -> Bool -> Either a ())

26− -> Canonical.Expr

27− -> Either a Canonical.Expr

28−checkWires inputCheck outputCheck loopbackCheck expr =

29− crawl inputCheck outputCheck loopbackCheck (mapM checkDef) expr

30− where

31− checkDef def@(Canonical.Definition _ body _) =

32− do _ <- checkWires inputCheck outputCheck loopbackCheck body

33− return def

34−

35−

36−crawl

37− :: (String -> Type var -> Either a ())

38− -> (String -> Type var -> Either a ())

39− -> (String -> Type var -> Bool -> Either a ())

40− -> ([def] -> Either a [def'])

41− -> Expr ann def var

42− -> Either a (Expr ann def' var)

43−crawl inputCheck outputCheck loopbackCheck defsTransform annotatedExpression =

13+crawlLet defsTransform annotatedExpression =

44 go annotatedExpression

14 go annotatedExpression

45 where

15 where

46 go (A srcSpan expression) =

16 go (A srcSpan expression) =

@@ -99,19 +69,14 @@ crawl inputCheck outputCheck loopbackCheck defsTransform annotatedExpression =

99 GLShader uid src gltipe ->

69 GLShader uid src gltipe ->

100 return $ GLShader uid src gltipe

70 return $ GLShader uid src gltipe

101

71

102− Input name st ->

72+ Input name tipe ->

103− do inputCheck name st

104− return $ Input name st

73+ return $ Input name tipe

105−

74+

106− Output name st expr ->

75+ Output name tipe expr ->

107− do outputCheck name st

108− Output name st <$> go expr

76+ Output name tipe <$> go expr

109−

77+

110− Loopback name st maybeExpr ->

78+ LoopbackIn name source ->

111− do let hasExpr = maybe False (const True) maybeExpr

79+ return (LoopbackIn name source)

112− loopbackCheck name st hasExpr

80+

113− case maybeExpr of

81+ LoopbackOut name expr ->

114− Nothing ->

115− return (Loopback name st Nothing)

116− Just expr ->

117− (Loopback name st . Just) <$> go expr

82+ LoopbackOut name <$> go expr

src/Transform/SortDefinitions.hs+5−3

@@ -121,9 +121,11 @@ reorder (A ann expression) =

121 Output name tipe signal ->

122 Output name tipe <$> reorder signal

123

124− Loopback name tipe maybeExpr ->

124+ LoopbackIn name source ->

125− Loopback name tipe <$>

125+ return $ LoopbackIn name source

126− maybe (return Nothing) (fmap Just . reorder) maybeExpr

126+

127+ LoopbackOut name expr ->

128+ LoopbackOut name <$> reorder expr

127

129

128 -- Actually do some reordering

130 -- Actually do some reordering

129 Let defs body ->

131 Let defs body ->

src/Transform/Substitute.hs+5−2

@@ -89,5 +89,8 @@ subst old new expression =

89 Output name tipe expr ->

90 Output name tipe (f expr)

91

92− Loopback name tipe maybeExpr ->

92+ LoopbackIn _ _ ->

93− Loopback name tipe (fmap f maybeExpr)

93+ expression

94+

95+ LoopbackOut name expr ->

96+ LoopbackOut name (f expr)

src/Type/Constrain/Expression.hs+5−6

@@ -171,12 +171,11 @@ constrain env (A region expr) tipe =

171 Output _ _ signal ->

172 constrain env signal tipe

173

174− Loopback _ _ maybeExpr ->

174+ LoopbackIn _ _ ->

175− case maybeExpr of

176− Nothing ->

177− return true

175+ return true

178− Just expr ->

176+

177+ LoopbackOut _ expr ->

179− constrain env expr tipe

178+ constrain env expr tipe

180

179

181

180

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

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

src/Type/ExtraChecks.hs+1−183

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

4successfully. At that point we still need to do occurs checks and ensure that

5`main` has an acceptable type.

6-}

7−module Type.ExtraChecks (mainType, occurs, wireTypes) where

7+module Type.ExtraChecks (mainType, occurs) where

8

9import Prelude hiding (maybe)

10import Control.Applicative ((<$>),(<*>))

@@ -16,21 +16,14 @@ import qualified Data.UnionFind.IO as UF

16import Text.PrettyPrint as P

17

18import qualified AST.Annotation as A

19−import qualified AST.Expression.Canonical as Canonical

20import qualified AST.PrettyPrint as PP

19import qualified AST.PrettyPrint as PP

21import qualified AST.Type as ST

20import qualified AST.Type as ST

22import qualified AST.Variable as Var

21import qualified AST.Variable as Var

23−import qualified Transform.Expression as Expr

24import qualified Type.Hint as Hint

22import qualified Type.Hint as Hint

25import qualified Type.Type as TT

23import qualified Type.Type as TT

26import qualified Type.State as TS

24import qualified Type.State as TS

27

25

28

26

29−throw :: [Doc] -> Either [Doc] a

30−throw err =

31− Left [ P.vcat err ]

32−

33−

34-- MAIN TYPE

27-- MAIN TYPE

35

28

36mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

29mainType :: TS.Env -> ErrorT [P.Doc] IO (Map.Map String ST.CanonicalType)

@@ -114,181 +107,6 @@ badMainMessage typeOfMain =

114 ]

107 ]

115

108

116

109

117−-- PORT TYPES

118−

119−data Direction = In | Out

120−

121−

122−wireTypes :: (Monad m) => Canonical.Expr -> ErrorT [P.Doc] m ()

123−wireTypes expr =

124− case Expr.checkWires (checkWires In) (checkWires Out) checkLoobacks expr of

125− Left err -> throwError err

126− Right _ -> return ()

127−

128−

129−checkWires :: Direction -> String -> ST.CanonicalType -> Either [P.Doc] ()

130−checkWires direction name tipe =

131− checkWiresHelp direction name tipe tipe

132−

133−

134−checkWiresHelp

135− :: Direction

136− -> String

137− -> ST.CanonicalType

138− -> ST.CanonicalType

139− -> Either [P.Doc] ()

140−checkWiresHelp direction name rootType tipe =

141− case tipe of

142− ST.Aliased _ args t ->

143− checkWiresHelp direction name rootType (ST.dealias args t)

144−

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

146− | Var.isStream signal ->

147− validWireType False (Just Stream) direction name rootType t

148−

149− | Var.isVarying signal ->

150− validWireType False (Just Varying) direction name rootType t

151−

152− _ ->

153− validWireType False Nothing direction name rootType tipe

154−

155−

156−data Signal = Stream | Varying

157−

158−

159−validWireType

160− :: Bool

161− -> Maybe Signal

162− -> Direction

163− -> String

164− -> ST.CanonicalType

165− -> ST.CanonicalType

166− -> Either [P.Doc] ()

167−validWireType seenFunc seenSignal direction name rootType tipe =

168− let valid localType =

169− validWireType seenFunc seenSignal direction name rootType localType

170−

171− err kind =

172− throw (wireError name direction rootType tipe kind)

173− in

174− case tipe of

175− ST.Aliased _ args t ->

176− valid (ST.dealias args t)

177−

178− ST.Type v ->

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

180− True -> return ()

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

182−

183− ST.App t [] ->

184− valid t

185−

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

187− | Var.isMaybe v -> valid t

188− | Var.isArray v -> valid t

189− | Var.isList v -> valid t

190−

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

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

193−

194− ST.App _ _ ->

195− err "It contains an unsupported type"

196−

197− ST.Var _ ->

198− err "It contains a free type variable"

199−

200− ST.Lambda _ _ ->

201− case direction of

202− In -> err "It contains functions"

203− Out ->

204− if seenFunc

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

206− else

207− case seenSignal of

208− Just Stream ->

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

210−

211− Just Varying ->

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

213−

214− Nothing ->

215− forM_ (ST.collectLambdas tipe)

216− (validWireType True seenSignal direction name rootType)

217−

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

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

220−

221− ST.Record fields Nothing ->

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

223−

224−

225−wireError

226− :: String

227− -> Direction

228− -> ST.CanonicalType

229− -> ST.CanonicalType

230− -> String

231− -> [P.Doc]

232−wireError name direction rootType localType problemMessage =

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

234− , P.nest 4 $

235− P.vcat

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

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

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

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

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

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

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

243− ]

244− ]

245− where

246− dir inMsg outMsg =

247− case direction of

248− In -> inMsg

249− Out -> outMsg

250−

251− txt = P.text . concat

252−

253− wire =

254− dir "input" "output"

255−

256−

257−checkLoobacks :: String -> ST.CanonicalType -> Bool -> Either [P.Doc] ()

258−checkLoobacks name tipe hasExpr =

259− checkLoobacksHelp name tipe tipe hasExpr

260−

261−

262−checkLoobacksHelp :: String -> ST.CanonicalType -> ST.CanonicalType -> Bool -> Either [P.Doc] ()

263−checkLoobacksHelp name rootType tipe hasExpr =

264− case ST.deepDealias tipe of

265− ST.Record

266− [ ("mailbox", ST.App (ST.Type mailbox) [a])

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

268− ]

269− Nothing

270− | not hasExpr

271− && Var.isStream stream

272− && Var.isMailbox mailbox

273− && a == b

274− ->

275− return ()

276−

277− ST.App (ST.Type signal) [ ST.App (ST.Type result) [_,_] ]

278− | hasExpr && Var.isStream signal && Var.isResult result ->

279− return ()

280−

281− _ ->

282− throw $

283− [ P.text "Loopback Error:"

284− , P.nest 4 $

285− P.vcat

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

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

288− ]

289− ]

290−

291−

292-- INFINITE TYPES

110-- INFINITE TYPES

293

111

294occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

112occurs :: (String, TT.Variable) -> StateT TS.SolverState IO ()

src/Type/Inference.hs−2

@@ -33,8 +33,6 @@ infer interfaces modul =

33 hints@(_:_) -> throwError hints

34 [] -> return ()

35

36− () <- Check.wireTypes (program (body modul))

37−

38 let header' = Map.delete "::" header

36 let header' = Map.delete "::" header

39 types = Map.difference (TS.sSavedEnv state) header'

37 types = Map.difference (TS.sSavedEnv state) header'

40

38