27cee06 · elk · git.iko.soy

git.iko.soy/elk

Store canonical types with pattern lookup table

This means we will not need to look any types up when generating type constraints for patterns. Instead of paying O(log2(n)) in the number of patterns in your dependencies, we pay O(1) to follow a pointer to things that are already allocated anyway. I suspect this same strategy can be used for all foreign values as well. I need to look into the performance of going from a AST.Type.Canonical to a Type.Type.Variable with the correct rank. My gut is that it’ll actually be faster than going through Type.Type.Type.

commit27cee06fcfc8285ce91d17c6061b19c7f70d5b15 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 6 Nov 2017, 14:59 (9 years ago) parenta8bfb99

8 files changed+128−112

compare with master

unifiedsplit

src/AST/Expression/Canonical.hs+7−1 src/Canonicalize/Effects.hs+9−2 src/Canonicalize/Environment.hs+1−37 src/Canonicalize/Environment/Foreign.hs+28−15 src/Canonicalize/Environment/Internals.hs+22−12 src/Canonicalize/Environment/Local.hs+37−29 src/Canonicalize/Module.hs+19−10 src/Canonicalize/Pattern.hs+5−6

src/AST/Expression/Canonical.hs+7−1

@@ -109,10 +109,16 @@ data Pattern_

109109 | PAlias Pattern N.Name

110110 | PUnit

111111 | PTuple Pattern Pattern (Maybe Pattern)

112− | PCtor ModuleName.Canonical N.Name [Pattern]

113112 | PList [Pattern]

114113 | PCons Pattern Pattern

115114 | PLiteral Literal.Literal

115+ | PCtor

116+ { _p_home :: ModuleName.Canonical

117+ , _p_type :: N.Name

118+ , _p_vars :: [N.Name]

119+ , _p_name :: N.Name

120+ , _p_args :: [(Int, Type.Canonical, Pattern)] -- zero indexed

121+ }

116122

117123

118124type Destructors = Map.Map N.Name (A.Located Destructor)

src/Canonicalize/Effects.hs+9−2

@@ -156,8 +156,15 @@ checkPayload tipe =

156156 Type.Unit ->

157157 Right ()

158158

159− Type.Tuple a b cs ->

160− F.traverse_ checkPayload (a:b:cs)

159+ Type.Tuple a b maybeC ->

160+ do checkPayload a

161+ checkPayload b

162+ case maybeC of

163+ Nothing ->

164+ Right ()

165+

166+ Just c ->

167+ checkPayload c

161168

162169 Type.Var name ->

163170 Left (tipe, Error.TypeVariable name)

src/Canonicalize/Environment.hs+1−37

@@ -3,51 +3,15 @@

33module Canonicalize.Environment

44 ( Env.Result

55 , Env.Env

6− , create

76 , Env.addLocals

87 , Env.findVar

98 , Env.findType

109 , Env.findPattern

1110 , Env.findBinop

1211 , Env.Binop(Env.Binop)

12+ , Env.Pattern(Env.Pattern)

1313 )

1414 where

1515

1616

17−

18−import qualified Data.Map.Strict as Map

19−

20−import qualified AST.Expression.Valid as Valid

21−import qualified AST.Module.Name as ModuleName

22−import qualified Canonicalize.Environment.Foreign as Foreign

2317import qualified Canonicalize.Environment.Internals as Env

24−import qualified Canonicalize.Environment.Local as Local

25−import qualified Elm.Interface as I

26−import qualified Elm.Name as N

27−import qualified Elm.Package as Package

28−import qualified Reporting.Error.Canonicalize as Error

29−import qualified Reporting.Result as Result

30−import qualified Reporting.Warning as Warning

31−

32−

33−

34−-- RESULT

35−

36−

37−type Result a =

38− Result.Result () Warning.Warning Error.Error a

39−

40−

41−

42−-- CREATE

43−

44−

45−type ImportDict =

46− Map.Map N.Name ModuleName.Canonical

47−

48−

49−create :: Package.Name -> ImportDict -> I.Interfaces -> Valid.Module -> Result Env.Env

50−create pkg importDict interfaces module_@(Valid.Module name _ _ _ imports _ _ _ _ _) =

51− let home = ModuleName.Canonical pkg name in

52− Local.addDeclarations module_ =<<

53− Foreign.createInitialEnv home importDict interfaces imports

src/Canonicalize/Environment/Foreign.hs+28−15

@@ -40,8 +40,8 @@ type Result a =

4040data Env =

4141 Env

4242 { _vars :: Map.Map N.Name (Env.Homes ModuleName.Canonical)

43− , _types :: Map.Map N.Name (Env.Homes (Env.Type, Int))

44− , _patterns :: Map.Map N.Name (Env.Homes (ModuleName.Canonical, Int))

43+ , _types :: Map.Map N.Name (Env.Homes Env.Type)

44+ , _patterns :: Map.Map N.Name (Env.Homes Env.Pattern)

4545 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Env.Binop)

4646 }

4747

@@ -91,8 +91,7 @@ importToEnv :: Import -> Env

9191importToEnv (Import home (I.Interface types unions aliases binops) prefix exposing) =

9292 let

9393 patterns =

94− let dector (Can.Union _ ctors) = map (fmap length) ctors in

95− Map.fromList (concatMap dector (Map.elems unions))

94+ Map.fromList (concatMap (toPatterns home) (Map.toList unions))

9695 in

9796 case exposing of

9897 Open ->

@@ -102,7 +101,7 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi

102101 (Map.map (toOpenHomes home prefix toUnionInfo) unions)

103102 (Map.map (toOpenHomes home prefix toAliasInfo) aliases)

104103 )

105− (Map.map (toOpenHomes home prefix (,)) patterns)

104+ (Map.map (toOpenHomes home prefix toPatternInfo) patterns)

106105 (Map.mapWithKey (toBinopHomes home) binops)

107106

108107 Explicit explicits ->

@@ -112,15 +111,10 @@ importToEnv (Import home (I.Interface types unions aliases binops) prefix exposi

112111 (Map.mapWithKey (toExplicitHomes home prefix explicits toUnionInfo toUnionBag) unions)

113112 (Map.mapWithKey (toExplicitHomes home prefix explicits toAliasInfo toAliasBag) aliases)

114113 )

115− (Map.mapWithKey (toExplicitHomes home prefix explicits (,) toPatternBag) patterns)

114+ (Map.mapWithKey (toExplicitHomes home prefix explicits toPatternInfo toPatternBag) patterns)

116115 (Map.mapWithKey (toBinopHomes home) binops)

117116

118117

119−toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop

120−toBinopHomes home op (Can.Binop_ associativity precedence name) =

121− OneOrMore.one (Env.Binop op home name associativity precedence)

122−

123−

124118toOpenHomes

125119 :: ModuleName.Canonical

126120 -> N.Name

@@ -150,18 +144,37 @@ toExplicitHomes home prefix explicits toInfo toBag name value =

150144 (Map.singleton prefix (OneOrMore.one info))

151145

152146

147+toBinopHomes :: ModuleName.Canonical -> N.Name -> Can.Binop -> OneOrMore.OneOrMore Env.Binop

148+toBinopHomes home op (Can.Binop_ associativity precedence name) =

149+ OneOrMore.one (Env.Binop op home name associativity precedence)

150+

151+

153152

154153-- TO INFO

155154

156155

157−toUnionInfo :: ModuleName.Canonical -> Can.Union -> ( Env.Type, Int )

156+toUnionInfo :: ModuleName.Canonical -> Can.Union -> Env.Type

158157toUnionInfo home (Can.Union args _) =

159− ( Env.Union home, length args )

158+ Env.Union (length args) home

160159

161160

162−toAliasInfo :: ModuleName.Canonical -> Can.Alias -> ( Env.Type, Int )

161+toAliasInfo :: ModuleName.Canonical -> Can.Alias -> Env.Type

163162toAliasInfo home (Can.Alias args tipe _) =

164− ( Env.Alias home args tipe, length args )

163+ Env.Alias (length args) home args tipe

164+

165+

166+toPatternInfo :: ModuleName.Canonical -> Env.Pattern -> Env.Pattern

167+toPatternInfo _ pattern =

168+ pattern

169+

170+

171+toPatterns :: ModuleName.Canonical -> (N.Name, Can.Union) -> [(N.Name, Env.Pattern)]

172+toPatterns home (tipe, Can.Union vars ctors) =

173+ let

174+ fromCtor (name, args) =

175+ (name, Env.Pattern home tipe vars args)

176+ in

177+ map fromCtor ctors

165178

166179

167180

src/Canonicalize/Environment/Internals.hs+22−12

@@ -6,6 +6,7 @@ module Canonicalize.Environment.Internals

66 , VarHomes(..)

77 , UnqualifiedVarHome(..)

88 , Type(..)

9+ , Pattern(..)

910 , Homes(..)

1011 , addLocals

1112 , findVar

@@ -51,8 +52,8 @@ data Env =

5152 Env

5253 { _home :: ModuleName.Canonical

5354 , _vars :: Map.Map N.Name VarHomes

54− , _types :: Map.Map N.Name (Homes (Type, Int))

55− , _patterns :: Map.Map N.Name (Homes (ModuleName.Canonical, Int))

55+ , _types :: Map.Map N.Name (Homes Type)

56+ , _patterns :: Map.Map N.Name (Homes Pattern)

5657 , _binops :: Map.Map N.Name (OneOrMore.OneOrMore Binop)

5758 }

5859

@@ -78,8 +79,17 @@ data UnqualifiedVarHome

7879

7980

8081data Type

81− = Alias ModuleName.Canonical [N.Name] Type.Canonical

82− | Union ModuleName.Canonical

82+ = Alias Int ModuleName.Canonical [N.Name] Type.Canonical

83+ | Union Int ModuleName.Canonical

84+

85+

86+data Pattern =

87+ Pattern

88+ { _p_home :: ModuleName.Canonical

89+ , _p_type :: N.Name

90+ , _p_vars :: [N.Name]

91+ , _p_args :: [Type.Canonical]

92+ }

8393

8494

8595data Binop =

@@ -87,8 +97,8 @@ data Binop =

8797 { _op_name :: N.Name

8898 , _op_home :: ModuleName.Canonical

8999 , _op_func :: N.Name

90− , _associativity :: Binop.Associativity

91− , _precedence :: Binop.Precedence

100+ , _op_associativity :: Binop.Associativity

101+ , _op_precedence :: Binop.Precedence

92102 }

93103

94104

@@ -174,14 +184,14 @@ findVar region (Env home vars _ _ _) maybePrefix name =

174184-- FIND TYPE and PATTERN

175185

176186

177−findType :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i Type

178−findType region (Env _ _ types _ _) maybePrefix name arity =

179− error "TODO findType" region types maybePrefix name arity

187+findType :: R.Region -> Env -> Maybe N.Name -> N.Name -> Result () Type

188+findType region (Env _ _ types _ _) maybePrefix name =

189+ error "TODO findType" region types maybePrefix name

180190

181191

182−findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Int -> Result i ModuleName.Canonical

183−findPattern region (Env _ _ _ patterns _) maybePrefix name arity =

184− error "TODO findPattern" region patterns maybePrefix name arity

192+findPattern :: (Monoid i) => R.Region -> Env -> Maybe N.Name -> N.Name -> Result i Pattern

193+findPattern region (Env _ _ _ patterns _) maybePrefix name =

194+ error "TODO findPattern" region patterns maybePrefix name

185195

186196

187197

src/Canonicalize/Environment/Local.hs+37−29

@@ -1,7 +1,8 @@

11{-# OPTIONS_GHC -Wall #-}

22{-# LANGUAGE OverloadedStrings #-}

33module Canonicalize.Environment.Local

4− ( addDeclarations

4+ ( addVarsTypesOps

5+ , addPatterns

56 )

67 where

@@ -12,6 +13,7 @@ import qualified Data.Graph as Graph

1213import qualified Data.Map.Strict as Map

1314import qualified Data.Map.Merge.Strict as Map

1415

16+import qualified AST.Expression.Canonical as Can

1517import qualified AST.Expression.Valid as Valid

1618import qualified AST.Type as Type

1719import qualified Canonicalize.Environment.Dups as Dups

@@ -36,14 +38,18 @@ type Result a =

3638

3739

3840

39−-- ADD DECLARATIONS

41+-- ADD VARS, TYPES, AND OPS

42+--

43+-- We can add names for local definitions, unions, aliases, and operators.

44+-- These are basically just names. We CANNOT add patterns though. Those must

45+-- be added by `addPatterns` after some canonicalization has occurred.

46+--

47+-- This code checks for (1) duplicate names and (2) cycles in type aliases.

4048

4149

42−addDeclarations :: Valid.Module -> Env.Env -> Result Env.Env

43−addDeclarations module_ env =

44− addVars module_

45− =<< addTypes module_

46− =<< addBinops module_ (addPatterns module_ env)

50+addVarsTypesOps :: Valid.Module -> Env.Env -> Result Env.Env

51+addVarsTypesOps module_ env =

52+ addVars module_ =<< addTypes module_ =<< addBinops module_ env

4753

4854

4955merge

@@ -65,31 +71,36 @@ merge addLeft addBoth locals foreigns =

6571

6672-- ADD PATTERNS

6773--

68−-- This does not return a Result because Dups.detect is already called in

69−-- collectUpperVars. This will detect all local pattern clashes. We skip it

74+-- Local patterns are added to the environment later such that we can have

75+-- canonical union types. This way we can avoid looking up the types during

76+-- type constraint generation.

77+--

78+-- This function does not return a Result because Dups.detect is already called

79+-- in collectUpperVars. This will detect all local pattern clashes. We skip it

7080-- here to avoid a second version of the same error.

7181

7282

73−addPatterns :: Valid.Module -> Env.Env -> Env.Env

74−addPatterns (Valid.Module _ _ _ _ _ _ unions _ _ _) (Env.Env home vars types patterns binops) =

83+addPatterns :: Map.Map N.Name Can.Union -> Env.Env -> Env.Env

84+addPatterns unions (Env.Env home vars types patterns binops) =

7585 let

76− unionToInfos (Valid.Union _ _ ctors) =

77− map ctorToPair ctors

78−

79− ctorToPair (A.A _ name, args) =

80− ( name, length args )

81−

8286 localPatterns =

83− Map.fromList $ concatMap unionToInfos unions

87+ Map.fromList $ concatMap toPatterns (Map.toList unions)

8488

85− addLeft _ arity =

86− Env.Homes (Bag.one (home, arity)) Map.empty

87−

88− addBoth _ arity (Env.Homes _ qualified) =

89− Env.Homes (Bag.one (home, arity)) qualified

89+ toPatterns (tipe, Can.Union tvars ctors) =

90+ map (ctorToPattern tipe tvars) ctors

9091

92+ ctorToPattern tipe tvars (name, args) =

93+ ( name, Env.Pattern home tipe tvars args )

94+ in

95+ let

9196 newPatterns =

9297 merge addLeft addBoth localPatterns patterns

98+

99+ addLeft _ localPattern =

100+ Env.Homes (Bag.one localPattern) Map.empty

101+

102+ addBoth _ localPattern (Env.Homes _ qualified) =

103+ Env.Homes (Bag.one localPattern) qualified

93104 in

94105 Env.Env home vars types newPatterns binops

95106

@@ -229,14 +240,11 @@ addTypes (Valid.Module _ _ _ _ _ _ unions aliases _ _) env =

229240addUnionTypes :: Map.Map N.Name Int -> Env.Env -> Env.Env

230241addUnionTypes unions (Env.Env home vars types patterns binops) =

231242 let

232− unionHome =

233− Env.Union home

234−

235243 addLeft _ arity =

236− Env.Homes (Bag.one (unionHome, arity)) Map.empty

244+ Env.Homes (Bag.one (Env.Union arity home)) Map.empty

237245

238246 addBoth _ arity (Env.Homes _ qualified) =

239− Env.Homes (Bag.one (unionHome, arity)) qualified

247+ Env.Homes (Bag.one (Env.Union arity home)) qualified

240248

241249 newTypes =

242250 merge addLeft addBoth unions types

@@ -269,7 +277,7 @@ addTypeAlias env@(Env.Env home vars types patterns binops) scc =

269277 case scc of

270278 Graph.AcyclicSCC (Alias _ name args tipe) ->

271279 do ctype <- Type.canonicalize env tipe

272− let info = (Env.Alias home args ctype, length args)

280+ let info = Env.Alias (length args) home args ctype

273281 let newTypes = Map.alter (addAliasInfo info) name types

274282 return $ Env.Env home vars newTypes patterns binops

275283

src/Canonicalize/Module.hs+19−10

@@ -17,6 +17,8 @@ import qualified AST.Type as Type

1717import qualified Canonicalize.Effects as Effects

1818import qualified Canonicalize.Environment as Env

1919import qualified Canonicalize.Environment.Dups as Dups

20+import qualified Canonicalize.Environment.Foreign as Foreign

21+import qualified Canonicalize.Environment.Local as Local

2022import qualified Canonicalize.Expression as Expr

2123import qualified Canonicalize.Pattern as Pattern

2224import qualified Canonicalize.Type as Type

@@ -48,20 +50,27 @@ canonicalize

4850 -> I.Interfaces

4951 -> Valid.Module

5052 -> Result Can.Module

51−canonicalize pkg importDict interfaces module_ =

52− do env <- Env.create pkg importDict interfaces module_

53− let (Valid.Module name _ _ exports _ decls unions aliases binops effects) = module_

54− (cdecls, cunions, caliases) <-

55− (,,)

56− <$> canonicalizeDecls env decls

57− <*> (Map.fromList <$> traverse (canonicalizeUnion env) unions)

58− <*> (Map.fromList <$> traverse (canonicalizeAlias env) aliases)

53+canonicalize pkg importDict interfaces module_@(Valid.Module name _ _ exports imports decls unions aliases binops effects) =

54+ do let home = ModuleName.Canonical pkg name

5955

56+ startEnv <- Local.addVarsTypesOps module_ =<<

57+ Foreign.createInitialEnv home importDict interfaces imports

58+

59+ (cunions, caliases) <-

60+ (,)

61+ <$> (Map.fromList <$> traverse (canonicalizeUnion startEnv) unions)

62+ <*> (Map.fromList <$> traverse (canonicalizeAlias startEnv) aliases)

63+

64+ let finalEnv = Local.addPatterns cunions startEnv

6065 let cbinops = Map.fromList (map canonicalizeBinop binops)

61− ceffects <- Effects.canonicalize env decls cunions effects

66+

67+ (cdecls, ceffects) <-

68+ (,)

69+ <$> canonicalizeDecls finalEnv decls

70+ <*> Effects.canonicalize finalEnv decls cunions effects

71+

6272 cexports <- canonicalizeExports decls cunions caliases cbinops ceffects exports

6373

64− let home = ModuleName.Canonical pkg name

6574 let docs = toDocs module_

6675 return $ Can.Module home docs cexports cdecls cunions caliases cbinops ceffects

6776

src/Canonicalize/Pattern.hs+5−6

@@ -170,13 +170,12 @@ canonicalize env destructor (A.A region pattern) =

170170

171171 Src.PCtor nameRegion maybePrefix name patterns ->

172172 let

173− ctorArg ptrn index =

174− canonicalize env (Can.DIndex index destructor) ptrn

173+ canArgs ptrn tipe index =

174+ (,,) index tipe <$> canonicalize env (Can.DIndex index destructor) ptrn

175175 in

176− Can.PCtor

177− <$> Env.findPattern nameRegion env maybePrefix name (length patterns)

178− <*> pure name

179− <*> zipWithM ctorArg patterns [ 0 .. length patterns ]

176+ do (Env.Pattern home tipe vars args) <- Env.findPattern nameRegion env maybePrefix name

177+ Can.PCtor home tipe vars name

178+ <$> sequenceA (zipWith3 canArgs patterns args [ 0 .. length patterns ])

180179

181180 Src.PList patterns ->

182181 Can.PList <$> canonicalizeList env destructor patterns