7c33c13 · elk · git.iko.soy

src/AST/Canonical.hs+3−3

compare with master

unifiedsplit

@@ -178,7 +178,7 @@ data AliasType

178

179data Decls

180 = Declare Def Decls

181− | DeclareRec Def [Def] Decls

181+ | DeclareRec [Def] Decls

182 | SaveTheEnvironment

183

184

@@ -244,8 +244,8 @@ data Effects

244

245

246data Port

247− = Incoming Type

247+ = Incoming FreeVars Type

248− | Outgoing Type

248+ | Outgoing FreeVars Type

249

250

251data Manager

src/Canonicalize/Effects.hs+3−3

@@ -78,7 +78,7 @@ canonicalize env decls unions effects =

78

79canonicalizePort :: Env.Env -> Valid.Port -> Result (N.Name, Can.Port)

80canonicalizePort env (Valid.Port (A.At region portName) tipe) =

81− do ctipe <- Type.canonicalize env tipe

81+ do (Can.Forall freeVars ctipe) <- Type.toAnnotation env tipe

82 case Type.deepDealias ctipe of

83 Can.TLambda outgoingType (Can.TType home name [Can.TVar _])

84 | home == ModuleName.cmd && name == "Cmd" ->

@@ -87,7 +87,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =

87 Result.throw region (Error.PortPayloadInvalid portName badType err)

88

89 Right () ->

90− Result.ok (portName, Can.Outgoing ctipe)

90+ Result.ok (portName, Can.Outgoing freeVars ctipe)

91

92 Can.TLambda (Can.TLambda incomingType (Can.TVar msg1)) (Can.TType home name [Can.TVar msg2])

93 | home == ModuleName.sub && name == "Sub" && msg1 == msg2 ->

@@ -96,7 +96,7 @@ canonicalizePort env (Valid.Port (A.At region portName) tipe) =

96 Result.throw region (Error.PortPayloadInvalid portName badType err)

97

98 Right () ->

99− Result.ok (portName, Can.Incoming ctipe)

99+ Result.ok (portName, Can.Incoming freeVars ctipe)

100

101 _ ->

102 Result.throw region (Error.PortTypeInvalid portName ctipe)

src/Canonicalize/Module.hs+2−2

@@ -156,9 +156,9 @@ detectCycles sccs =

156 Graph.CyclicSCC [] ->

157 detectCycles otherSccs

158

159− Graph.CyclicSCC (def:defs) ->

159+ Graph.CyclicSCC cyclicDefs@(def:defs) ->

160 do detectBadCycles def defs

161− Can.DeclareRec def defs <$> detectCycles otherSccs

161+ Can.DeclareRec cyclicDefs <$> detectCycles otherSccs

162

163

164toNode :: Env.Env -> A.Located Valid.Decl -> Result (Can.Def, N.Name, [N.Name])

src/Type/Constrain/Effects.hsdeleted−136

@@ -1,136 +0,0 @@

1−{-# OPTIONS_GHC -Wall #-}

2−{-# LANGUAGE OverloadedStrings #-}

3−module Type.Constrain.Effects

4− ( constrain

5− )

6− where

7−

8−

9−import Control.Monad (replicateM)

10−import qualified Data.Map.Strict as Map

11−

12−import qualified AST.Canonical as Can

13−import qualified AST.Module.Name as ModuleName

14−import qualified AST.Type as T

15−import qualified Elm.Name as N

16−import qualified Reporting.Error.Type as Error

17−import qualified Reporting.Region as R

18−import Type.Constraint (Constraint(..), Scheme(Scheme))

19−import qualified Type.Instantiate as Instantiate

20−import Type.Type (Type(..), Variable, (==>), mkFlexVar)

21−

22−

23−

24−-- CONSTRAIN

25−

26−

27−constrain :: ModuleName.Canonical -> Can.Effects -> IO ( Map.Map N.Name Type, Constraint )

28−constrain home effects =

29− case effects of

30− Can.NoEffects ->

31− return (Map.empty, CSaveEnv)

32−

33− Can.Ports ports ->

34− (,)

35− <$> traverse fromSrcType (Map.map deport ports)

36− <*> return CSaveEnv

37−

38− Can.Manager r0 r1 r2 manager ->

39− case manager of

40− Can.Cmd cmdName ->

41− do cmd <- command home cmdName

42− con <- constrainEffects r0 r1 r2 $ \msg result ->

43− effectList home cmdName msg ==> result

44− return (Map.singleton "command" cmd, con)

45−

46− Can.Sub subName ->

47− do sub <- subscription home subName

48− con <- constrainEffects r0 r1 r2 $ \msg result ->

49− effectList home subName msg ==> result

50− return (Map.singleton "subscription" sub, con)

51−

52− Can.Fx cmdName subName ->

53− do cmd <- command home cmdName

54− sub <- subscription home subName

55− con <- constrainEffects r0 r1 r2 $ \msg result ->

56− effectList home cmdName msg ==> effectList home subName msg ==> result

57− return (Map.fromList [("command", cmd),("subscription", sub)], con)

58−

59−

60−

61−-- HELPERS

62−

63−

64−deport :: Can.Port -> T.Canonical

65−deport port_ =

66− case port_ of

67− Can.Incoming tipe ->

68− tipe

69−

70− Can.Outgoing tipe ->

71− tipe

72−

73−

74−fromSrcType :: T.Canonical -> IO Type

75−fromSrcType tipe =

76− fst <$> Instantiate.flexible tipe

77−

78−

79−command :: ModuleName.Canonical -> N.Name -> IO Type

80−command home typeName =

81− fromSrcType $

82− T.Lambda

83− (T.Type home typeName [T.Var "msg"])

84− (T.Type ModuleName.cmd N.cmd [T.Var "msg"])

85−

86−

87−subscription :: ModuleName.Canonical -> N.Name -> IO Type

88−subscription home typeName =

89− fromSrcType $

90− T.Lambda

91− (T.Type home typeName [T.Var "msg"])

92− (T.Type ModuleName.sub N.sub [T.Var "msg"])

93−

94−

95−

96−-- CONSTRAINTS FOR EFFECT MANAGER STUFF

97−

98−

99−constrainEffects :: R.Region -> R.Region -> R.Region -> (Variable -> Type -> Type) -> IO Constraint

100−constrainEffects r0 r1 r2 toFinalArgs =

101− let

102− task t =

103− AppN ModuleName.platform N.task [ never, VarN t ]

104−

105− router msg selfMsg =

106− AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]

107− in

108− do vars@[v0,v1,v2,s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 10 mkFlexVar

109−

110− let

111− onEffectsType = router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)

112− onSelfMsgType = router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2

113− constrains =

114− [ CInstance r0 "init" (VarN v0)

115− , CInstance r1 "onEffects" (VarN v1)

116− , CInstance r2 "onSelfMsg" (VarN v2)

117− , CEqual (Error.Manager "init") r0 (VarN v0) (task s0)

118− , CEqual (Error.Manager "onEffects") r1 (VarN v1) onEffectsType

119− , CEqual (Error.Manager "onSelfMsg") r2 (VarN v2) onSelfMsgType

120− , CEqual (Error.State "onEffects") r1 (VarN s0) (VarN s1)

121− , CEqual (Error.State "onSelfMsg") r2 (VarN s0) (VarN s2)

122− , CEqual Error.SelfMsg r2 (VarN selfMsg1) (VarN selfMsg2)

123− ]

124−

125− return $ CLet [ Scheme [] vars Map.empty (CAnd constrains) ] CSaveEnv

126−

127−

128−{-# NOINLINE never #-}

129−never :: Type

130−never =

131− AppN ModuleName.basics "Never" []

132−

133−

134−effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type

135−effectList home name msg =

136− AppN ModuleName.list N.list [AppN home name [VarN msg]]

src/Type/Constrain/Expression.hs+2

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

1{-# OPTIONS_GHC -Wall #-}

2module Type.Constrain.Expression

3 ( constrain

4+ , constrainDef

5+ , constrainRecursiveDefs

4 )

6 )

5 where

7 where

6

8

src/Type/Constrain/Module.hsnew file+155

@@ -0,0 +1,155 @@

1+{-# OPTIONS_GHC -Wall #-}

2+{-# LANGUAGE OverloadedStrings #-}

3+module Type.Constrain.Module

4+ ( constrain

5+ )

6+ where

7+

8+

9+import Control.Monad (replicateM)

10+import qualified Data.Map.Strict as Map

11+

12+import qualified AST.Canonical as Can

13+import qualified AST.Module.Name as ModuleName

14+import qualified Elm.Name as N

15+import qualified Reporting.Annotation as A

16+import qualified Reporting.Region as R

17+import Type.Constraint

18+import qualified Type.Constrain.Expression as Expr

19+import qualified Type.Instantiate as Instantiate

20+import Type.Type (Type(..), Variable, (==>), mkFlexVar, never)

21+

22+

23+

24+-- CONSTRAIN

25+

26+

27+constrain :: Can.Module -> IO Constraint

28+constrain (Can.Module home _ _ decls _ _ _ effects) =

29+ case effects of

30+ Can.NoEffects ->

31+ constrainDecls CSaveTheEnvironment decls

32+

33+ Can.Ports ports ->

34+ do header <- traverse portToHeader ports

35+ CLet [] [] header CTrue

36+ <$> constrainDecls CSaveTheEnvironment decls

37+

38+ Can.Manager r0 r1 r2 manager ->

39+ case manager of

40+ Can.Cmd cmdName ->

41+ do header <- mkCmd home cmdName

42+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->

43+ effectList home cmdName msg ==> result

44+ CLet [] [] header CTrue <$> constrainDecls fxCon decls

45+

46+ Can.Sub subName ->

47+ do header <- mkSub home subName

48+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->

49+ effectList home subName msg ==> result

50+ CLet [] [] header CTrue <$> constrainDecls fxCon decls

51+

52+ Can.Fx cmdName subName ->

53+ do header <- Map.union <$> mkCmd home cmdName <*> mkSub home subName

54+ fxCon <- constrainEffects r0 r1 r2 $ \msg result ->

55+ effectList home cmdName msg ==> effectList home subName msg ==> result

56+ CLet [] [] header CTrue <$> constrainDecls fxCon decls

57+

58+

59+

60+-- CONSTRAIN DECLARATIONS

61+

62+

63+constrainDecls :: Constraint -> Can.Decls -> IO Constraint

64+constrainDecls finalConstraint decls =

65+ case decls of

66+ Can.Declare def otherDecls ->

67+ Expr.constrainDef Map.empty def

68+ =<< constrainDecls finalConstraint otherDecls

69+

70+ Can.DeclareRec defs otherDecls ->

71+ Expr.constrainRecursiveDefs Map.empty defs

72+ =<< constrainDecls finalConstraint otherDecls

73+

74+ Can.SaveTheEnvironment ->

75+ return finalConstraint

76+

77+

78+

79+-- PORT HELPERS

80+

81+

82+portToHeader :: Can.Port -> IO (A.Located Type)

83+portToHeader port_ =

84+ case port_ of

85+ Can.Incoming freeVars tipe ->

86+ do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars

87+ A.At zero <$> Instantiate.fromSrcType vars tipe

88+

89+ Can.Outgoing freeVars tipe ->

90+ do vars <- traverse (\_ -> VarN <$> mkFlexVar) freeVars

91+ A.At zero <$> Instantiate.fromSrcType vars tipe

92+

93+

94+{-# NOINLINE zero #-}

95+zero :: R.Region

96+zero =

97+ R.Region (R.Position 0 0) (R.Position 0 0)

98+

99+

100+

101+-- EFFECT MANAGER HELPERS

102+

103+

104+mkCmd :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))

105+mkCmd home typeName =

106+ do msg <- VarN <$> mkFlexVar

107+ return $ Map.singleton "command" $ A.At zero $

108+ FunN (AppN home typeName [msg]) (AppN ModuleName.cmd N.cmd [msg])

109+

110+

111+mkSub :: ModuleName.Canonical -> N.Name -> IO (Map.Map N.Name (A.Located Type))

112+mkSub home typeName =

113+ do msg <- VarN <$> mkFlexVar

114+ return $ Map.singleton "subscription" $ A.At zero $

115+ FunN (AppN home typeName [msg]) (AppN ModuleName.sub N.sub [msg])

116+

117+

118+constrainEffects

119+ :: R.Region

120+ -> R.Region

121+ -> R.Region

122+ -> (Variable -> Type -> Type)

123+ -> IO Constraint

124+constrainEffects r0 r1 r2 toFinalArgs =

125+ let

126+ task t =

127+ AppN ModuleName.platform N.task [ never, VarN t ]

128+

129+ router msg selfMsg =

130+ AppN ModuleName.platform N.router [ VarN msg, VarN selfMsg ]

131+

132+ equal region var tipe =

133+ CEqual region Effects (VarN var) (NoExpectation tipe)

134+ in

135+ do vars@[s0,s1,s2,msg1,msg2,selfMsg1,selfMsg2] <- replicateM 7 mkFlexVar

136+ return $

137+ CLet [] vars Map.empty

138+ (CAnd

139+ [ CLookup r0 "init" $ NoExpectation $

140+ task s0

141+ , CLookup r1 "onEffects" $ NoExpectation $

142+ router msg1 selfMsg1 ==> toFinalArgs msg1 (VarN s1 ==> task s1)

143+ , CLookup r2 "onSelfMsg" $ NoExpectation $

144+ router msg2 selfMsg2 ==> VarN selfMsg2 ==> VarN s2 ==> task s2

145+ , equal r1 s0 (VarN s1)

146+ , equal r2 s0 (VarN s2)

147+ , equal r2 selfMsg1 (VarN selfMsg2)

148+ ]

149+ )

150+ CSaveTheEnvironment

151+

152+

153+effectList :: ModuleName.Canonical -> N.Name -> Variable -> Type

154+effectList home name msg =

155+ AppN ModuleName.list N.list [AppN home name [VarN msg]]

src/Type/Constraint.hs+1

@@ -112,6 +112,7 @@ data Category

112 | Tuple

113 | Unit

114 | Shader

115+ | Effects

115

116

117

118

src/Type/Inference.hsdeleted−128

@@ -1,128 +0,0 @@

1−{-# LANGUAGE OverloadedStrings #-}

2−module Type.Inference where

3−

4−import Control.Arrow (first, second)

5−import Control.Monad.Except (Except, forM, liftIO, runExceptT, throwError)

6−import qualified Data.Map.Strict as Map

7−import qualified Data.Set as Set

8−import Data.Monoid ((<>))

9−import Data.Text (Text)

10−

11−import qualified AST.Module as Module

12−import qualified AST.Module.Name as ModuleName

13−import qualified AST.Type as Type

14−import qualified AST.Variable as Var

15−import qualified Reporting.Annotation as A

16−import qualified Reporting.Error.Type as Error

17−import qualified Type.Constraint as T

18−import qualified Type.Constrain.Expression as TcExpr

19−import qualified Type.Environment as Env

20−import qualified Type.Solve as Solve

21−import qualified Type.State as TS

22−import qualified Type.Type as T

23−

24−import System.IO.Unsafe

25− -- Maybe possible to switch over to ST instead of IO.

26− -- I don't think that'd be worthwhile though.

27−

28−

29−infer

30− :: Module.Interfaces

31− -> Module.Canonical

32− -> Except [A.Located Error.Error] (Map.Map Text Type.Canonical)

33−infer interfaces modul =

34− either throwError return $ unsafePerformIO $ runExceptT $

35− do (header, constraint) <-

36− liftIO (genConstraints interfaces modul)

37−

38− state <- Solve.solve constraint

39−

40− let header' = Map.delete "::" header

41− let types = Map.map A.drop (Map.difference (TS._savedEnv state) header')

42−

43− liftIO (traverse T.toSrcType types)

44−

45−

46−genConstraints

47− :: Module.Interfaces

48− -> Module.Canonical

49− -> IO (Map.Map Text T.Type, T.Constraint)

50−genConstraints allInterfaces modul@(Module.Module _ info) =

51− do let directDeps = toDirectDeps (Set.fromList (Module.imports info)) allInterfaces

52− let env = Env.initialize (canonicalizeUnions directDeps modul)

53−

54− ctors <-

55− {-# SCC elm_compiler_mk_ctor_types #-}

56− forM (Env.ctorNames env) $ \name ->

57− do (_, vars, args, result) <- Env.freshDataScheme env name

58− return (name, (vars, foldr T.FunN result args))

59−

60− importedVars <- mapM (canonicalizeValues env) directDeps

61−

62− let allTypes = concat (ctors : importedVars)

63− let vars = concatMap (fst . snd) allTypes

64− let header = Map.map snd (Map.fromList allTypes)

65− let environ = T.CLet [ T.Scheme vars [] T.CTrue (Map.map (A.A undefined) header) ]

66−

67− fvar <- T.mkFlexVar

68−

69− constraint <-

70− {-# SCC elm_compiler_constrain #-}

71− TcExpr.constrain env (Module.program info) (T.VarN fvar)

72−

73− return (header, environ constraint)

74−

75−

76−toDirectDeps :: Set.Set ModuleName.Raw -> Module.Interfaces -> [(ModuleName.Canonical, Module.Interface)]

77−toDirectDeps imports interfaces =

78− let

79− isDirect (ModuleName.Canonical _ name, _) =

80− Set.member name imports

81− in

82− filter isDirect (Map.toList interfaces)

83−

84−

85−canonicalizeValues

86− :: Env.Env

87− -> (ModuleName.Canonical, Module.Interface)

88− -> IO [(Text, ([T.Variable], T.Type))]

89−canonicalizeValues env (moduleName, iface) =

90− forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->

91− do (flexType, flexVars) <- Env.instantiateFlex env tipe

92− return

93− ( ModuleName.canonicalToText moduleName <> "." <> name

94− , ( Map.elems flexVars

95− , flexType

96− )

97− )

98−

99−

100−canonicalizeUnions

101− :: [(ModuleName.Canonical, Module.Interface)]

102− -> Module.Canonical

103− -> [Module.CanonicalUnion]

104−canonicalizeUnions directDeps (Module.Module name info) =

105− localUnions ++ importedUnions

106− where

107− localUnions :: [Module.CanonicalUnion]

108− localUnions =

109− format (name, Module.unions info)

110−

111− importedUnions :: [Module.CanonicalUnion]

112− importedUnions =

113− concatMap (format . second Module.iUnions) directDeps

114−

115−

116−format :: (ModuleName.Canonical, Module.Unions) -> [Module.CanonicalUnion]

117−format (home, unions) =

118− map canonical (Map.toList unions)

119− where

120− canonical :: (Text, Module.UnionInfo Text) -> Module.CanonicalUnion

121− canonical (name, (tvars, ctors)) =

122− ( toVar name

123− , (tvars, map (first toVar) ctors)

124− )

125−

126− toVar :: Text -> Var.Canonical

127− toVar name =

128− Var.fromModule home name

src/Type/Solve.hs+3−3

@@ -24,10 +24,10 @@ import qualified Type.UnionFind as UF

24

25

26

27−-- RUN

27+-- RUN SOLVER

28

29

30−run :: Constraint -> IO (Either [Error.Error] Env)

30+run :: Constraint -> IO (Either [Error.Error] (Map.Map N.Name Can.Type))

31run constraint =

32 do pools <- MVector.replicate 16 []

33

@@ -36,7 +36,7 @@ run constraint =

36

37 case errors of

38 [] ->

39− return $ Right env

39+ Right <$> traverse toSrcType env

40

41 _ ->

42 return $ Left errors

src/Type/Type.hs+6−1

@@ -13,7 +13,7 @@ module Type.Type

13 , noMark

14 , nextMark

15 , (==>)

16− , int, float, char, string, bool

16+ , int, float, char, string, bool, never

17 , vec2, vec3, vec4, mat4, texture

18 , mkFlexVar

19 , mkFlexNumber

@@ -193,6 +193,11 @@ bool :: Type

193bool = AppN ModuleName.basics "Bool" []

194

195

196+{-# NOINLINE never #-}

197+never :: Type

198+never = AppN ModuleName.basics "Never" []

199+

200+

196

201

197-- WEBGL TYPES

202-- WEBGL TYPES

198

203