4a6c4a0 · elk · git.iko.soy

git.iko.soy/elk

Make Type.Instantiate and Type.Constrain.Pattern more self-contained

Rather than having all the logic that uses the core code in these modules, the special uses are designed at the place where they are used. That seems to make the code simpler overall, but it is a bit harder to enforce invariants within a single file.

commit4a6c4a00c4eb11a51cba883b0eb1409f816596c4 authorEvan Czaplicki <evancz@users.noreply.github.com> dateWed 8 Nov 2017, 17:27 (9 years ago) parenta794af5

2 files changed+114−142

compare with master

unifiedsplit

src/Type/Constrain/Pattern.hs+112−103 src/Type/Instantiate.hs+2−39

src/Type/Constrain/Pattern.hs+112−103

@@ -1,168 +1,135 @@

11{-# OPTIONS_GHC -Wall #-}

22module Type.Constrain.Pattern

3− ( Info(..)

4− , constrain

3+ ( State(..)

4+ , addConstraints

55 )

66 where

9+import Control.Arrow (second)

910import Control.Monad (foldM)

1011import qualified Data.Map.Strict as Map

1112

1213import qualified AST.Expression.Canonical as Can

1314import qualified AST.Module.Name as ModuleName

1415import qualified Data.Bag as Bag

16+import qualified Data.Index as Index

1517import qualified Elm.Name as N

1618import qualified Reporting.Annotation as A

1719import qualified Reporting.Error.Type as Error

1820import qualified Reporting.Region as R

1921import Type.Constraint

20−import qualified Type.Constrain.Literal as Literal

2122import qualified Type.Instantiate as Instantiate

22−import Type.Type

23−

24−

25−

26−-- CONSTRAIN PATTERN

27−

28−

29−constrain :: Can.Pattern -> Type -> IO (Map.Map N.Name (A.Located Type), [Variable], Constraint)

30−constrain pattern tipe =

31− do (Info headers vars cons) <-

32− addConstraints Error.PatternUnknown pattern tipe $

33− Info Map.empty Bag.empty []

34−

35− return ( headers, Bag.toList vars, CAnd (reverse cons) )

23+import Type.Type as T

3624

3725

3826

3927-- ADD CONSTRAINTS

4028

4129

42−data Info =

43− Info

30+-- The constraints are stored in reverse order so that adding a new

31+-- constraint is O(1) and we can reverse it at some later time.

32+--

33+data State =

34+ State

4435 { _headers :: Map.Map N.Name (A.Located Type)

4536 , _vars :: Bag.Bag Variable

46− , _cons :: [Constraint]

37+ , _revCons :: [Constraint]

4738 }

4839

4940

50−addConstraints :: Error.PatternContext -> Can.Pattern -> Type -> Info -> IO Info

51−addConstraints context (A.A region pattern) tipe info =

41+addConstraints :: R.Region -> Error.PatternContext -> Can.Pattern -> Type -> State -> IO State

42+addConstraints outerRegion context (A.A region pattern) tipe state =

5243 case pattern of

5344 Can.PAnything ->

54− return info

55−

56− Can.PLiteral lit ->

57− do let (Info headers vars revCons) = info

58− litCon <- Literal.constrain region lit tipe

59− return $ Info headers vars (litCon:revCons)

45+ return state

6046

6147 Can.PVar name ->

62− do let (Info headers vars revCons) = info

48+ do let (State headers vars revCons) = state

6349 let newHeaders = Map.insert name (A.A region tipe) headers

64− return $ Info newHeaders vars revCons

50+ return $ State newHeaders vars revCons

6551

6652 Can.PAlias realPattern name ->

67− do let (Info headers vars revCons) = info

68− addConstraints context realPattern tipe $

69− Info (Map.insert name (A.A region tipe) headers) vars revCons

53+ do let (State headers vars revCons) = state

54+ addConstraints outerRegion context realPattern tipe $

55+ State (Map.insert name (A.A region tipe) headers) vars revCons

7056

7157 Can.PUnit ->

72− do let (Info headers vars revCons) = info

73− let unitCon = CEqual (Error.Pattern context Error.PUnit) region UnitN tipe

74− return $ Info headers vars (unitCon:revCons)

58+ do let (State headers vars revCons) = state

59+ let unitCon = CPattern outerRegion context Error.PUnit region UnitN tipe

60+ return $ State headers vars (unitCon:revCons)

7561

7662 Can.PTuple a b maybeC ->

77− addTupleConstraint context region a b maybeC tipe info

63+ addTupleConstraint outerRegion context region a b maybeC tipe state

7864

79− Can.PCtor home typeName vs ctorName args ->

80− do (Instantiate.Ctor tvars targs ttype) <- Instantiate.pattern home typeName vs args

81−

82− (Info headers vars revCons) <-

83− foldM (addCtorConstraint ctorName) info targs

84−

85− return $

86− Info

87− { _headers = headers

88− , _vars = Bag.append vars (Bag.fromList id tvars)

89− , _cons =

90− CEqual (Error.Pattern context (Error.PCtor ctorName)) region ttype tipe

91− : revCons

92− }

65+ Can.PCtor home typeName typeVars ctorName args ->

66+ addCtorConstraint outerRegion context region home typeName typeVars ctorName args tipe state

9367

9468 Can.PList patterns ->

9569 do entryVar <- mkFlexVar

9670 let entryVarN = VarN entryVar

9771 let listType = AppN ModuleName.list N.list [entryVarN]

9872

99− (Info headers vars revCons) <-

100− foldM

101− (addListConstraint entryVarN)

102− info

103− (zip patterns [ 1 .. length patterns ])

73+ (State headers vars revCons) <-

74+ foldM (addListConstraint region entryVarN) state (Index.indexedMap (,) patterns)

10475

105− let listCon = CEqual (Error.Pattern context Error.PList) region listType tipe

106− return $ Info headers (Bag.insert entryVar vars) (listCon:revCons)

76+ let listCon = CPattern outerRegion context Error.PList region listType tipe

77+ return $ State headers (Bag.insert entryVar vars) (listCon:revCons)

10778

10879 Can.PCons headPattern tailPattern ->

109− do headVar <- mkFlexVar

110− tailVar <- mkFlexVar

111− let headVarN = VarN headVar

112− let tailVarN = VarN tailVar

113− let tailType = AppN ModuleName.list N.list [tailVarN]

80+ do entryVar <- mkFlexVar

81+ let entryType = VarN entryVar

82+ let listType = AppN ModuleName.list N.list [entryType]

11483

115− (Info headers vars revCons) <-

116− addConstraints Error.PatternTail tailPattern tailType =<<

117− addConstraints Error.PatternUnknown headPattern headVarN info

84+ (State headers vars revCons) <-

85+ addConstraints region Error.PatternHead headPattern entryType =<<

86+ addConstraints region Error.PatternTail tailPattern listType state

11887

119− return $

120− Info

121− { _headers = headers

122− , _vars = Bag.insert headVar (Bag.insert tailVar vars)

123− , _cons =

124− CEqual (Error.Pattern context Error.PList) region tailType tipe

125− : CEqual Error.PatternCons region headVarN tailVarN

126− : revCons

127− }

88+ let listCon = CPattern outerRegion context Error.PList region listType tipe

89+ return $ State headers (Bag.insert entryVar vars) (listCon : revCons)

12890

12991 Can.PRecord fields ->

13092 do extVar <- mkFlexVar

93+ let extType = VarN extVar

13194

13295 fieldVars <- traverse (\field -> (,) field <$> mkFlexVar) fields

133− let fieldVarN = Map.fromList (map (fmap VarN) fieldVars)

96+ let fieldTypes = Map.fromList (map (fmap VarN) fieldVars)

97+ let recordType = RecordN fieldTypes extType

13498

135− let (Info headers vars revCons) = info

99+ let (State headers vars revCons) = state

100+ let recordCon = CPattern outerRegion context Error.PRecord region recordType tipe

136101 return $

137− Info

138− { _headers = Map.union headers (Map.map (A.A region) fieldVarN)

102+ State

103+ { _headers = Map.union headers (Map.map (A.A region) fieldTypes)

139104 , _vars = Bag.insert extVar (Bag.append vars (Bag.fromList snd fieldVars))

140− , _cons =

141− CEqual

142− (Error.Pattern context Error.PRecord)

143− region

144− (RecordN fieldVarN (VarN extVar))

145− tipe

146− : revCons

105+ , _revCons = recordCon : revCons

147106 }

148107

108+ Can.PInt _ ->

109+ do let (State headers vars revCons) = state

110+ let intCon = CPattern outerRegion context Error.PInt region T.int tipe

111+ return $ State headers vars (intCon:revCons)

149112

113+ Can.PStr _ ->

114+ do let (State headers vars revCons) = state

115+ let strCon = CPattern outerRegion context Error.PStr region T.string tipe

116+ return $ State headers vars (strCon:revCons)

150117

151−-- CONSTRAIN CONSTRUCTORS

118+ Can.PChr _ ->

119+ do let (State headers vars revCons) = state

120+ let chrCon = CPattern outerRegion context Error.PChr region T.char tipe

121+ return $ State headers vars (chrCon:revCons)

152122

153123

154−addCtorConstraint :: N.Name -> Info -> (Int, Type, Can.Pattern) -> IO Info

155−addCtorConstraint name info (index, argType, argPattern) =

156− addConstraints (Error.PatternArg name index) argPattern argType info

157124

158125

159126

160127-- CONSTRAIN LIST

161128

162129

163−addListConstraint :: Type -> Info -> (Can.Pattern, Int) -> IO Info

164−addListConstraint tipe info (pattern, index) =

165− addConstraints (Error.PatternList index) pattern tipe info

130+addListConstraint :: R.Region -> Type -> State -> (Index.ZeroBased, Can.Pattern) -> IO State

131+addListConstraint listRegion tipe state (index, pattern) =

132+ addConstraints listRegion (Error.PatternList index) pattern tipe state

166133

167134

168135

@@ -170,29 +137,30 @@ addListConstraint tipe info (pattern, index) =

170137

171138

172139addTupleConstraint

173− :: Error.PatternContext

140+ :: R.Region

141+ -> Error.PatternContext

174142 -> R.Region

175143 -> Can.Pattern

176144 -> Can.Pattern

177145 -> Maybe Can.Pattern

178146 -> Type

179− -> Info

180− -> IO Info

181−addTupleConstraint context region a b maybeC tipe (Info headers vars revCons) =

182− do let equal = CEqual (Error.Pattern context Error.PTuple) region

183− let addCon = addConstraints Error.PatternUnknown

184−

185− aVar <- mkFlexVar

147+ -> State

148+ -> IO State

149+addTupleConstraint parentRegion context tupleRegion a b maybeC tipe (State headers vars revCons) =

150+ do aVar <- mkFlexVar

186151 bVar <- mkFlexVar

187152 let aVarN = VarN aVar

188153 let bVarN = VarN bVar

189154

155+ let equal = CPattern parentRegion context Error.PTuple tupleRegion

156+ let addCon = addConstraints tupleRegion Error.PatternUnknown

157+

190158 case maybeC of

191159 Nothing ->

192160 do let tupleCon = equal (TupleN aVarN bVarN Nothing) tipe

193161 let newVars = Bag.insert aVar (Bag.insert bVar vars)

194162 addCon b bVarN =<<

195− addCon a aVarN (Info headers newVars (tupleCon:revCons))

163+ addCon a aVarN (State headers newVars (tupleCon:revCons))

196164

197165 Just c ->

198166 do cVar <- mkFlexVar

@@ -201,4 +169,45 @@ addTupleConstraint context region a b maybeC tipe (Info headers vars revCons) =

201169 let newVars = Bag.insert aVar (Bag.insert bVar (Bag.insert cVar vars))

202170 addCon c cVarN =<<

203171 addCon b bVarN =<<

204− addCon a aVarN (Info headers newVars (tupleCon:revCons))

172+ addCon a aVarN (State headers newVars (tupleCon:revCons))

173+

174+

175+

176+-- CONSTRAIN CONSTRUCTORS

177+

178+

179+addCtorConstraint

180+ :: R.Region

181+ -> Error.PatternContext

182+ -> R.Region

183+ -> ModuleName.Canonical

184+ -> N.Name

185+ -> [N.Name]

186+ -> N.Name

187+ -> [Can.PatternCtorArg]

188+ -> Type

189+ -> State

190+ -> IO State

191+addCtorConstraint outerRegion context ctorRegion home typeName typeVarNames ctorName args tipe state =

192+ do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) typeVarNames

193+ let typePairs = map (second VarN) varPairs

194+ let freeVarDict = Map.fromList typePairs

195+

196+ (State headers vars revCons) <-

197+ foldM (addCtorArgConstraint ctorRegion ctorName freeVarDict) state args

198+

199+ let ctorType = AppN home typeName (map snd typePairs)

200+ let ctorCon = CPattern outerRegion context (Error.PCtor ctorName) ctorRegion ctorType tipe

201+

202+ return $

203+ State

204+ { _headers = headers

205+ , _vars = Bag.append vars (Bag.fromList snd varPairs)

206+ , _revCons = ctorCon : revCons

207+ }

208+

209+

210+addCtorArgConstraint :: R.Region -> N.Name -> Map.Map N.Name Type -> State -> Can.PatternCtorArg -> IO State

211+addCtorArgConstraint ctorRegion ctorName freeVarDict state (Can.PatternCtorArg index srcType pattern) =

212+ do tipe <- Instantiate.fromSrcType freeVarDict srcType

213+ addConstraints ctorRegion (Error.PatternCtorArg ctorName index) pattern tipe state

src/Type/Instantiate.hs+2−39

@@ -1,59 +1,22 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Type.Instantiate

4− ( Ctor(..)

5− , pattern

6− , flexible

4+ ( flexible

75 , rigid

6+ , fromSrcType

87 )

98 where

109

1110

12−import Control.Arrow (second)

1311import qualified Data.Map.Strict as Map

1412import Data.Map.Strict ((!))

1513

16−import qualified AST.Expression.Canonical as Can

17−import qualified AST.Module.Name as ModuleName

1814import qualified AST.Type as T

1915import qualified Elm.Name as N

2016import Type.Type

2117

2218

2319

24−-- FROM PATTERN

25−

26−

27−data Ctor =

28− Ctor

29− { _vars :: [Variable]

30− , _args :: [(Int, Type, Can.Pattern)]

31− , _type :: Type

32− }

33−

34−

35−pattern :: ModuleName.Canonical -> N.Name -> [N.Name] -> [(Int, T.Canonical, Can.Pattern)] -> IO Ctor

36−pattern home tipe tvars args =

37− do varPairs <- traverse (\var -> (,) var <$> nameToFlex var) tvars

38− let typePairs = map (second VarN) varPairs

39−

40− targs <- traverse (patternHelp (Map.fromList typePairs)) args

41−

42− return $

43− Ctor

44− { _vars = map snd varPairs

45− , _args = targs

46− , _type = AppN home tipe (map snd typePairs)

47− }

48−

49−

50−patternHelp :: Map.Map N.Name Type -> (i, T.Canonical, p) -> IO (i, Type, p)

51−patternHelp freeVarDict (index, srcType, arg) =

52− do tipe <- fromSrcType freeVarDict srcType

53− return (index, tipe, arg)

54−

55−

56−

5720-- FROM SOURCE TYPES

5821

5922