52e43bb · elk · git.iko.soy

src/AST/Literal.hs+19−10

compare with master

unifiedsplit

@@ -3,7 +3,7 @@

3module AST.Literal

4 ( Literal(..)

5 , toBuilder

6− , GLType(..), glTypeToText, Shader(..)

6+ , GLType(..), glTypeToVar, Shader(..)

7 )

8 where

9

@@ -16,6 +16,10 @@ import Data.Text.Lazy.Builder (Builder, fromText)

16import Data.Text.Lazy.Builder.Int (decimal)

17import Data.Text.Lazy.Builder.RealFloat (realFloat)

18

19+import qualified AST.Module.Name as ModuleName

20+import qualified AST.Variable as Var

21+import qualified Elm.Package as Pkg

22+

19

23

20

24

21-- LITERALS

25-- LITERALS

@@ -64,16 +68,21 @@ data GLType

64 deriving (Eq)

68 deriving (Eq)

65

69

66

70

67−glTypeToText :: GLType -> Text

71+glTypeToVar :: GLType -> Var.Canonical

68−glTypeToText glTipe =

72+glTypeToVar glTipe =

69 case glTipe of

73 case glTipe of

70− V2 -> "Math.Vector2.Vec2"

74+ V2 -> inLinearAlgebra "Math.Vector2" "Vec2"

71− V3 -> "Math.Vector3.Vec3"

75+ V3 -> inLinearAlgebra "Math.Vector3" "Vec3"

72− V4 -> "Math.Vector4.Vec4"

76+ V4 -> inLinearAlgebra "Math.Vector4" "Vec4"

73− M4 -> "Math.Matrix4.Mat4"

77+ M4 -> inLinearAlgebra "Math.Matrix4" "Mat4"

74− Int -> "Int"

78+ Int -> Var.int

75− Float -> "Float"

79+ Float -> Var.float

76− Texture -> "WebGL.Texture"

80+ Texture -> Var.fromModule (ModuleName.Canonical Pkg.webgl "WebGL") "Texture"

81+

82+

83+inLinearAlgebra :: ModuleName.Raw -> Text -> Var.Canonical

84+inLinearAlgebra moduleName tipe =

85+ Var.fromModule (ModuleName.Canonical Pkg.linearAlgebra moduleName) tipe

77

86

78

87

79

88

src/AST/Type.hs+30−33

@@ -10,7 +10,7 @@ module AST.Type

10 where

11

12import Control.Arrow (second)

13−import Control.Monad (liftM, liftM2, liftM3)

13+import Control.Monad (liftM, liftM2, liftM3, replicateM)

14import Data.Binary

15import qualified Data.Map as Map

16import Data.Text (Text)

@@ -33,16 +33,14 @@ type Raw =

33data Raw'

34 = RLambda Raw Raw

35 | RVar Text

36− | RType Var.Raw

36+ | RType (A.Located Var.Raw) [Raw]

37− | RApp Raw [Raw]

38 | RRecord [(A.Located Text, Raw)] (Maybe Raw)

37 | RRecord [(A.Located Text, Raw)] (Maybe Raw)

39

38

40

39

41data Canonical

40data Canonical

42 = Lambda Canonical Canonical

41 = Lambda Canonical Canonical

43 | Var Text

42 | Var Text

44− | Type Var.Canonical

43+ | Type Var.Canonical [Canonical]

45− | App Canonical [Canonical]

46 | Record [(Text, Canonical)] (Maybe Canonical)

44 | Record [(Text, Canonical)] (Maybe Canonical)

47 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)

45 | Aliased Var.Canonical [(Text, Canonical)] (Aliased Canonical)

48 deriving (Eq, Ord)

46 deriving (Eq, Ord)

@@ -64,7 +62,7 @@ tuple region types =

64 name =

62 name =

65 Var.Raw (Help.makeTuple (length types))

63 Var.Raw (Help.makeTuple (length types))

66 in

64 in

67− A.A region (RApp (A.A region (RType name)) types)

65+ A.A region (RType (A.A region name) types)

68

66

69

67

70cmd :: ModuleName.Canonical -> Text -> Canonical

68cmd :: ModuleName.Canonical -> Text -> Canonical

@@ -80,8 +78,8 @@ sub =

80effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical

78effect :: Var.Canonical -> ModuleName.Canonical -> Text -> Canonical

81effect effectName moduleName tipe =

79effect effectName moduleName tipe =

82 Lambda

80 Lambda

83− (App (Type (Var.fromModule moduleName tipe)) [Var "msg"])

81+ (Type (Var.fromModule moduleName tipe) [Var "msg"])

84− (App (Type effectName) [Var "msg"])

82+ (Type effectName [Var "msg"])

85

83

86

84

87

85

@@ -103,11 +101,8 @@ deepDealias tipe =

103 Aliased _name args tipe' ->

101 Aliased _name args tipe' ->

104 deepDealias (dealias args tipe')

102 deepDealias (dealias args tipe')

105

103

106− Type _ ->

104+ Type name args ->

107− tipe

108−

109− App f args ->

110− App (deepDealias f) (map deepDealias args)

105+ Type name (map deepDealias args)

111

106

112

107

113iteratedDealias :: Canonical -> Canonical

108iteratedDealias :: Canonical -> Canonical

@@ -149,11 +144,8 @@ dealiasHelp typeTable tipe =

149 Aliased original args t' ->

144 Aliased original args t' ->

150 Aliased original (map (second go) args) t'

145 Aliased original (map (second go) args) t'

151

146

152− Type _ ->

147+ Type name args ->

153− tipe

154−

155− App f args ->

156− App (go f) (map go args)

148+ Type name (map go args)

157

149

158

150

159

151

@@ -183,28 +175,33 @@ instance Binary Canonical where

183 Var x ->

175 Var x ->

184 putWord8 1 >> put x

176 putWord8 1 >> put x

185

177

186− Type name ->

187− putWord8 2 >> put name

188−

189− App t1 t2 ->

190− putWord8 3 >> put t1 >> put t2

191−

192 Record fs ext ->

178 Record fs ext ->

193− putWord8 4 >> put fs >> put ext

179+ putWord8 2 >> put fs >> put ext

194

180

195 Aliased var args t ->

181 Aliased var args t ->

196− putWord8 5 >> put var >> put args >> put t

182+ putWord8 3 >> put var >> put args >> put t

183+

184+ Type name ts ->

185+ let

186+ potentialWord =

187+ length ts + 5

188+ in

189+ if potentialWord <= fromIntegral (maxBound :: Word8) then

190+ do putWord8 (fromIntegral potentialWord)

191+ put name

192+ mapM_ put ts

193+ else

194+ putWord8 4 >> put name >> put ts

197

195

198 get =

196 get =

199− do n <- getWord8

197+ do word <- getWord8

200− case n of

198+ case word of

201 0 -> liftM2 Lambda get get

199 0 -> liftM2 Lambda get get

202 1 -> liftM Var get

200 1 -> liftM Var get

203− 2 -> liftM Type get

201+ 2 -> liftM2 Record get get

204− 3 -> liftM2 App get get

205− 4 -> liftM2 Record get get

206− 5 -> liftM3 Aliased get get get

202+ 3 -> liftM3 Aliased get get get

207− _ -> error "Error reading a valid type from serialized string"

203+ 4 -> liftM2 Type get get

204+ n -> liftM2 Type get (replicateM (fromIntegral (n - 5)) get)

208

205

209

206

210instance Binary t => Binary (Aliased t) where

207instance Binary t => Binary (Aliased t) where

src/AST/Variable.hs+99−24

@@ -4,22 +4,26 @@ module AST.Variable

4 ( Raw(..)

5 , Canonical(..), Home(..)

6 , Global(..)

7− , local, topLevel, builtin, fromModule

7+ , local, topLevel, fromModule

8− , inCore, inHtml, cmd, sub

8+ , inCore, inHtml

9+ , int, float, char, string, tuple

10+ , list, cons, nil

11+ , bool, true, false

12+ , never, task, cmd, sub, router, shader

9 , isLocalHome, isCons

13 , isLocalHome, isCons

10 , is, isJson, isMaybe, isArray, isTask, isList

14 , is, isJson, isMaybe, isArray, isTask, isList

11− , isKernel, isTuple, isPrimitive, isPrim, isLocal

15+ , isKernel, isTuple, isPrim, isLocal

12 , rawToText, toText

16 , rawToText, toText

13 )

17 )

14 where

18 where

15

19

16import Data.Binary

20import Data.Binary

17import Data.Monoid ((<>))

21import Data.Monoid ((<>))

18−import qualified Data.Set as Set

19import Data.Text (Text)

22import Data.Text (Text)

20

23

21import qualified AST.Helpers as Help

24import qualified AST.Helpers as Help

22import qualified AST.Module.Name as ModuleName

25import qualified AST.Module.Name as ModuleName

26+import qualified Elm.Package as Pkg

23

27

24

28

25

29

@@ -72,11 +76,6 @@ topLevel home x =

72 Canonical (TopLevel home) x

76 Canonical (TopLevel home) x

73

77

74

78

75−builtin :: Text -> Canonical

76−builtin x =

77− Canonical BuiltIn x

78−

79−

80fromModule :: ModuleName.Canonical -> Text -> Canonical

79fromModule :: ModuleName.Canonical -> Text -> Canonical

81fromModule home name =

80fromModule home name =

82 Canonical (Module home) name

81 Canonical (Module home) name

@@ -92,6 +91,87 @@ inHtml home name =

92 Canonical (Module (ModuleName.inHtml home)) name

91 Canonical (Module (ModuleName.inHtml home)) name

93

92

94

93

94+

95+-- BUILT IN TYPES

96+

97+

98+int :: Canonical

99+int =

100+ Canonical BuiltIn "Int"

101+

102+

103+float :: Canonical

104+float =

105+ Canonical BuiltIn "Float"

106+

107+

108+char :: Canonical

109+char =

110+ Canonical BuiltIn "Char"

111+

112+

113+string :: Canonical

114+string =

115+ Canonical BuiltIn "String"

116+

117+

118+tuple :: Int -> Canonical

119+tuple size =

120+ Canonical BuiltIn (Help.makeTuple size)

121+

122+

123+

124+-- LIST

125+

126+

127+list :: Canonical

128+list =

129+ Canonical BuiltIn "List"

130+

131+

132+cons :: Canonical

133+cons =

134+ Canonical BuiltIn "::"

135+

136+

137+nil :: Canonical

138+nil =

139+ Canonical BuiltIn "[]"

140+

141+

142+

143+-- BOOLEANS

144+

145+

146+bool :: Canonical

147+bool =

148+ Canonical BuiltIn "Bool"

149+

150+

151+true :: Canonical

152+true =

153+ Canonical BuiltIn "True"

154+

155+

156+false :: Canonical

157+false =

158+ Canonical BuiltIn "False"

159+

160+

161+

162+-- CORE TYPES

163+

164+

165+never :: Canonical

166+never =

167+ inCore "Basics" "Never"

168+

169+

170+task :: Canonical

171+task =

172+ inCore "Platform" "Task"

173+

174+

95cmd :: Canonical

175cmd :: Canonical

96cmd =

176cmd =

97 inCore "Platform.Cmd" "Cmd"

177 inCore "Platform.Cmd" "Cmd"

@@ -102,6 +182,16 @@ sub =

102 inCore "Platform.Sub" "Sub"

182 inCore "Platform.Sub" "Sub"

103

183

104

184

185+router :: Canonical

186+router =

187+ inCore "Platform" "Router"

188+

189+

190+shader :: Canonical

191+shader =

192+ fromModule (ModuleName.Canonical Pkg.webgl "WebGL") "Shader"

193+

194+

105

195

106-- VARIABLE RECOGNIZERS

196-- VARIABLE RECOGNIZERS

107

197

@@ -181,21 +271,6 @@ isTuple var =

181 False

271 False

182

272

183

273

184−isPrimitive :: Canonical -> Bool

185−isPrimitive var =

186− case var of

187− Canonical BuiltIn name ->

188− Set.member name primitiveSet

189−

190− _ ->

191− False

192−

193−

194−primitiveSet :: Set.Set Text

195−primitiveSet =

196− Set.fromList ["Int","Float","String","Bool"]

197−

198−

199isPrim :: Text -> Canonical -> Bool

274isPrim :: Text -> Canonical -> Bool

200isPrim prim (Canonical home name) =

275isPrim prim (Canonical home name) =

201 case home of

276 case home of

src/Canonicalize/Body.hs+1−3

@@ -57,9 +57,7 @@ unionToDefs moduleName (A.A (region,_) (Decl.Type name tvars constructors)) =

57 generateArgs (length tipes) []

58

59 tbody =

60− Type.App

61− (Type.Type (Var.fromModule moduleName name))

60+ Type.Type (Var.fromModule moduleName name) (map Type.Var tvars)

62− (map Type.Var tvars)

63

61

64 body =

62 body =

65 A.A region $

63 A.A region $

src/Canonicalize/Effects.hs+25−13

@@ -8,6 +8,7 @@ module Canonicalize.Effects

8 where

9

10import qualified Data.Foldable as F

11+import qualified Data.Set as Set

11import Data.Text (Text)

12import Data.Text (Text)

12

13

13import qualified AST.Effects as Effects

14import qualified AST.Effects as Effects

@@ -69,12 +70,12 @@ canonicalizeRawPort env (A.A ann (Effects.PortRaw name rawType)) =

69figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind

70figureOutKind :: R.Region -> Text -> T.Canonical -> Result Effects.Kind

70figureOutKind region name rootType =

71figureOutKind region name rootType =

71 case T.deepDealias rootType of

72 case T.deepDealias rootType of

72− T.Lambda outgoingType (T.App (T.Type effect) [T.Var _])

73+ T.Lambda outgoingType (T.Type effect [T.Var _])

73 | effect == Var.cmd ->

74 | effect == Var.cmd ->

74 pure (Effects.Outgoing outgoingType)

75 pure (Effects.Outgoing outgoingType)

75 <* checkPortType (makeError region name) outgoingType

76 <* checkPortType (makeError region name) outgoingType

76

77

77− T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.App (T.Type effect) [T.Var msg2])

78+ T.Lambda (T.Lambda incomingType (T.Var msg1)) (T.Type effect [T.Var msg2])

78 | effect == Var.sub && msg1 == msg2 ->

79 | effect == Var.sub && msg1 == msg2 ->

79 pure (Effects.Incoming incomingType)

80 pure (Effects.Incoming incomingType)

80 <* checkPortType (makeError region name) incomingType

81 <* checkPortType (makeError region name) incomingType

@@ -109,26 +110,22 @@ checkPortType mkError tipe =

109 T.Aliased _ args aliasedType ->

110 T.Aliased _ args aliasedType ->

110 check (T.dealias args aliasedType)

111 check (T.dealias args aliasedType)

111

112

112− T.Type name ->

113+ T.Type name [] ->

113− if Var.isJson name || Var.isPrimitive name || Var.isTuple name then

114+ if Var.isJson name || isPrimitive name || Var.isTuple name then

114 return ()

115 return ()

115

116

116 else

117 else

117 throw Nothing

118 throw Nothing

118

119

119− T.App name [] ->

120− check name

121−

122− T.App (T.Type name) [arg]

120+ T.Type name [arg]

123 | Var.isMaybe name -> check arg

121 | Var.isMaybe name -> check arg

124 | Var.isArray name -> check arg

122 | Var.isArray name -> check arg

125 | Var.isList name -> check arg

123 | Var.isList name -> check arg

126

124

127− T.App (T.Type name) args

125+ T.Type name args ->

128− | Var.isTuple name ->

126+ if Var.isTuple name then

129− F.traverse_ check args

127+ F.traverse_ check args

130−

128+ else

131− T.App _ _ ->

132 throw Nothing

129 throw Nothing

133

130

134 T.Var _ ->

131 T.Var _ ->

@@ -142,3 +139,18 @@ checkPortType mkError tipe =

142

139

143 T.Record fields Nothing ->

140 T.Record fields Nothing ->

144 F.traverse_ (\(k,v) -> (,) k <$> check v) fields

141 F.traverse_ (\(k,v) -> (,) k <$> check v) fields

142+

143+

144+isPrimitive :: Var.Canonical -> Bool

145+isPrimitive var =

146+ case var of

147+ Var.Canonical Var.BuiltIn name ->

148+ Set.member name primitiveSet

149+

150+ _ ->

151+ False

152+

153+

154+primitiveSet :: Set.Set Text

155+primitiveSet =

156+ Set.fromList ["Int","Float","String","Bool"]

src/Canonicalize/Environment.hs+25−20

@@ -115,27 +115,32 @@ insert key value =

115

116builtinPatches :: [Patch]

117builtinPatches =

118− concat

118+ valuePatches ++ unionPatches ++ patternPatches

119− [ map (patch Value) tupleNames

120− , map (patch Union) (tupleNames ++ ["List","Int","Float","Char","Bool","String"])

121− , map (patternPatch) (tuples ++ [ ("::", 2), ("[]", 0) ])

122− ]

123 where

119 where

124− patch mkPatch name =

120+ validTupleSizes =

125− mkPatch name (Var.builtin name)

121+ [0..9]

126−

122+

127− patternPatch (name, args) =

123+ valuePatches :: [Patch]

128− Pattern name (Var.builtin name, args)

124+ valuePatches =

129−

125+ map (\n -> Value (Help.makeTuple n) (Var.tuple n)) validTupleSizes

130− tupleNames =

126+

131− map fst tuples

127+ unionPatches :: [Patch]

132−

128+ unionPatches =

133− tuples =

129+ [ Union "List" Var.list

134− map toTuple [0..9]

130+ , Union "Int" Var.int

135−

131+ , Union "Float" Var.float

136− toTuple :: Int -> (Text, Int)

132+ , Union "Char" Var.char

137− toTuple n =

133+ , Union "Bool" Var.bool

134+ , Union "String" Var.string

135+ ]

136+ ++ map (\n -> Union (Help.makeTuple n) (Var.tuple n)) validTupleSizes

137+

138+ patternPatches :: [Patch]

139+ patternPatches =

140+ [ Pattern "::" (Var.cons, 2)

141+ , Pattern "[]" (Var.nil, 0)

142+ ]

138− ( Help.makeTuple n, n )

143+ ++ map (\n -> Pattern (Help.makeTuple n) (Var.tuple n, n)) validTupleSizes

139

144

140

145

141

146

src/Canonicalize/Setup.hs+2−5

@@ -264,11 +264,8 @@ node region name tvars alias =

264 Type.RVar _ ->

265 []

266

267− Type.RType (Var.Raw x) ->

267+ Type.RType (A.A _ (Var.Raw x)) args ->

268− [x]

269−

270− Type.RApp t ts ->

271− edges t ++ concatMap edges ts

268+ x : concatMap edges args

272

269

273 Type.RRecord fs ext ->

270 Type.RRecord fs ext ->

274 maybe [] edges ext ++ concatMap (edges . snd) fs

271 maybe [] edges ext ++ concatMap (edges . snd) fs

src/Canonicalize/Type.hs+11−29

@@ -19,7 +19,7 @@ import qualified Reporting.Result as Result

19

20

21tipe :: Env.Env -> T.Raw -> Result T.Canonical

22−tipe env annType@(A.A _ typ) =

22+tipe env (A.A _ typ) =

23 let

24 go =

25 tipe env

@@ -31,11 +31,8 @@ tipe env annType@(A.A _ typ) =

31 T.RVar x ->

32 Result.ok (T.Var x)

33

34− T.RType _ ->

34+ T.RType name args ->

35− canonicalizeApp env annType []

36−

37− T.RApp t ts ->

38− canonicalizeApp env t ts

35+ canonicalizeApp env name args

39

36

40 T.RLambda a b ->

37 T.RLambda a b ->

41 T.Lambda <$> go a <*> go b

38 T.Lambda <$> go a <*> go b

@@ -44,30 +41,15 @@ tipe env annType@(A.A _ typ) =

44 T.Record <$> traverse goField fields <*> traverse go ext

41 T.Record <$> traverse goField fields <*> traverse go ext

45

42

46

43

47−canonicalizeApp :: Env.Env -> T.Raw -> [T.Raw] -> Result T.Canonical

44+canonicalizeApp :: Env.Env -> A.Located Var.Raw -> [T.Raw] -> Result T.Canonical

48−canonicalizeApp env annFunc@(A.A region func) args =

45+canonicalizeApp env (A.A region (Var.Raw rawName)) args =

49− case func of

50− T.RType (Var.Raw rawName) ->

51− canonicalizeWithTvar =<< Canonicalize.tvar region env rawName

46+ do tvar <- Canonicalize.tvar region env rawName

52−

53− _ ->

54− T.App

55− <$> tipe env annFunc

56− <*> traverse (tipe env) args

57−

58− where

59− canonicalizeWithTvar tvar =

60− case tvar of

47+ case tvar of

61− Right alias ->

48+ Right alias ->

62− canonicalizeAlias region env alias args

49+ canonicalizeAlias region env alias args

63−

64− Left name ->

65− case args of

66− [] ->

67− Result.ok (T.Type name)

68

50

69− _ ->

51+ Left name ->

70− T.App (T.Type name) <$> traverse (tipe env) args

52+ T.Type name <$> traverse (tipe env) args

71

53

72

54

73canonicalizeAlias

55canonicalizeAlias

src/Elm/Compiler/Type.hs+18−30

@@ -35,8 +35,7 @@ import Json.Encode ((==>))

35data Type

36 = Lambda Type Type

37 | Var Text

38− | Type Text

38+ | Type Text [Type]

39− | App Type [Type]

40 | Record [(Text, Type)] (Maybe Type)

39 | Record [(Text, Type)] (Maybe Type)

41

40

42

41

@@ -88,17 +87,14 @@ toDoc context tipe =

88 Var name ->

87 Var name ->

89 P.text (Text.unpack name)

88 P.text (Text.unpack name)

90

89

91− Type name ->

90+ Type name [] ->

92− P.text (Text.unpack (if name == Help.zeroTuple then "()" else name))

91+ P.text (if name == Help.zeroTuple then "()" else Text.unpack name)

93

92

94− App (Type name) args ->

93+ Type name arguments@(arg:args) ->

95− if name == Help.zeroTuple then

96− P.text "()"

97−

98− else if Help.isTuple name then

94+ if Help.isTuple name then

99 P.sep

95 P.sep

100− [ P.cat (zipWith (<+>) (P.lparen : repeat P.comma) (map (toDoc None) args))

96+ [ P.cat ("(" <+> toDoc None arg : map (\a -> "," <+> toDoc None a) args)

101− , P.rparen

97+ , ")"

102 ]

98 ]

103

99

104 else

100 else

@@ -107,20 +103,15 @@ toDoc context tipe =

107 P.hang

103 P.hang

108 (P.text (Text.unpack name))

104 (P.text (Text.unpack name))

109 2

105 2

110− (P.sep $ map (toDoc InType) args)

106+ (P.sep $ map (toDoc InType) arguments)

111 in

107 in

112− case (context, args) of

108+ case context of

113− (InType, _ : _) ->

109+ InType ->

114 P.parens application

110 P.parens application

115

111

116 _ ->

112 _ ->

117 application

113 application

118

114

119− App _ _ ->

120− error $

121− "Somehow ended up with an unexpected type, please post a minimal example that\n"

122− ++ "reproduces this error to <https://github.com/elm-lang/elm-compiler/issues>"

123−

124 Record _ _ ->

115 Record _ _ ->

125 case flattenRecord tipe of

116 case flattenRecord tipe of

126 ([], Nothing) ->

117 ([], Nothing) ->

@@ -128,22 +119,22 @@ toDoc context tipe =

128

119

129 (fields, Nothing) ->

120 (fields, Nothing) ->

130 P.sep

121 P.sep

131− [ P.cat (zipWith (<+>) (P.lbrace : repeat P.comma) (map prettyField fields))

122+ [ P.cat (zipWith (<+>) ("{" : repeat ",") (map prettyField fields))

132− , P.rbrace

123+ , "}"

133 ]

124 ]

134

125

135 (fields, Just x) ->

126 (fields, Just x) ->

136 P.hang

127 P.hang

137− (P.lbrace <+> P.text (Text.unpack x) <+> P.text "|")

128+ ("{" <+> P.text (Text.unpack x) <+> "|")

138 4

129 4

139 (P.sep

130 (P.sep

140− [ P.sep (P.punctuate P.comma (map prettyField fields))

131+ [ P.sep (P.punctuate "," (map prettyField fields))

141− , P.rbrace

132+ , "}"

142 ]

133 ]

143 )

134 )

144 where

135 where

145 prettyField (field, fieldType) =

136 prettyField (field, fieldType) =

146− P.text (Text.unpack field) <+> P.text ":" <+> toDoc None fieldType

137+ P.text (Text.unpack field) <+> ":" <+> toDoc None fieldType

147

138

148

139

149collectLambdas :: Type -> [Type]

140collectLambdas :: Type -> [Type]

@@ -200,11 +191,8 @@ fromRawType (A.A _ astType) =

200 Type.RVar x ->

191 Type.RVar x ->

201 Var x

192 Var x

202

193

203− Type.RType var ->

194+ Type.RType (A.A _ name) args ->

204− Type (Var.rawToText var)

195+ Type (Var.rawToText name) (map fromRawType args)

205−

206− Type.RApp t ts ->

207− App (fromRawType t) (map fromRawType ts)

208

196

209 Type.RRecord fields ext ->

197 Type.RRecord fields ext ->

210 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)

198 Record (map (A.drop *** fromRawType) fields) (fmap fromRawType ext)

src/Elm/Compiler/Type/Extract.hs+5−8

@@ -50,12 +50,9 @@ extractHelp astType =

50 T.Var x ->

51 return (Var x)

52

53− T.Type var ->

53+ T.Type var args ->

54 do Writer.tell ( Set.empty, Set.singleton var )

55− return (Type (Var.toText var))

55+ Type (Var.toText var) <$> traverse extractHelp args

56−

57− T.App constructor args ->

58− App <$> extractHelp constructor <*> traverse extractHelp args

59

56

60 T.Record fields ext ->

57 T.Record fields ext ->

61 Record

58 Record

@@ -65,7 +62,7 @@ extractHelp astType =

65 T.Aliased name args aliasedType ->

62 T.Aliased name args aliasedType ->

66 do Writer.tell ( Set.singleton name, Set.empty )

63 do Writer.tell ( Set.singleton name, Set.empty )

67 _ <- extractHelp (T.dealias args aliasedType)

64 _ <- extractHelp (T.dealias args aliasedType)

68− App (Type (Var.toText name)) <$> traverse (extractHelp . snd) args

65+ Type (Var.toText name) <$> traverse (extractHelp . snd) args

69

66

70

67

71

68

@@ -79,8 +76,8 @@ extractProgram interfaces name =

79

76

80 message <-

77 message <-

81 case T.deepDealias mainType of

78 case T.deepDealias mainType of

82− T.App _program [_flags, _model, msg] -> Just msg

79+ T.Type _program [_flags, _model, msg] -> Just msg

83− T.App _node [msg] -> Just msg

80+ T.Type _node [msg] -> Just msg

84 _ -> Nothing

81 _ -> Nothing

85

82

86 let (msgType, msgDeps) = Writer.runWriter (extractHelp message)

83 let (msgType, msgDeps) = Writer.runWriter (extractHelp message)

src/Elm/Package.hs+11−1

@@ -3,7 +3,7 @@

3module Elm.Package

4 ( Name(..)

5 , Package(..)

6− , dummyName, core, virtualDom, html

6+ , dummyName, core, virtualDom, html, webgl, linearAlgebra

7 , toString, toText, toUrl, toFilePath

8 , fromText

9 , Version(..)

@@ -77,6 +77,16 @@ html =

77 Name "elm-lang" "html"

78

79

80+webgl :: Name

81+webgl =

82+ Name "elm-community" "webgl"

83+

84+

85+linearAlgebra :: Name

86+linearAlgebra =

87+ Name "elm-community" "linear-algebra"

88+

89+

80toString :: Name -> String

90toString :: Name -> String

81toString name =

91toString name =

82 Text.unpack (toText name)

92 Text.unpack (toText name)

src/Nitpick/Pattern.hs+2−2

@@ -49,10 +49,10 @@ fromCanonicalPattern (A.A _ pattern) =

49 Anything

50

51 P.Literal (L.Boolean True) ->

52− Ctor (Var.builtin "True") []

52+ Ctor Var.true []

53

54 P.Literal (L.Boolean False) ->

55− Ctor (Var.builtin "False") []

55+ Ctor Var.false []

56

57 P.Literal literal ->

58 Literal literal

src/Nitpick/PatternMatches.hs+3−7

@@ -405,10 +405,10 @@ builtinDict :: ArityDict

405builtinDict =

406 let

407 listInfo =

408− ArityInfo 2 [ (Var.builtin "::", 2), (Var.builtin "[]", 0) ]

408+ ArityInfo 2 [ (Var.cons, 2), (Var.nil, 0) ]

409

410 boolInfo =

411− ArityInfo 2 [ (Var.builtin "True", 0), (Var.builtin "False", 0) ]

411+ ArityInfo 2 [ (Var.true, 0), (Var.false, 0) ]

412 in

413 Map.singleton Var.BuiltIn $ Map.fromList $

414 [ ("::", listInfo)

@@ -421,11 +421,7 @@ builtinDict =

421

422makeTupleInfo :: Int -> ( Text, ArityInfo )

423makeTupleInfo n =

424− let

425− name =

426− Help.makeTuple n

424+ ( Help.makeTuple n, ArityInfo 1 [ (Var.tuple n, n) ] )

427− in

428− ( name, ArityInfo 1 [ (Var.builtin name, n) ] )

429

425

430

426

431toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo

427toArityEntry :: ModuleName.Canonical -> Module.Unions -> Map.Map Text ArityInfo

src/Nitpick/TopLevelTypes.hs+7−7

@@ -87,11 +87,11 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

87

88 getMainKind =

89 case Type.deepDealias mainType of

90− Type.App name [_]

90+ Type.Type name [_]

91 | name == vdomNode ->

92 return Can.VDom

93

94− Type.App name [flags, _, _]

94+ Type.Type name [flags, _, _]

95 | name == program && flags == never ->

96 return Can.NoFlags

97

@@ -107,21 +107,21 @@ checkMain typeEnv (Can.Def facts pattern@(A.A region _) body maybeType) =

107 return (Can.Def facts pattern newBody maybeType)

108

109

110−program :: Type.Canonical

110+program :: Var.Canonical

111program =

112− Type.Type (Var.inCore "Platform" "Program")

112+ Var.inCore "Platform" "Program"

113

114

115never :: Type.Canonical

116never =

117− Type.Type (Var.inCore "Basics" "Never")

117+ Type.Type (Var.inCore "Basics" "Never") []

118

119

120−vdomNode :: Type.Canonical

120+vdomNode :: Var.Canonical

121vdomNode =

122 let

123 vdom =

124 ModuleName.Canonical Pkg.virtualDom "VirtualDom"

125 in

126− Type.Type (Var.fromModule vdom "Node")

126+ Var.fromModule vdom "Node"

127

src/Optimize/Port.hs+8−8

@@ -38,7 +38,7 @@ toEncoder tipe =

38 T.Var _ ->

39 error "toEncoder: type variable"

40

41− T.Type name

41+ T.Type name []

42 | Var.isPrim "Float" name -> encode "float"

43 | Var.isPrim "Int" name -> encode "int"

44 | Var.isPrim "Bool" name -> encode "bool"

@@ -47,16 +47,16 @@ toEncoder tipe =

47 | Var.isTuple name -> encode "null"

48 | otherwise -> error "toEncoder: bad type"

49

50− T.App (T.Type name) [arg]

50+ T.Type name [arg]

51 | Var.isMaybe name -> encodeMaybe arg

52 | Var.isList name -> encodeList arg

53 | Var.isArray name -> encodeArray arg

54 | otherwise -> error "toEncoder: bad union type"

55

56− T.App (T.Type name) args

56+ T.Type name args

57 | Var.isTuple name -> encodeTuple args

58

59− T.App _ _ ->

59+ T.Type _ _ ->

60 error "toEncoder: bad union type"

61

62 T.Record _ (Just _) ->

@@ -142,7 +142,7 @@ toDecoder tipe =

142 T.Aliased _ args t ->

143 toDecoder (T.dealias args t)

144

145− T.Type name

145+ T.Type name []

146 | Var.isPrim "Float" name -> decode "float"

147 | Var.isPrim "Int" name -> decode "int"

148 | Var.isPrim "Bool" name -> decode "bool"

@@ -151,16 +151,16 @@ toDecoder tipe =

151 | Var.isTuple name -> decodeTuple0

152 | otherwise -> error "toDecoder: bad type"

153

154− T.App (T.Type name) [arg]

154+ T.Type name [arg]

155 | Var.isMaybe name -> decodeMaybe arg

156 | Var.isList name -> decodeList arg

157 | Var.isArray name -> decodeArray arg

158 | otherwise -> error "toDecoder: bad union type"

159

160− T.App (T.Type name) args

160+ T.Type name args

161 | Var.isTuple name -> decodeTuple args

162

163− T.App _ _ ->

163+ T.Type _ _ ->

164 error "toDecoder: bad union type"

165

166 T.Record _ (Just _) ->

src/Parse/Type.hs+11−16

@@ -21,7 +21,7 @@ term =

21 hint E.Type $

22 do start <- getPosition

23 oneOf

24− [ constructor

24+ [ app0

25 , variable start

26 , tuple start

27 , record start

@@ -67,28 +67,23 @@ expression =

67-- TYPE CONSTRUCTORS

68

69

70−constructor :: Parser Type.Raw

70+app0 :: Parser Type.Raw

71−constructor =

71+app0 =

72− addLocation $

72+ do start <- getPosition

73− fmap (Type.RType . Var.Raw) qualifiedCapVar

73+ name <- qualifiedCapVar

74+ end <- getPosition

75+ return (A.at start end (Type.RType (A.at start end (Var.Raw name)) []))

74

76

75

77

76app :: R.Position -> SParser Type.Raw

78app :: R.Position -> SParser Type.Raw

77app start =

79app start =

78− do ctor <- constructor

80+ do ctor <- qualifiedCapVar

79 ctorEnd <- getPosition

81 ctorEnd <- getPosition

82+ let name = A.at start ctorEnd (Var.Raw ctor)

80 ctorPos <- whitespace

83 ctorPos <- whitespace

81 (args, end, pos) <- eatArgs [] ctorEnd ctorPos

84 (args, end, pos) <- eatArgs [] ctorEnd ctorPos

82− case args of

83− [] ->

84− return ( ctor, end, pos )

85−

86− _ ->

87− let

88− tipe =

89− A.at start end (Type.RApp ctor args)

85+ let tipe = A.at start end (Type.RType name args)

90− in

91− return ( tipe, end, pos )

86+ return ( tipe, end, pos )

92

87

93

88

94unionConstructor :: SParser (Text, [Type.Raw])

89unionConstructor :: SParser (Text, [Type.Raw])

src/Reporting/Error/Canonicalize.hs+2−5

@@ -361,11 +361,8 @@ unsafePromote (A.A _ rawType) =

361 Type.RVar x ->

362 Type.Var x

363

364− Type.RType (Var.Raw name) ->

364+ Type.RType (A.A _ (Var.Raw name)) args ->

365− Type.Type (Var.local name)

365+ Type.Type (Var.local name) (map unsafePromote args)

366−

367− Type.RApp func args ->

368− Type.App (unsafePromote func) (map unsafePromote args)

369

366

370 Type.RRecord fields ext ->

367 Type.RRecord fields ext ->

371 Type.Record (map (A.drop *** unsafePromote) fields) (fmap unsafePromote ext)

368 Type.Record (map (A.drop *** unsafePromote) fields) (fmap unsafePromote ext)

src/Reporting/Error/Type.hs+2−2

@@ -24,7 +24,7 @@ import qualified Reporting.Render.Type as RenderType

24import qualified Reporting.Report as Report

25import qualified Reporting.Helpers as Help

26import Reporting.Helpers

27− ( Doc, (<>), (<+>), capitalize, colon, dullyellow, fillSep, functionName

27+ ( Doc, (<>), (<+>), capitalize, dullyellow, fillSep, functionName

28 , i2t, indent, ordinalize, reflowParagraph, stack, text, underline, vcat

29 )

30

@@ -847,7 +847,7 @@ doubleRigidError maybeLeftName maybeRightName =

847

848hintDoc :: Doc

849hintDoc =

850− underline (text "Hint") <> colon

850+ underline (text "Hint") <> ":"

851

852

853toHint :: Text -> Doc

src/Reporting/Helpers.hs+2−3

@@ -3,9 +3,8 @@

3module Reporting.Helpers

4 ( (|>)

5 -- re-exports

6− , Doc, (<+>), (<>), cat, colon, comma, dullyellow, equals, fillSep, hang

6+ , Doc, (<+>), (<>), cat, dullyellow, fillSep, hang

7− , hsep, indent, lbrace, lparen, parens, rbrace, rparen, sep, text, underline

7+ , hsep, indent, parens, sep, text, underline, vcat

8− , vcat

9 -- custom helpers

8 -- custom helpers

10 , i2t

9 , i2t

11 , functionName, args

10 , functionName, args

src/Reporting/Render/Type.hs+35−54

@@ -19,10 +19,7 @@ import qualified AST.Helpers as Help

19import qualified AST.Type as Type

20import qualified AST.Variable as Var

21import qualified Reporting.Helpers as Help

22−import Reporting.Helpers

22+import Reporting.Helpers ( Doc, (<+>), cat, dullyellow, hang, hsep, parens, sep, text, vcat )

23− ( Doc, (<+>), cat, colon, comma, dullyellow, equals, hang, hsep

24− , lbrace, lparen, parens, rbrace, rparen, sep, text, vcat

25− )

26

23

27

24

28

25

@@ -51,11 +48,9 @@ decl localizer name vars tags =

51 hang 2 (sep (text tag : map (docType localizer App) args))

48 hang 2 (sep (text tag : map (docType localizer App) args))

52 in

49 in

53 hang 4 $ vcat $

50 hang 4 $ vcat $

54− (hsep (text "type" : map text (name : vars)))

51+ (hsep ("type" : map text (name : vars)))

55 :

52 :

56− zipWith (<+>)

57− (equals : repeat (text "|"))

58− (map docTag tags)

53+ zipWith (<+>) ("=" : repeat "|") (map docTag tags)

59

54

60

55

61annotation :: Localizer -> Text -> Type.Canonical -> Doc

56annotation :: Localizer -> Text -> Type.Canonical -> Doc

@@ -69,12 +64,12 @@ annotation localizer name tipe =

69 hang 4 $ sep $

64 hang 4 $ sep $

70 docName

65 docName

71 : zipWith (<+>)

66 : zipWith (<+>)

72− (colon : repeat (text "->"))

67+ (":" : repeat "->")

73 (map (docType localizer Func) parts)

68 (map (docType localizer Func) parts)

74

69

75 _ ->

70 _ ->

76 hang 4 $ sep $

71 hang 4 $ sep $

77− [ docName <+> colon

72+ [ docName <+> ":"

78 , docType localizer None tipe

73 , docType localizer None tipe

79 ]

74 ]

80

75

@@ -185,10 +180,7 @@ diff localizer context leftType rightType =

185 (Type.Var x, Type.Var y) | x == y ->

180 (Type.Var x, Type.Var y) | x == y ->

186 pure (text x)

181 pure (text x)

187

182

188− (Type.Type leftName, Type.Type rightName) | leftName == rightName ->

189− pure (varToDoc localizer leftName)

190−

191− (Type.App (Type.Type leftName) leftArgs, Type.App (Type.Type rightName) rightArgs) ->

183+ (Type.Type leftName leftArgs, Type.Type rightName rightArgs) ->

192 if leftName /= rightName || length leftArgs /= length rightArgs then

184 if leftName /= rightName || length leftArgs /= length rightArgs then

193 difference

185 difference

194 (docApp localizer context leftName leftArgs)

186 (docApp localizer context leftName leftArgs)

@@ -202,9 +194,6 @@ diff localizer context leftType rightType =

202 docAppHelp localizer context leftName

194 docAppHelp localizer context leftName

203 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)

195 <$> sequenceA (zipWith (go subContext) leftArgs rightArgs)

204

196

205− (Type.App _ _, Type.App _ _) ->

206− error "Type applications without concrete names should not get here."

207−

208 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->

197 (Type.Record outerLeftFields outerLeftExt, Type.Record outerRightFields outerRightExt) ->

209 let

198 let

210 (leftFields, leftExt) =

199 (leftFields, leftExt) =

@@ -404,15 +393,9 @@ docType localizer context tipe =

404 Type.Var x ->

393 Type.Var x ->

405 text x

394 text x

406

395

407− Type.Type name ->

396+ Type.Type name args ->

408− varToDoc localizer name

409−

410− Type.App (Type.Type name) args ->

411 docApp localizer context name args

397 docApp localizer context name args

412

398

413− Type.App _ _ ->

414− error "type applications should start with a type atom"

415−

416 Type.Record outerFields outerExt ->

399 Type.Record outerFields outerExt ->

417 let

400 let

418 (fields, ext) =

401 (fields, ext) =

@@ -436,13 +419,13 @@ docLambda context docs =

436 arg:rest ->

419 arg:rest ->

437 case context of

420 case context of

438 None ->

421 None ->

439− sep (arg : map (text "->" <+>) rest)

422+ sep (arg : map ("->" <+>) rest)

440

423

441 _ ->

424 _ ->

442 cat

425 cat

443− [ lparen

426+ [ "("

444− , sep (arg : map (text "->" <+>) rest)

427+ , sep (arg : map ("->" <+>) rest)

445− , rparen

428+ , ")"

446 ]

429 ]

447

430

448

431

@@ -457,27 +440,25 @@ docApp localizer context name args =

457

440

458

441

459docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc

442docAppHelp :: Localizer -> Context -> Var.Canonical -> [Doc] -> Doc

460−docAppHelp localizer context name args =

443+docAppHelp localizer context name arguments =

461− if Var.isTuple name then

462− sep

463− [ cat (zipWith (<+>) (lparen : repeat comma) args)

464− , rparen

465− ]

466−

467− else if null args then

468− varToDoc localizer name

469−

470− else

471− case context of

444+ case arguments of

472− App ->

445+ [] ->

473− cat

474− [ lparen

475− , hang 4 (sep (varToDoc localizer name : args))

446+ if Var.isTuple name then "()" else varToDoc localizer name

476− , rparen

477− ]

478

447

448+ arg : args ->

449+ if Var.isTuple name then

450+ sep

451+ [ cat ("(" <+> arg : map ("," <+>) args)

452+ , ")"

453+ ]

454+

455+ else

456+ case context of

457+ App ->

458+ cat [ "(", hang 4 (sep (varToDoc localizer name : arg : args)), ")" ]

459+

479− _ ->

460+ _ ->

480− hang 4 (sep (varToDoc localizer name : args))

461+ hang 4 (sep (varToDoc localizer name : arg : args))

481

462

482

463

483

464

@@ -490,7 +471,7 @@ docRecord :: Style -> [(Doc,Doc)] -> Maybe Doc -> Doc

490docRecord style fields maybeExt =

471docRecord style fields maybeExt =

491 let

472 let

492 docField (name, tipe) =

473 docField (name, tipe) =

493− hang 4 (sep [ name <+> colon, tipe ])

474+ hang 4 (sep [ name <+> ":", tipe ])

494

475

495 elision =

476 elision =

496 case style of

477 case style of

@@ -509,16 +490,16 @@ docRecord style fields maybeExt =

509

490

510 (_, Nothing) ->

491 (_, Nothing) ->

511 sep

492 sep

512− [ cat (zipWith (<+>) (lbrace : repeat comma) fieldDocs)

493+ [ cat (zipWith (<+>) ("{" : repeat ",") fieldDocs)

513− , rbrace

494+ , "}"

514 ]

495 ]

515

496

516 (_, Just ext) ->

497 (_, Just ext) ->

517 sep

498 sep

518 [ hang 4 $ sep $

499 [ hang 4 $ sep $

519− [ lbrace <+> ext

500+ [ "{" <+> ext

520− , cat (zipWith (<+>) (text "|" : repeat comma) fieldDocs)

501+ , cat (zipWith (<+>) (text "|" : repeat ",") fieldDocs)

521 ]

502 ]

522− , rbrace

503+ , "}"

523 ]

504 ]

524

505

src/Type/Constrain/Effects.hs+21−19

@@ -3,16 +3,15 @@

3module Type.Constrain.Effects (constrain) where

4

5import qualified Data.Map as Map

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

7

6

8import qualified AST.Effects as Effects

7import qualified AST.Effects as Effects

9import qualified AST.Module.Name as ModuleName

8import qualified AST.Module.Name as ModuleName

9+import qualified AST.Variable as Var

10import qualified Reporting.Annotation as A

11import qualified Reporting.Error.Type as Error

12−import qualified Type.Environment as Env

13import Type.Type

12import Type.Type

14− ( Variable, Type(VarN), Constraint(..), Scheme(Scheme)

13+ ( Variable, Type(AppN,VarN), Constraint(..)

15− , (==>), (<|), mkVar

14+ , Scheme(Scheme), (==>), mkVar

16 )

15 )

17

16

18

17

@@ -20,8 +19,8 @@ import Type.Type

20-- CONSTRAIN EFFECTS

19-- CONSTRAIN EFFECTS

21

20

22

21

23−constrain :: Env.Env -> ModuleName.Canonical -> Effects.Canonical -> IO Constraint

22+constrain :: ModuleName.Canonical -> Effects.Canonical -> IO Constraint

24−constrain env moduleName effects =

23+constrain moduleName effects =

25 case effects of

24 case effects of

26 Effects.None ->

25 Effects.None ->

27 return CSaveEnv

26 return CSaveEnv

@@ -30,17 +29,22 @@ constrain env moduleName effects =

30 return CSaveEnv

29 return CSaveEnv

31

30

32 Effects.Manager _ info ->

31 Effects.Manager _ info ->

33− constrainHelp env moduleName info

32+ constrainHelp moduleName info

34

33

35

34

35+never :: Type

36+never =

37+ AppN Var.never []

38+

39+

36−constrainHelp :: Env.Env -> ModuleName.Canonical -> Effects.Info -> IO Constraint

40+constrainHelp :: ModuleName.Canonical -> Effects.Info -> IO Constraint

37−constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

41+constrainHelp moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

38 let

42 let

39 task t =

43 task t =

40− Env.getType env "Platform.Task" <| Env.getType env "Basics.Never" <| VarN t

44+ AppN Var.task [ never, VarN t ]

41

45

42 router msg selfMsg =

46 router msg selfMsg =

43− Env.getType env "Platform.Router" <| VarN msg <| VarN selfMsg

47+ AppN Var.router [ VarN msg, VarN selfMsg ]

44 in

48 in

45 do v0 <- mkVar Nothing

49 do v0 <- mkVar Nothing

46 v1 <- mkVar Nothing

50 v1 <- mkVar Nothing

@@ -62,7 +66,7 @@ constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

62

66

63 onEffectsType =

67 onEffectsType =

64 router msg1 selfMsg1

68 router msg1 selfMsg1

65− ==> addEffectArgs env moduleName managerType msg1

69+ ==> addEffectArgs moduleName managerType msg1

66 (VarN state1 ==> task state1)

70 (VarN state1 ==> task state1)

67

71

68 onSelfMsgType =

72 onSelfMsgType =

@@ -85,20 +89,18 @@ constrainHelp env moduleName (Effects.Info tagRegion r0 r1 r2 managerType) =

85

89

86

90

87addEffectArgs

91addEffectArgs

88− :: Env.Env

89− -> ModuleName.Canonical

92+ :: ModuleName.Canonical

90 -> Effects.RawManagerType

93 -> Effects.RawManagerType

91 -> Variable

94 -> Variable

92 -> Type

95 -> Type

93 -> Type

96 -> Type

94−addEffectArgs env moduleName managerType msg result =

97+addEffectArgs moduleName managerType msg result =

95 let

98 let

96− toTypeName (A.A _ name) =

99+ toVar (A.A _ name) =

97− ModuleName.canonicalToText moduleName <> "." <> name

100+ Var.fromModule moduleName name

98

101

99 effectList fxName =

102 effectList fxName =

100− Env.getType env "List" <|

103+ AppN Var.list [AppN (toVar fxName) [VarN msg]]

101− (Env.getType env (toTypeName fxName) <| VarN msg)

102 in

104 in

103 case managerType of

105 case managerType of

104 Effects.CmdManager cmd ->

106 Effects.CmdManager cmd ->

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

@@ -28,7 +28,7 @@ constrain :: Env.Env -> C.Expr -> Type -> IO Constraint

28constrain env annotatedExpr@(A.A region expression) tipe =

29 case expression of

30 C.Literal lit ->

31− Literal.constrain env region lit tipe

31+ Literal.constrain region lit tipe

32

33 C.Cmd _ _ ->

34 return CTrue

@@ -46,17 +46,17 @@ constrain env annotatedExpr@(A.A region expression) tipe =

46 error "DANGER - Program AST nodes should not be in type inference."

47

48 C.SaveEnv moduleName effects ->

49− Effects.constrain env moduleName effects

49+ Effects.constrain moduleName effects

50

51 C.GLShader _uid _src glType ->

52 exists $ \attr ->

53 exists $ \unif ->

54 let

55 shaderTipe a u v =

56− Env.getType env "WebGL.Shader" <| a <| u <| v

56+ AppN V.shader [a, u, v]

57

58 glToType gl =

59− Env.getType env (Lit.glTypeToText gl)

59+ AppN (Lit.glTypeToVar gl) []

60

61 makeRec accessor baseRec =

62 let decls = accessor glType

@@ -299,7 +299,7 @@ constrainList env region exprs tipe =

299 return ( (var, region'), con )

300

301 varToCon var =

302− CEqual Error.List region (Env.getType env "List" <| VarN var) tipe

302+ CEqual Error.List region (AppN V.list [VarN var]) tipe

303

304

305

@@ -328,7 +328,7 @@ constrainIf env region branches finally tipe =

328 return $ ex (condVars ++ vars) (CAnd (condCons ++ branchExprCons ++ cons))

329 where

330 bool =

331− Env.getType env "Bool"

331+ AppN V.bool []

332

333 constrainCondition condition@(A.A condRegion _) =

334 do condVar <- mkVar Nothing

src/Type/Constrain/Literal.hs+9−9

@@ -3,23 +3,23 @@

3module Type.Constrain.Literal where

4

5import qualified AST.Literal as L

6+import qualified AST.Variable as Var

6import qualified Reporting.Error.Type as Error

7import qualified Reporting.Error.Type as Error

7import qualified Reporting.Region as R

8import qualified Reporting.Region as R

8import qualified Type.Type as T

9import qualified Type.Type as T

9−import qualified Type.Environment as Env

10

11

12

13-- CONSTRAIN LITERALS

14

15

16−constrain :: Env.Env -> R.Region -> L.Literal -> T.Type -> IO T.Constraint

16+constrain :: R.Region -> L.Literal -> T.Type -> IO T.Constraint

17−constrain env region literal tipe =

17+constrain region literal tipe =

18 do definiteType <- litType

19 return (T.CEqual (Error.Literal name) region definiteType tipe)

20 where

21− prim tipeName =

21+ prim var =

22− return (Env.getType env tipeName)

22+ return (T.AppN var [])

23

24 (name, litType) =

25 case literal of

@@ -30,20 +30,20 @@ constrain env region literal tipe =

30

31 L.FloatNum _ ->

32 ( "float"

33− , prim "Float"

33+ , prim Var.float

34 )

35

36 L.Chr _ ->

37 ( "character"

38− , prim "Char"

38+ , prim Var.char

39 )

40

41 L.Str _ ->

42 ( "string"

43− , prim "String"

43+ , prim Var.string

44 )

45

46 L.Boolean _ ->

47 ( "boolean"

48− , prim "Bool"

48+ , prim Var.bool

49 )

src/Type/Constrain/Pattern.hs+1−1

@@ -70,7 +70,7 @@ constrain env (A.A region pattern) tipe =

70 return emptyInfo

71

72 P.Literal lit ->

73− do c <- Literal.constrain env region lit tipe

73+ do c <- Literal.constrain region lit tipe

74 return $ emptyInfo { _cons = c }

75

76 P.Var name ->

src/Type/Environment.hs+28−81

@@ -4,13 +4,12 @@ module Type.Environment

4 ( Env

5 , Dict

6 , initialize

7− , get, getType, freshDataScheme, ctorNames

7+ , get, freshDataScheme, ctorNames

8 , addValues

9 , instantiateType

10 )

11 where

12

13−import Control.Monad (foldM)

14import qualified Control.Monad.State.Strict as State

13import qualified Control.Monad.State.Strict as State

15import qualified Data.List as List

14import qualified Data.List as List

16import qualified Data.Map as Map

15import qualified Data.Map as Map

@@ -31,7 +30,6 @@ import Type.Type

31data Env =

30data Env =

32 Env

31 Env

33 { _ctor :: Dict Instantiator

32 { _ctor :: Dict Instantiator

34− , _types :: Dict Type

35 , _value :: Dict Type

33 , _value :: Dict Type

36 }

34 }

37

35

@@ -44,61 +42,20 @@ type Dict a =

44 Map.Map Text a

42 Map.Map Text a

45

43

46

44

47−initialize :: [Module.CanonicalUnion] -> IO Env

45+initialize :: [Module.CanonicalUnion] -> Env

48initialize unions =

46initialize unions =

49− do types <- makeTypes unions

47+ Env (makeCtors unions) Map.empty

50− let env =

51− Env

52− { _ctor = Map.empty

53− , _value = Map.empty

54− , _types = types

55− }

56− return $ env { _ctor = makeCtors env unions }

57−

58−

59−

60−-- TYPES

61−

62−

63−makeTypes :: [Module.CanonicalUnion] -> IO (Dict Type)

64−makeTypes unions =

65− do builtinDict <- Map.fromList <$> mapM makeBuiltin builtinTypes

66− foldM addImported builtinDict unions

67−

68−

69−addImported :: Dict Type -> (Var.Canonical, unionInfo) -> IO (Dict Type)

70−addImported dict ( var, _ ) =

71− do atom <- mkAtom var

72− return (Map.insert (Var.toText var) (VarN atom) dict)

73−

74−

75−makeBuiltin :: (Text, Int) -> IO (Text, Type)

76−makeBuiltin (name, _) =

77− do atom <- mkAtom (Var.builtin name)

78− return (name, VarN atom)

79−

80−

81−builtinTypes :: [(Text, Int)]

82−builtinTypes =

83− concat

84− [ map tuple [0..9]

85− , kind 1 ["List"]

86− , kind 0 ["Int","Float","Char","String","Bool"]

87− ]

88− where

89− tuple size = ( Help.makeTuple size, size )

90− kind n names = map (\name -> (name, n)) names

91

48

92

49

93

50

94-- CONSTRUCTORS

51-- CONSTRUCTORS

95

52

96

53

97−makeCtors :: Env -> [Module.CanonicalUnion] -> Dict Instantiator

54+makeCtors :: [Module.CanonicalUnion] -> Dict Instantiator

98−makeCtors env unions =

55+makeCtors unions =

99 let

56 let

100 list t =

57 list t =

101− getType env "List" <| t

58+ AppN Var.list [t]

102

59

103 inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator

60 inst :: Int -> ([Type] -> ([Type], Type)) -> Instantiator

104 inst numTVars tipe =

61 inst numTVars tipe =

@@ -111,7 +68,7 @@ makeCtors env unions =

111 name =

68 name =

112 Help.makeTuple size

69 Help.makeTuple size

113 in

70 in

114− (name, inst size $ \vs -> (vs, foldl (<|) (getType env name) vs))

71+ (name, inst size $ \vs -> (vs, AppN (Var.tuple size) vs))

115

72

116 builtins :: Dict Instantiator

73 builtins :: Dict Instantiator

117 builtins =

74 builtins =

@@ -121,15 +78,15 @@ makeCtors env unions =

121 ]

78 ]

122 ++ map tupleCtor [0..9]

79 ++ map tupleCtor [0..9]

123 in

80 in

124− List.foldl' (makeCtorsHelp env) builtins unions

81+ List.foldl' makeCtorsHelp builtins unions

125

82

126

83

127type VarDict =

84type VarDict =

128 Map.Map Text Variable

85 Map.Map Text Variable

129

86

130

87

131−makeCtorsHelp :: Env -> Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator

88+makeCtorsHelp :: Dict Instantiator -> Module.CanonicalUnion -> Dict Instantiator

132−makeCtorsHelp env constructorDict ( var, (rawTypeVars, ctors) ) =

89+makeCtorsHelp constructorDict ( var, (rawTypeVars, ctors) ) =

133 let

90 let

134 inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator

91 inst :: Dict Instantiator -> (Var.Canonical, [T.Canonical]) -> Dict Instantiator

135 inst ctorDict (name, rawArgs) =

92 inst ctorDict (name, rawArgs) =

@@ -145,8 +102,8 @@ makeCtorsHelp env constructorDict ( var, (rawTypeVars, ctors) ) =

145

102

146 go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)

103 go :: [T.Canonical] -> State.StateT VarDict IO ([Type], Type)

147 go args =

104 go args =

148− do types <- mapM (instantiator Flex env) args

105+ do types <- mapM (instantiator Flex Map.empty) args

149− returnType <- instantiator Flex env (T.App (T.Type var) tvars)

106+ returnType <- instantiator Flex Map.empty (T.Type var tvars)

150 return (types, returnType)

107 return (types, returnType)

151 in

108 in

152 List.foldl' inst constructorDict ctors

109 List.foldl' inst constructorDict ctors

@@ -162,11 +119,6 @@ get dict var =

162 dict Map.! var

119 dict Map.! var

163

120

164

121

165−getType :: Env -> Text -> Type

166−getType env var =

167− get (_types env) var

168−

169−

170freshDataScheme :: Env -> Text -> Instantiator

122freshDataScheme :: Env -> Text -> Instantiator

171freshDataScheme env var =

123freshDataScheme env var =

172 get (_ctor env) var

124 get (_ctor env) var

@@ -192,19 +144,19 @@ addValues newValues env =

192

144

193instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)

145instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)

194instantiateType flex env sourceType =

146instantiateType flex env sourceType =

195− State.runStateT (instantiator flex env sourceType) Map.empty

147+ State.runStateT (instantiator flex (_value env) sourceType) Map.empty

196

148

197

149

198−instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type

150+instantiator :: Flex -> Dict Type -> T.Canonical -> State.StateT VarDict IO Type

199−instantiator flex env sourceType =

151+instantiator flex values sourceType =

200− instantiatorHelp flex env Set.empty sourceType

152+ instantiatorHelp flex values Set.empty sourceType

201

153

202

154

203−instantiatorHelp :: Flex -> Env -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type

155+instantiatorHelp :: Flex -> Dict Type -> Set.Set Text -> T.Canonical -> State.StateT VarDict IO Type

204−instantiatorHelp flex env aliasVars sourceType =

156+instantiatorHelp flex values aliasVars sourceType =

205 let

157 let

206 go =

158 go =

207− instantiatorHelp flex env aliasVars

159+ instantiatorHelp flex values aliasVars

208 in

160 in

209 case sourceType of

161 case sourceType of

210 T.Lambda t1 t2 ->

162 T.Lambda t1 t2 ->

@@ -215,12 +167,12 @@ instantiatorHelp flex env aliasVars sourceType =

215 return (PlaceHolder name)

167 return (PlaceHolder name)

216

168

217 else

169 else

218− do dict <- State.get

219− case Map.lookup name (_value env) of

170+ case Map.lookup name values of

220− Just tipe ->

171+ Just tipe ->

221− return tipe

172+ return tipe

222

173

223− Nothing ->

174+ Nothing ->

175+ do dict <- State.get

224 case Map.lookup name dict of

176 case Map.lookup name dict of

225 Just variable ->

177 Just variable ->

226 return (VarN variable)

178 return (VarN variable)

@@ -235,20 +187,15 @@ instantiatorHelp flex env aliasVars sourceType =

235 realType <-

187 realType <-

236 case aliasType of

188 case aliasType of

237 T.Filled tipe ->

189 T.Filled tipe ->

238− instantiatorHelp flex env Set.empty tipe

190+ instantiatorHelp flex values Set.empty tipe

239

191

240 T.Holey tipe ->

192 T.Holey tipe ->

241− instantiatorHelp flex env (Set.fromList (map fst args)) tipe

193+ instantiatorHelp flex values (Set.fromList (map fst args)) tipe

242

194

243 return (AliasN name targs realType)

195 return (AliasN name targs realType)

244

196

245− T.Type name ->

197+ T.Type name args ->

246− return (getType env (Var.toText name))

198+ AppN name <$> traverse go args

247−

248− T.App func args ->

249− do tfunc <- go func

250− targs <- traverse go args

251− return $ foldl (<|) tfunc targs

252

199

253 T.Record fields ext ->

200 T.Record fields ext ->

254 do tfields <- traverse go (Map.fromList fields)

201 do tfields <- traverse go (Map.fromList fields)

src/Type/Inference.hs+1−2

@@ -46,8 +46,7 @@ genConstraints

46 -> Module.Canonical

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

48genConstraints interfaces modul =

49− do env <-

50− Env.initialize (canonicalizeUnions interfaces modul)

49+ do let env = Env.initialize (canonicalizeUnions interfaces modul)

51

50

52 ctors <-

51 ctors <-

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

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

src/Type/Occurs.hs+2−5

@@ -25,9 +25,6 @@ occursHelp seen var =

25 else

26 do desc <- UF.descriptor var

27 case _content desc of

28− Atom _ ->

29− return False

30−

31 Var _ _ _ ->

28 Var _ _ _ ->

32 return False

29 return False

33

30

@@ -43,8 +40,8 @@ occursHelp seen var =

43 go = occursHelp (var:seen)

40 go = occursHelp (var:seen)

44 in

41 in

45 case term of

42 case term of

46− App1 a b ->

43+ App1 _ args ->

47− (||) <$> go a <*> go b

44+ or <$> traverse go args

48

45

49 Fun1 a b ->

46 Fun1 a b ->

50 (||) <$> go a <*> go b

47 (||) <$> go a <*> go b

src/Type/Solve.hs+6−5

@@ -122,9 +122,6 @@ adjustRankContent youngMark visitedMark groupRank content =

122 Error _ ->

123 return groupRank

124

125− Atom _ ->

126− return groupRank

127−

128 Var _ _ _ ->

125 Var _ _ _ ->

129 return groupRank

126 return groupRank

130

127

@@ -133,8 +130,12 @@ adjustRankContent youngMark visitedMark groupRank content =

133 do realRank <- go realVar

130 do realRank <- go realVar

134 foldM (\rank (_, argVar) -> max rank <$> go argVar) realRank args

131 foldM (\rank (_, argVar) -> max rank <$> go argVar) realRank args

135

132

136− Structure (App1 func arg) ->

133+ Structure (App1 _ []) ->

137− max <$> go func <*> go arg

134+ return groupRank

135+

136+ Structure (App1 _ (first:rest)) ->

137+ do firstRank <- go first

138+ foldM (\rank arg -> max rank <$> go arg) firstRank rest

138

139

139 Structure (Fun1 arg result) ->

140 Structure (Fun1 arg result) ->

140 max <$> go arg <*> go result

141 max <$> go arg <*> go result

src/Type/State.hs+6−16

@@ -22,7 +22,7 @@ module Type.State

22 where

23

24

25−import Control.Monad (liftM2)

25+import Control.Monad (liftM, liftM2)

26import Control.Monad.Trans (MonadIO, liftIO)

27import qualified Data.Map as Map

28import Data.Map ((!))

@@ -219,10 +219,9 @@ flattenHelp aliasDict termN =

219 VarN v ->

220 return v

221

222− AppN a b ->

222+ AppN name args ->

223− do flatA <- flattenHelp aliasDict a

224− flatB <- flattenHelp aliasDict b

223+ do flatArgs <- traverse (flattenHelp aliasDict) args

225− makeFlatType (Structure (App1 flatA flatB))

224+ makeFlatType (Structure (App1 name flatArgs))

226

225

227 FunN a b ->

226 FunN a b ->

228 do flatA <- flattenHelp aliasDict a

227 do flatA <- flattenHelp aliasDict a

@@ -323,9 +322,6 @@ makeCopyHelp (Descriptor content rank mark copy) alreadyCopiedMark variable =

323 do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term

322 do newTerm <- traverseFlatType (makeCopy alreadyCopiedMark) term

324 setContent (Structure newTerm)

323 setContent (Structure newTerm)

325

324

326− Atom _ ->

327− return ()

328−

329 Var Rigid maybeSuper maybeName ->

325 Var Rigid maybeSuper maybeName ->

330 setContent (Var Flex maybeSuper maybeName)

326 setContent (Var Flex maybeSuper maybeName)

331

327

@@ -351,9 +347,6 @@ needsCopy content =

351 Structure _ ->

347 Structure _ ->

352 True

348 True

353

349

354− Atom _ ->

355− False

356−

357 Var _ _ _ ->

350 Var _ _ _ ->

358 True

351 True

359

352

@@ -397,9 +390,6 @@ restoreContent alreadyCopiedMark content =

397 Structure term ->

390 Structure term ->

398 Structure <$> traverseFlatType go term

391 Structure <$> traverseFlatType go term

399

392

400− Atom _ ->

401− return content

402−

403 Var _ _ _ ->

393 Var _ _ _ ->

404 return content

394 return content

405

395

@@ -419,8 +409,8 @@ restoreContent alreadyCopiedMark content =

419traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType

409traverseFlatType :: (Variable -> Solver Variable) -> FlatType -> Solver FlatType

420traverseFlatType f flatType =

410traverseFlatType f flatType =

421 case flatType of

411 case flatType of

422− App1 a b ->

412+ App1 name args ->

423− liftM2 App1 (f a) (f b)

413+ liftM (App1 name) (traverse f args)

424

414

425 Fun1 a b ->

415 Fun1 a b ->

426 liftM2 Fun1 (f a) (f b)

416 liftM2 Fun1 (f a) (f b)

src/Type/Type.hs+6−32

@@ -28,7 +28,7 @@ type Variable =

28

29

30data FlatType

31− = App1 Variable Variable

31+ = App1 Var.Canonical [Variable]

32 | Fun1 Variable Variable

33 | EmptyRecord1

34 | Record1 (Map.Map Text Variable) Variable

@@ -38,7 +38,7 @@ data Type

38 = PlaceHolder Text

39 | AliasN Var.Canonical [(Text, Type)] Type

40 | VarN Variable

41− | AppN Type Type

41+ | AppN Var.Canonical [Type]

42 | FunN Type Type

43 | EmptyRecordN

44 | RecordN (Map.Map Text Type) Type

@@ -59,7 +59,6 @@ data Descriptor =

59

60data Content

61 = Structure FlatType

62− | Atom Var.Canonical

63 | Var Flex (Maybe Super) (Maybe Text)

62 | Var Flex (Maybe Super) (Maybe Text)

64 | Alias Var.Canonical [(Text,Variable)] Variable

63 | Alias Var.Canonical [(Text,Variable)] Variable

65 | Error Text

64 | Error Text

@@ -142,12 +141,6 @@ infixr 9 ==>

142 FunN

141 FunN

143

142

144

143

145−{-# INLINE (<|) #-}

146−(<|) :: Type -> Type -> Type

147−(<|) =

148− AppN

149−

150−

151

144

152-- VARIABLE CREATION

145-- VARIABLE CREATION

153

146

@@ -162,11 +155,6 @@ mkDescriptor content =

162 }

155 }

163

156

164

157

165−mkAtom :: Var.Canonical -> IO Variable

166−mkAtom name =

167− UF.fresh $ mkDescriptor (Atom name)

168−

169−

170mkVar :: Maybe Super -> IO Variable

158mkVar :: Maybe Super -> IO Variable

171mkVar maybeSuper =

159mkVar maybeSuper =

172 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

160 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)

@@ -268,9 +256,6 @@ contentToSrcType variable content =

268 Structure term ->

256 Structure term ->

269 termToSrcType term

257 termToSrcType term

270

258

271− Atom name ->

272− return (T.Type name)

273−

274 Var _ _ (Just name) ->

259 Var _ _ (Just name) ->

275 return (T.Var name)

260 return (T.Var name)

276

261

@@ -292,15 +277,8 @@ contentToSrcType variable content =

292termToSrcType :: FlatType -> StateT NameState IO T.Canonical

277termToSrcType :: FlatType -> StateT NameState IO T.Canonical

293termToSrcType term =

278termToSrcType term =

294 case term of

279 case term of

295− App1 func arg ->

280+ App1 name args ->

296− do srcFunc <- variableToSrcType func

281+ T.Type name <$> traverse variableToSrcType args

297− srcArg <- variableToSrcType arg

298− case srcFunc of

299− T.App f args ->

300− return (T.App f (args ++ [srcArg]))

301−

302− _ ->

303− return (T.App srcFunc [srcArg])

304

282

305 Fun1 a b ->

283 Fun1 a b ->

306 T.Lambda

284 T.Lambda

@@ -431,9 +409,6 @@ getVarNames var =

431 False ->

409 False ->

432 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })

410 do liftIO $ UF.setDescriptor var (desc { _mark = getVarNamesMark })

433 case _content desc of

411 case _content desc of

434− Atom _ ->

435− return ()

436−

437 Error _ ->

412 Error _ ->

438 return ()

413 return ()

439

414

@@ -449,9 +424,8 @@ getVarNames var =

449 do mapM_ (getVarNames . snd) args

424 do mapM_ (getVarNames . snd) args

450 getVarNames realVar

425 getVarNames realVar

451

426

452− Structure (App1 func arg) ->

427+ Structure (App1 _ args) ->

453− do getVarNames func

454− getVarNames arg

428+ mapM_ getVarNames args

455

429

456 Structure (Fun1 arg body) ->

430 Structure (Fun1 arg body) ->

457 do getVarNames arg

431 do getVarNames arg

src/Type/Unify.hs+56−144

@@ -234,9 +234,6 @@ actuallyUnify context@(Context _ _ firstDesc _ secondDesc) =

234 Var Rigid maybeSuper maybeName ->

235 unifyRigid context maybeSuper maybeName firstContent secondContent

236

237− Atom name ->

238− unifyAtom context name secondContent

239−

240 Alias name args realVar ->

237 Alias name args realVar ->

241 unifyAlias context name args realVar secondContent

238 unifyAlias context name args realVar secondContent

242

239

@@ -260,9 +257,6 @@ unifyFlex context otherContent =

260 Var Rigid _ _ ->

257 Var Rigid _ _ ->

261 merge context otherContent

258 merge context otherContent

262

259

263− Atom _ ->

264− merge context otherContent

265−

266 Alias _ _ _ ->

260 Alias _ _ _ ->

267 merge context otherContent

261 merge context otherContent

268

262

@@ -298,9 +292,6 @@ unifyRigid context maybeSuper maybeName content otherContent =

298 mismatch context $ Just $

292 mismatch context $ Just $

299 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)

293 doubleBad (Error.Rigid maybeName) (Error.Rigid otherMaybeName)

300

294

301− Atom _ ->

302− mismatch context (Just (badRigid maybeName))

303−

304 Alias _ _ _ ->

295 Alias _ _ _ ->

305 mismatch context (Just (badRigid maybeName))

296 mismatch context (Just (badRigid maybeName))

306

297

@@ -318,12 +309,6 @@ unifyFlexSuper context super content otherContent =

318 Structure term ->

309 Structure term ->

319 unifyFlexSuperStructure context super term

310 unifyFlexSuperStructure context super term

320

311

321− Atom name ->

322− if atomMatchesSuper super name then

323− merge context otherContent

324− else

325− mismatch context (Just (badSuper super))

326−

327 Var Rigid Nothing maybeName ->

312 Var Rigid Nothing maybeName ->

328 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))

313 mismatch context (Just (doubleBad (errorSuper super) (Error.Rigid maybeName)))

329

314

@@ -379,71 +364,71 @@ combineRigidSupers rigid flex =

379 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))

364 || (rigid == CompAppend && (flex == Comparable || flex == Appendable))

380

365

381

366

382−isPrimitiveFrom :: [Text] -> Var.Canonical -> Bool

383−isPrimitiveFrom prims var =

384− any (\p -> Var.isPrim p var) prims

385−

386−

387atomMatchesSuper :: Super -> Var.Canonical -> Bool

367atomMatchesSuper :: Super -> Var.Canonical -> Bool

388atomMatchesSuper super name =

368atomMatchesSuper super name =

389 case super of

369 case super of

390 Number ->

370 Number ->

391− isPrimitiveFrom ["Int", "Float"] name

371+ elem name [ Var.int, Var.float ]

392

372

393 Comparable ->

373 Comparable ->

394− isPrimitiveFrom ["Int", "Float", "Char", "String"] name

374+ elem name [ Var.string, Var.int, Var.float, Var.char]

395

375

396 Appendable ->

376 Appendable ->

397− Var.isPrim "String" name

377+ name == Var.string

398

378

399 CompAppend ->

379 CompAppend ->

400− Var.isPrim "String" name

380+ name == Var.string

401

381

402

382

403unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()

383unifyFlexSuperStructure :: Context -> Super -> FlatType -> Unify ()

404unifyFlexSuperStructure context super term =

384unifyFlexSuperStructure context super term =

405− do appStructure <- liftIO (collectApps term)

406− case appStructure of

385+ do case term of

407− Other ->

386+ App1 name [] ->

387+ if atomMatchesSuper super name then

388+ merge context (Structure term)

389+ else

408 mismatch context (Just (badSuper super))

390 mismatch context (Just (badSuper super))

409

391

410− List variable ->

392+ App1 name [variable] | name == Var.list ->

411− case super of

393+ case super of

412− Number ->

394+ Number ->

413− mismatch context (Just (badSuper super))

395+ mismatch context (Just (badSuper super))

414

396

415− Appendable ->

397+ Appendable ->

416− merge context (Structure term)

398+ merge context (Structure term)

417

399

418− Comparable ->

400+ Comparable ->

419− do comparableOccursCheck context

401+ do comparableOccursCheck context

420− merge context (Structure term)

402+ merge context (Structure term)

421− unifyComparableRecursive (_orientation context) variable

403+ unifyComparableRecursive (_orientation context) variable

422

404

423− CompAppend ->

405+ CompAppend ->

424− do comparableOccursCheck context

406+ do comparableOccursCheck context

425− merge context (Structure term)

407+ merge context (Structure term)

426− unifyComparableRecursive (_orientation context) variable

408+ unifyComparableRecursive (_orientation context) variable

427

409

428− Tuple entries ->

410+ App1 name args | Var.isTuple name ->

429− case super of

411+ case super of

430− Number ->

412+ Number ->

431− mismatch context (Just (badSuper super))

413+ mismatch context (Just (badSuper super))

432

414

433− Appendable ->

415+ Appendable ->

434− mismatch context (Just (badSuper super))

416+ mismatch context (Just (badSuper super))

435

417

436− Comparable ->

418+ Comparable ->

437− if length entries > 6 then

419+ if length args > 6 then

438− mismatch context (Just (Error.TooLongComparableTuple (length entries)))

420+ mismatch context (Just (Error.TooLongComparableTuple (length args)))

439

421

440− else

422+ else

441− do comparableOccursCheck context

423+ do comparableOccursCheck context

442− merge context (Structure term)

424+ merge context (Structure term)

443− mapM_ (unifyComparableRecursive (_orientation context)) entries

425+ mapM_ (unifyComparableRecursive (_orientation context)) args

444

426

445− CompAppend ->

427+ CompAppend ->

428+ mismatch context (Just (badSuper super))

429+

430+ _ ->

446− mismatch context (Just (badSuper super))

431+ mismatch context (Just (badSuper super))

447

432

448

433

449-- TODO: is there some way to avoid doing this?

434-- TODO: is there some way to avoid doing this?

@@ -472,38 +457,6 @@ unifyComparableRecursive orientation var =

472 guardedUnify orientation compVar var

457 guardedUnify orientation compVar var

473

458

474

459

475−data AppStructure

476− = List Variable

477− | Tuple [Variable]

478− | Other

479−

480−

481−collectApps :: FlatType -> IO AppStructure

482−collectApps term =

483− case term of

484− App1 func arg ->

485− collectAppsHelp [arg] =<< getContent func

486−

487− _ ->

488− return Other

489−

490−

491−collectAppsHelp :: [Variable] -> Content -> IO AppStructure

492−collectAppsHelp args content =

493− case (content, args) of

494− (Structure (App1 func arg), _) ->

495− collectAppsHelp (arg : args) =<< getContent func

496−

497− (Atom name, [arg]) | Var.isList name ->

498− return (List arg)

499−

500− (Atom name, _) | Var.isTuple name ->

501− return (Tuple (reverse args))

502−

503− _ ->

504− return Other

505−

506−

507collectArgs :: Variable -> IO [Variable]

460collectArgs :: Variable -> IO [Variable]

508collectArgs variable =

461collectArgs variable =

509 collectArgsHelp [] variable

462 collectArgsHelp [] variable

@@ -526,52 +479,6 @@ getContent variable =

526

479

527

480

528

481

529−-- UNIFY ATOMS

530−

531−

532−unifyAtom :: Context -> Var.Canonical -> Content -> Unify ()

533−unifyAtom context name otherContent =

534− case otherContent of

535− Error _ ->

536− return ()

537−

538− Var Flex Nothing _ ->

539− merge context (Atom name)

540−

541− Var Flex (Just super) _ ->

542− if atomMatchesSuper super name then

543− merge context (Atom name)

544−

545− else

546− mismatch context (Just ((Error.flipReason (badSuper super))))

547−

548− Var Rigid _ maybeName ->

549− mismatch context (Just (Error.flipReason (badRigid maybeName)))

550−

551− Atom otherName ->

552− if name == otherName then

553− merge context otherContent

554−

555− else

556− mismatch context $

557− if isIntFloat name otherName || isIntFloat otherName name then

558− Just Error.IntFloat

559− else

560− Nothing

561−

562− Alias _ _ realVar ->

563− subUnify context (_first context) realVar

564−

565− Structure _ ->

566− mismatch context Nothing

567−

568−

569−isIntFloat :: Var.Canonical -> Var.Canonical -> Bool

570−isIntFloat name otherName =

571− Var.isPrim "Int" name && Var.isPrim "Float" otherName

572−

573−

574−

575-- UNIFY ALIASES

482-- UNIFY ALIASES

576

483

577

484

@@ -587,9 +494,6 @@ unifyAlias context name args realVar otherContent =

587 Var _ _ _ ->

494 Var _ _ _ ->

588 subUnify context realVar (_second context)

495 subUnify context realVar (_second context)

589

496

590− Atom _ ->

591− subUnify context realVar (_second context)

592−

593 Alias otherName otherArgs otherRealVar ->

497 Alias otherName otherArgs otherRealVar ->

594 if name == otherName then

498 if name == otherName then

595 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

499 do zipWithM_ (subUnify context) (map snd args) (map snd otherArgs)

@@ -621,18 +525,21 @@ unifyStructure context term content otherContent =

621 Var Rigid _ maybeName ->

525 Var Rigid _ maybeName ->

622 mismatch context (Just (Error.flipReason (badRigid maybeName)))

526 mismatch context (Just (Error.flipReason (badRigid maybeName)))

623

527

624− Atom _ ->

625− mismatch context Nothing

626−

627 Alias _ _ realVar ->

528 Alias _ _ realVar ->

628 subUnify context (_first context) realVar

529 subUnify context (_first context) realVar

629

530

630 Structure otherTerm ->

531 Structure otherTerm ->

631 case (term, otherTerm) of

532 case (term, otherTerm) of

632− (App1 func arg, App1 otherFunc otherArg) ->

533+ (App1 name args, App1 otherName otherArgs) ->

633− do subUnify context func otherFunc

534+ if name == otherName then

634− subUnify context arg otherArg

535+ do zipWithM_ (subUnify context) args otherArgs

635− merge context otherContent

536+ merge context otherContent

537+

538+ else if isIntFloat name otherName || isIntFloat otherName name then

539+ mismatch context (Just Error.IntFloat)

540+

541+ else

542+ mismatch context Nothing

636

543

637 (Fun1 arg result, Fun1 otherArg otherResult) ->

544 (Fun1 arg result, Fun1 otherArg otherResult) ->

638 do subUnify context arg otherArg

545 do subUnify context arg otherArg

@@ -657,6 +564,11 @@ unifyStructure context term content otherContent =

657 mismatch context Nothing

564 mismatch context Nothing

658

565

659

566

567+isIntFloat :: Var.Canonical -> Var.Canonical -> Bool

568+isIntFloat name otherName =

569+ Var.isPrim "Int" name && Var.isPrim "Float" otherName

570+

571+

660

572

661-- UNIFY RECORDS

573-- UNIFY RECORDS

662

574

src/Validate.hs+4−10

@@ -687,11 +687,8 @@ freeVars (A.A region tipe) =

687 Type.RVar x ->

688 Result.ok [A.A region x]

689

690− Type.RType _ ->

690+ Type.RType _ args ->

691− Result.ok []

692−

693− Type.RApp t ts ->

694− concat <$> traverse freeVars (t:ts)

691+ concat <$> traverse freeVars args

695

692

696 Type.RRecord fields ext ->

693 Type.RRecord fields ext ->

697 do checkDuplicateFields region fields

694 do checkDuplicateFields region fields

@@ -709,11 +706,8 @@ checkDuplicateFieldsInType (A.A region tipe) =

709 Type.RVar _ ->

706 Type.RVar _ ->

710 Result.ok ()

707 Result.ok ()

711

708

712− Type.RType _ ->

709+ Type.RType _ args ->

713− Result.ok ()

714−

715− Type.RApp t ts ->

716− F.traverse_ checkDuplicateFieldsInType (t:ts)

710+ F.traverse_ checkDuplicateFieldsInType args

717

711

718 Type.RRecord fields ext ->

712 Type.RRecord fields ext ->

719 do checkDuplicateFields region fields

713 do checkDuplicateFields region fields