5018b35 · elk · git.iko.soy

src/AST/Declaration.hs+56−36

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

1111import Text.PrettyPrint as P

1212

1313

14−data Declaration' port def var

14+data Declaration' wire def var

1515 = Definition def

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

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

18− | Port port

18+ | Wire wire

1919 | Fixity Assoc Int String

2020

2121

@@ -23,34 +23,38 @@ data Assoc = L | N | R

2323 deriving (Eq)

2424

2525

26−data RawPort

26+data RawWire

2727 = InputAnnotation String T.RawType

2828 | OutputAnnotation String T.RawType

29− | OutputDef String Source.Expr

29+ | OutputDefinition String Source.Expr

30+ | LoopbackAnnotation String T.RawType

31+ | LoopbackDefinition String Source.Expr

3032

3133

32−data Port expr var

33− = Out String expr (T.Type var)

34− | In String (T.Type var)

34+data Wire expr var

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

36+ | Input String (T.Type var)

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

3538

3639

3740type SourceDecl =

38− Declaration' RawPort Source.Def Var.Raw

41+ Declaration' RawWire Source.Def Var.Raw

3942

4043

4144type ValidDecl =

42− Declaration' (Port Valid.Expr Var.Raw) Valid.Def Var.Raw

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

4346

4447

4548type CanonicalDecl =

46− Declaration' (Port Canonical.Expr Var.Canonical) Canonical.Def Var.Canonical

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

4750

4851

49−portName :: Port expr var -> String

50−portName port =

51− case port of

52− Out name _ _ -> name

53− In name _ -> name

52+wireName :: Wire expr var -> String

53+wireName wire =

54+ case wire of

55+ Input name _ -> name

56+ Output name _ _ -> name

57+ Loopback name _ _ -> name

5458

5559

5660assocToString :: Assoc -> String

@@ -82,8 +86,8 @@ instance Binary Assoc where

8286

8387-- PRETTY STRINGS

8488

85−instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

86− Pretty (Declaration' port def var) where

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

90+ Pretty (Declaration' wire def var) where

8791 pretty decl =

8892 case decl of

8993 Definition def -> pretty def

@@ -109,7 +113,7 @@ instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

109113 name' =

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

111115

112− Port port -> pretty port

116+ Wire wire -> pretty wire

113117

114118 Fixity assoc prec op ->

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

@@ -121,32 +125,48 @@ instance (Pretty port, Pretty def, Pretty var, Var.ToString var) =>

121125 R -> P.text "r"

122126

123127

124−instance Pretty RawPort where

125− pretty port =

126− case port of

128+instance Pretty RawWire where

129+ pretty wire =

130+ case wire of

127131 InputAnnotation name tipe ->

128− prettyPort "input" name ":" tipe

132+ prettyWire "input" name ":" tipe

129133

130134 OutputAnnotation name tipe ->

131− prettyPort "output" name ":" tipe

135+ prettyWire "output" name ":" tipe

132136

133− OutputDef name expr ->

134− prettyPort "output" name "=" expr

137+ OutputDefinition name expr ->

138+ prettyWire "output" name "=" expr

135139

140+ LoopbackAnnotation name tipe ->

141+ prettyWire "loopback" name ":" tipe

136142

137−instance (Pretty expr, Pretty var, Var.ToString var) => Pretty (Port expr var) where

138− pretty port =

139− case port of

140− In name tipe ->

141− prettyPort "input" name ":" tipe

143+ LoopbackDefinition name expr ->

144+ prettyWire "loopback" name "=" expr

142145

143− Out name expr tipe ->

146+

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

148+ pretty wire =

149+ case wire of

150+ Input name tipe ->

151+ prettyWire "input" name ":" tipe

152+

153+ Output name expr tipe ->

154+ P.vcat

155+ [ prettyWire "output" name ":" tipe

156+ , prettyWire "output" name "=" expr

157+ ]

158+

159+ Loopback name maybeExpr tipe ->

144160 P.vcat

145− [ prettyPort "output" name ":" tipe

146− , prettyPort "output" name "=" expr

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

162+ , case maybeExpr of

163+ Just expr ->

164+ prettyWire "loopback" name "=" expr

165+ Nothing ->

166+ P.empty

147167 ]

148−

149168

150−prettyPort :: (Pretty a) => String -> String -> String -> a -> Doc

151−prettyPort keyword name op e =

169+

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

171+prettyWire keyword name op e =

152172 P.text keyword <+> P.text name <+> P.text op <+> pretty e

src/AST/Expression/General.hs+11−7

@@ -58,8 +58,9 @@ 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− | PortIn String (Type var)

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

61+ | Input String (Type var)

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

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

6364 | GLShader String String Literal.GLShaderTipe

6465 deriving (Show)

6566

@@ -87,7 +88,7 @@ saveEnvName =

8788

8889

8990dummyLet :: (Pretty def) => [def] -> Expr Annotation.Region def Var.Canonical

90−dummyLet defs =

91+dummyLet defs =

9192 Annotation.none $ Let defs (Annotation.none $ Var (Var.builtin saveEnvName))

9293

9394

@@ -194,11 +195,14 @@ instance (Pretty def, Pretty var, Var.ToString var) => Pretty (Expr' ann def var

194195 GLShader _ _ _ ->

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

196197

197− PortIn name _ ->

198− P.text $ "<port:" ++ name ++ ">"

198+ Input name _ ->

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

199200

200− PortOut _ _ signal ->

201− pretty signal

201+ Output name _ _ ->

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

203+

204+ Loopback name _ _ ->

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

202206

203207

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

src/AST/Variable.hs+8−3

@@ -63,9 +63,14 @@ isArray =

6363 is ["Array"] "Array"

6464

6565

66−isSignal :: Canonical -> Bool

67−isSignal =

68− is ["Signal"] "Signal"

66+isStream :: Canonical -> Bool

67+isStream =

68+ is ["Signal"] "Stream"

69+

70+

71+isVarying :: Canonical -> Bool

72+isVarying =

73+ is ["Signal"] "Varying"

6974

7075

7176isPromise :: Canonical -> Bool

src/Docs.hs+1−1

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

200200 in

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

202202

203− Decl.Port _ ->

203+ Decl.Wire _ ->

204204 error errorMessage

205205

206206

src/Parse/Declaration.hs+42−34

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

1212

1313declaration :: IParser D.SourceDecl

1414declaration =

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

1616

1717

1818definition :: IParser D.SourceDecl

19−definition = D.Definition <$> Expr.def

19+definition =

20+ D.Definition <$> Expr.def

2021

2122

2223typeDecl :: IParser D.SourceDecl

@@ -40,48 +41,55 @@ typeDecl =

4041

4142

4243infixDecl :: IParser D.SourceDecl

43−infixDecl = do

44− assoc <-

45− choice

46− [ try (reserved "infixl") >> return D.L

47− , try (reserved "infixr") >> return D.R

48− , try (reserved "infix") >> return D.N

49− ]

50− forcedWS

51− n <- digit

52− forcedWS

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

44+infixDecl =

45+ do assoc <-

46+ choice

47+ [ try (reserved "infixl") >> return D.L

48+ , try (reserved "infixr") >> return D.R

49+ , try (reserved "infix") >> return D.N

50+ ]

51+ forcedWS

52+ n <- digit

53+ forcedWS

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

5455

5556

5657input :: IParser D.SourceDecl

5758input =

58− do try (reserved "input")

59− whitespace

60− name <- lowVar

61− whitespace

62− ioEnding D.InputAnnotation name hasType Type.expr

59+ do name <- wireBegining "input"

60+ wireEnding (D.InputAnnotation name) hasType Type.expr

6361

6462

6563output :: IParser D.SourceDecl

6664output =

67− do try (reserved "output")

65+ do name <- wireBegining "output"

66+ choice

67+ [ wireEnding (D.OutputAnnotation name) hasType Type.expr

68+ , wireEnding (D.OutputDefinition name) equals Expr.expr

69+ ]

70+

71+

72+loopback :: IParser D.SourceDecl

73+loopback =

74+ do name <- wireBegining "loopback"

75+ choice

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

77+ , wireEnding (D.LoopbackDefinition name) equals Expr.expr

78+ ]

79+

80+

81+wireBegining :: String -> IParser String

82+wireBegining keyword =

83+ do try (reserved keyword)

6884 whitespace

6985 name <- lowVar

7086 whitespace

71− choice

72− [ ioEnding D.OutputAnnotation name hasType Type.expr

73− , ioEnding D.OutputDef name equals Expr.expr

74− ]

87+ return name

7588

7689

77−ioEnding

78− :: (String -> a -> D.RawPort)

79− -> String

80− -> IParser String

81− -> IParser a

82− -> IParser D.SourceDecl

83−ioEnding decl name op valueParser =

84− do op

85− whitespace

86− value <- valueParser

87− return (D.Port (decl name value))

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+2−2

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

3131 , "type"

3232 , "module", "where"

3333 , "import", "as", "hiding", "exposing"

34− , "export", "foreign"

34+ , "export"

3535 , "deriving"

36− , "input", "output"

36+ , "input", "output", "loopback"

3737 ]

3838

3939

src/Transform/Canonicalize.hs+24−15

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

7676 , aliases =

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

7878 , ports =

79− [ D.portName port | D.Port port <- decls ]

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

8080 }

8181

8282

@@ -181,7 +181,7 @@ declaration env decl =

181181 let canonicalize kind context pattern env v =

182182 let ctx = P.text ("Error in " ++ context) <+> pretty pattern <> P.colon

183183 throw err = P.vcat [ ctx, P.text err ]

184− in

184+ in

185185 Env.onError throw (kind env v)

186186 in

187187 case decl of

@@ -201,18 +201,24 @@ declaration env decl =

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

202202 return (D.TypeAlias name tvars expanded')

203203

204− D.Port port ->

204+ D.Wire wire ->

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

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

207− D.Port <$>

208− case port of

209− D.In name t ->

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

211− return (D.In name t')

212− D.Out name e t ->

207+ D.Wire <$>

208+ case wire of

209+ D.Input name t ->

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

211+ return (D.Input name t')

212+

213+ D.Output name e t ->

213214 do e' <- expression env e

214− t' <- canonicalize Canonicalize.tipe "port" name env t

215− return (D.Out name e' t')

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

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

217+

218+ D.Loopback name maybeExpr t ->

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

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

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

216222

217223 D.Fixity assoc prec op ->

218224 return $ D.Fixity assoc prec op

@@ -298,11 +304,14 @@ expression env (A.A ann expr) =

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

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

300306

301− PortIn name st ->

302− PortIn name <$> tipe' env st

307+ Input name tipe ->

308+ Input name <$> tipe' env tipe

309+

310+ Output name st signal ->

311+ Output name <$> tipe' env st <*> go signal

303312

304− PortOut name st signal ->

305− PortOut name <$> tipe' env st <*> go signal

313+ Loopback name st maybeExpr ->

314+ Loopback name <$> tipe' env st <*> T.traverse go maybeExpr

306315

307316 GLShader uid src tipe ->

308317 return (GLShader uid src tipe)

src/Transform/Canonicalize/Setup.hs+6−11

@@ -220,7 +220,7 @@ addTypeAlias moduleName env scc =

220220 in P.vcat [ P.text msg, P.text err ]

221221

222222 aliases ->

223− throwError

223+ throwError

224224 [ P.vcat

225225 [ P.text (eightyCharLines 0 mutuallyRecursiveMessage)

226226 , indented (map typeAlias aliases)

@@ -311,15 +311,10 @@ addDecl moduleName info@(nodes,env) decl =

311311 _values env

312312 }

313313

314− D.Port port ->

315− let portName =

316− case port of

317− D.Out name _ _ -> name

318− D.In name _ -> name

319− in

320− (,) nodes $ env

321− { _values =

322− addLocal portName (_values env)

323− }

314+ D.Wire wire ->

315+ (,) nodes $ env

316+ { _values =

317+ addLocal (D.wireName wire) (_values env)

318+ }

324319

325320 D.Fixity _ _ _ -> info

src/Transform/Check.hs+6−5

@@ -52,11 +52,12 @@ duplicateValues decls =

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

5353

5454 (portNames, portExprs) =

55− Arrow.second concat $ unzip $

56− flip map [ port | D.Port port <- decls ] $ \port ->

57− case port of

58− D.Out name expr _ -> (name, [expr])

59− D.In name _ -> (name, [])

55+ Arrow.second Maybe.catMaybes $ unzip $

56+ flip map [ wire | D.Wire wire <- decls ] $ \wire ->

57+ case wire of

58+ D.Input name _ -> (name, Nothing)

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

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

6061

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

6263 exprDups expr = Expr.crawlLet defsDups expr

src/Transform/Declaration.hs+44−27

@@ -22,15 +22,18 @@ combineAnnotations :: [D.SourceDecl] -> Either String [D.ValidDecl]

2222combineAnnotations =

2323 go

2424 where

25− msg x = "Syntax Error: The type annotation for '" ++ x ++

26− "' must be directly above its definition."

25+ errorMessage kind name =

26+ "Syntax Error: The type annotation for " ++ kind ++ " '" ++

27+ name ++ "' must be directly above its definition."

2728

28− exprCombineAnnotations = Expr.crawlLet Def.combineAnnotations

29+ exprCombineAnnotations =

30+ Expr.crawlLet Def.combineAnnotations

2931

3032 go decls =

3133 case decls of

3234 -- simple cases, pass them through with no changes

33− [] -> return []

35+ [] ->

36+ return []

3437

3538 D.Datatype name tvars ctors : rest ->

3639 (:) (D.Datatype name tvars ctors) <$> go rest

@@ -45,37 +48,49 @@ combineAnnotations =

4548 D.Definition def : defRest ->

4649 case def of

4750 Source.Definition pat expr ->

48− do expr' <- exprCombineAnnotations expr

49− let def' = Valid.Definition pat expr' Nothing

50− (:) (D.Definition def') <$> go defRest

51+ do expr' <- exprCombineAnnotations expr

52+ let def' = Valid.Definition pat expr' Nothing

53+ (:) (D.Definition def') <$> go defRest

5154

5255 Source.TypeAnnotation name tipe ->

5356 case defRest of

5457 D.Definition (Source.Definition pat@(P.Var name') expr) : rest

5558 | name == name' ->

56− do expr' <- exprCombineAnnotations expr

57− let def' = Valid.Definition pat expr' (Just tipe)

58− (:) (D.Definition def') <$> go rest

59+ do expr' <- exprCombineAnnotations expr

60+ let def' = Valid.Definition pat expr' (Just tipe)

61+ (:) (D.Definition def') <$> go rest

5962

60− _ -> Left (msg name)

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

6164

62− -- combine ports

63− D.Port port : portRest ->

64− case port of

65+ -- combine wires

66+ D.Wire wire : wireRest ->

67+ case wire of

6568 D.InputAnnotation name tipe ->

66− (:) (D.Port (D.In name tipe)) <$> go portRest

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

6770

68− D.OutputDef name _ ->

69− Left (msg name)

71+ D.OutputDefinition name _ ->

72+ Left (errorMessage "output" name)

7073

7174 D.OutputAnnotation name tipe ->

72− case portRest of

73− D.Port (D.OutputDef name' expr) : rest | name == name' ->

75+ case wireRest of

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

7477 do expr' <- exprCombineAnnotations expr

75− (:) (D.Port (D.Out name expr' tipe)) <$> go rest

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

7679

7780 _ ->

78− Left (msg name)

81+ Left (errorMessage "output" name)

82+

83+ D.LoopbackDefinition name tipe ->

84+ Left (errorMessage "loopback" 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+ (:) (D.Wire (D.Loopback name (Just expr') tipe)) <$> go rest

91+

92+ _ ->

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

7994

8095

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

@@ -122,12 +137,14 @@ toDefs moduleName decl =

122137 D.TypeAlias _ _ _ ->

123138 []

124139

125− D.Port port ->

126− case port of

127− D.Out name expr@(A.A s _) tipe ->

128− [ definition name (A.A s $ E.PortOut name tipe expr) tipe ]

129− D.In name tipe ->

130− [ definition name (A.none $ E.PortIn name tipe) tipe ]

140+ D.Wire wire ->

141+ case wire of

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

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

144+ D.Input name tipe ->

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

146+ D.Loopback name maybeExpr tipe ->

147+ [ definition name (A.none $ E.Loopback name tipe maybeExpr) tipe ]

131148

132149 -- no constraints are needed for fixity declarations

133150 D.Fixity _ _ _ ->

src/Transform/SortDefinitions.hs+8−4

@@ -111,11 +111,15 @@ reorder (A ann expr) =

111111 GLShader _ _ _ ->

112112 return expr

113113

114− PortOut name st signal ->

115− PortOut name st <$> reorder signal

114+ Input name st ->

115+ return $ Input name st

116116

117− PortIn name st ->

118− return $ PortIn name st

117+ Output name st signal ->

118+ Output name st <$> reorder signal

119+

120+ Loopback name st maybeExpr ->

121+ Loopback name st <$>

122+ maybe (return Nothing) (fmap Just . reorder) maybeExpr

119123

120124 -- Actually do some reordering

121125 Let defs body ->

src/Transform/Substitute.hs+7−4

@@ -81,8 +81,11 @@ subst old new expression =

8181

8282 GLShader _ _ _ -> expression

8383

84− PortIn name st ->

85− PortIn name st

84+ Input name st ->

85+ Input name st

8686

87− PortOut name st signal ->

88− PortOut name st (f signal)

87+ Output name st expr ->

88+ Output name st (f expr)

89+

90+ Loopback name tipe maybeExpr ->

91+ Loopback name tipe (fmap f maybeExpr)

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

@@ -165,11 +165,19 @@ constrain env (A region expr) tipe =

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

166166 (c1 /\ c))

167167

168− PortIn _ _ -> return true

168+ Input _ _ ->

169+ return true

169170

170− PortOut _ _ signal ->

171+ Output _ _ signal ->

171172 constrain env signal tipe

172173

174+ Loopback _ _ maybeExpr ->

175+ case maybeExpr of

176+ Nothing ->

177+ return true

178+ Just expr ->

179+ constrain env expr tipe

180+

173181

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

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