e24e0fa · elk · git.iko.soy

compiler/src/AST/Canonical.hs+32−4

compare with master

unifiedsplit

@@ -15,6 +15,8 @@ module AST.Canonical

15 , Annotation(..)

16 , Type(..)

17 , AliasType(..)

18+ , FieldType(..)

19+ , fieldsToList

18 -- modules

20 -- modules

19 , Module(..)

21 , Module(..)

20 , Alias(..)

22 , Alias(..)

@@ -53,6 +55,7 @@ So it is clear why the data is kept around.

53import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)

55import Control.Monad (liftM, liftM2, liftM3, liftM4, replicateM)

54import Data.Binary

56import Data.Binary

55import qualified Data.ByteString as B

57import qualified Data.ByteString as B

58+import qualified Data.List as List

56import qualified Data.Map as Map

59import qualified Data.Map as Map

57import Data.Text (Text)

60import Data.Text (Text)

58

61

@@ -188,7 +191,7 @@ data Type

188 = TLambda Type Type

191 = TLambda Type Type

189 | TVar N.Name

192 | TVar N.Name

190 | TType ModuleName.Canonical N.Name [Type]

193 | TType ModuleName.Canonical N.Name [Type]

191− | TRecord (Map.Map N.Name Type) (Maybe N.Name)

194+ | TRecord (Map.Map N.Name FieldType) (Maybe N.Name)

192 | TUnit

195 | TUnit

193 | TTuple Type Type (Maybe Type)

196 | TTuple Type Type (Maybe Type)

194 | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType

197 | TAlias ModuleName.Canonical N.Name [(N.Name, Type)] AliasType

@@ -199,6 +202,26 @@ data AliasType

199 | Filled Type

202 | Filled Type

200

203

201

204

205+data FieldType =

206+ FieldType {-# UNPACK #-} !Word16 Type

207+

208+

209+-- NOTE: The Word16 marks the source order, but it may not be available

210+-- for every canonical type. For example, if the canonical type is inferred

211+-- the orders will all be zeros.

212+--

213+fieldsToList :: Map.Map N.Name FieldType -> [(N.Name, Type)]

214+fieldsToList fields =

215+ let

216+ getIndex (_, FieldType index _) =

217+ index

218+

219+ dropIndex (name, FieldType _ tipe) =

220+ (name, tipe)

221+ in

222+ map dropIndex (List.sortOn getIndex (Map.toList fields))

223+

224+

202

225

203-- MODULES

226-- MODULES

204

227

@@ -216,7 +239,7 @@ data Module =

216 }

239 }

217

240

218

241

219−data Alias = Alias [N.Name] Type (Maybe [(N.Name,Type)])

242+data Alias = Alias [N.Name] Type

220data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name

243data Binop = Binop_ Binop.Associativity Binop.Precedence N.Name

221

244

222

245

@@ -297,8 +320,8 @@ data Manager

297

320

298

321

299instance Binary Alias where

322instance Binary Alias where

300− get = liftM3 Alias get get get

323+ get = liftM2 Alias get get

301− put (Alias a b c) = put a >> put b >> put c

324+ put (Alias a b) = put a >> put b

302

325

303

326

304instance Binary Union where

327instance Binary Union where

@@ -376,3 +399,8 @@ instance Binary AliasType where

376 0 -> liftM Holey get

399 0 -> liftM Holey get

377 1 -> liftM Filled get

400 1 -> liftM Filled get

378 _ -> error "binary encoding of AliasType was corrupted"

401 _ -> error "binary encoding of AliasType was corrupted"

402+

403+

404+instance Binary FieldType where

405+ get = liftM2 FieldType get get

406+ put (FieldType a b) = put a >> put b

compiler/src/AST/Utils/Type.hs+13−3

@@ -11,7 +11,7 @@ module AST.Utils.Type

11

12import qualified Data.Map as Map

13

14−import AST.Canonical (Type(..), AliasType(..))

14+import AST.Canonical (Type(..), AliasType(..), FieldType(..))

15import qualified Elm.Name as N

16

17

@@ -55,7 +55,7 @@ dealiasHelp typeTable tipe =

55 Map.findWithDefault tipe x typeTable

56

57 TRecord fields ext ->

58− TRecord (Map.map (dealiasHelp typeTable) fields) ext

58+ TRecord (Map.map (dealiasField typeTable) fields) ext

59

60 TAlias home name args t' ->

61 TAlias home name (map (fmap (dealiasHelp typeTable)) args) t'

@@ -73,6 +73,11 @@ dealiasHelp typeTable tipe =

73 (fmap (dealiasHelp typeTable) maybeC)

74

75

76+dealiasField :: Map.Map N.Name Type -> FieldType -> FieldType

77+dealiasField typeTable (FieldType index tipe) =

78+ FieldType index (dealiasHelp typeTable tipe)

79+

80+

76

81

77-- DEEP DEALIAS

82-- DEEP DEALIAS

78

83

@@ -87,7 +92,7 @@ deepDealias tipe =

87 tipe

92 tipe

88

93

89 TRecord fields ext ->

94 TRecord fields ext ->

90− TRecord (Map.map deepDealias fields) ext

95+ TRecord (Map.map deepDealiasField fields) ext

91

96

92 TAlias _ _ args tipe' ->

97 TAlias _ _ args tipe' ->

93 deepDealias (dealias args tipe')

98 deepDealias (dealias args tipe')

@@ -102,6 +107,11 @@ deepDealias tipe =

102 TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)

107 TTuple (deepDealias a) (deepDealias b) (fmap deepDealias c)

103

108

104

109

110+deepDealiasField :: FieldType -> FieldType

111+deepDealiasField (FieldType index tipe) =

112+ FieldType index (deepDealias tipe)

113+

114+

105

115

106-- ITERATED DEALIAS

116-- ITERATED DEALIAS

107

117

compiler/src/Canonicalize/Effects.hs+6−1

@@ -202,7 +202,12 @@ checkPayload tipe =

202 Left (tipe, Error.ExtendedRecord)

203

204 Can.TRecord fields Nothing ->

205− F.traverse_ checkPayload fields

205+ F.traverse_ checkFieldPayload fields

206+

207+

208+checkFieldPayload :: Can.FieldType -> Either (Can.Type, Error.InvalidPayload) ()

209+checkFieldPayload (Can.FieldType _ tipe) =

210+ checkPayload tipe

206

211

207

212

208isIntFloatBool :: ModuleName.Canonical -> N.Name -> Bool

213isIntFloatBool :: ModuleName.Canonical -> N.Name -> Bool

compiler/src/Canonicalize/Environment/Foreign.hs+7−7

@@ -153,24 +153,24 @@ aliasToType home name alias =

153

154

155aliasToTypeHelp :: ModuleName.Canonical -> N.Name -> Can.Alias -> (Env.Type, Env.Exposed Env.Ctor)

156−aliasToTypeHelp home name (Can.Alias vars tipe maybeRecordFields) =

156+aliasToTypeHelp home name (Can.Alias vars tipe) =

157 (

158 Env.Alias (length vars) home vars tipe

159 ,

160− case maybeRecordFields of

160+ case tipe of

161− Nothing ->

161+ Can.TRecord fields Nothing ->

162− Map.empty

163−

164− Just fields ->

165 let

162 let

166 avars = map (\var -> (var, Can.TVar var)) vars

163 avars = map (\var -> (var, Can.TVar var)) vars

167 alias =

164 alias =

168 foldr

165 foldr

169 (\(_,t1) t2 -> Can.TLambda t1 t2)

166 (\(_,t1) t2 -> Can.TLambda t1 t2)

170 (Can.TAlias home name avars (Can.Filled tipe))

167 (Can.TAlias home name avars (Can.Filled tipe))

171− fields

168+ (Can.fieldsToList fields)

172 in

169 in

173 Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))

170 Map.singleton name (Map.singleton home (Env.RecordCtor home vars alias))

171+

172+ _ ->

173+ Map.empty

174 )

175

176

compiler/src/Canonicalize/Environment/Local.hs+21−9

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

6 where

7

8

9−import Control.Arrow (first)

10import Control.Monad (foldM)

9import Control.Monad (foldM)

11import qualified Data.Graph as Graph

10import qualified Data.Graph as Graph

12import qualified Data.List as List

11import qualified Data.List as List

@@ -295,28 +294,41 @@ canonicalizeAlias :: Env.Env -> Valid.Alias -> Result i w ( (N.Name, Can.Alias),

295canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =

294canonicalizeAlias env@(Env.Env home _ _ _ _ _ _ _) (Valid.Alias _ (A.At region name) args tipe) =

296 case tipe of

295 case tipe of

297 A.At _ (Src.TRecord fields Nothing) ->

296 A.At _ (Src.TRecord fields Nothing) ->

298− do cfields <- traverse (traverse (Type.canonicalize env)) fields

297+ do cfields <- canonicalizeFields env fields

299 fieldDict <- Dups.checkFields cfields

298 fieldDict <- Dups.checkFields cfields

300

299

300+ let

301+ addArg (_, Can.FieldType _ t1) t2 = Can.TLambda t1 t2

301− let recordType = Can.TRecord fieldDict Nothing

302+ recordType = Can.TRecord fieldDict Nothing

302− let ctorType = foldr (Can.TLambda . snd) recordType cfields

303− let vars = map A.toValue args

303+ vars = map A.toValue args

304− let alias = Can.Alias vars recordType (Just (map (first A.toValue) cfields))

305− let ctor = Env.RecordCtor home vars ctorType

304+ ctor = Env.RecordCtor home vars (foldr addArg recordType cfields)

306

305

307 Result.ok

306 Result.ok

308− ( (name, alias)

307+ ( (name, Can.Alias vars recordType)

309 , Dups.one name region (Map.singleton home ctor)

308 , Dups.one name region (Map.singleton home ctor)

310 )

309 )

311

310

312 _ ->

311 _ ->

313 do ctipe <- Type.canonicalize env tipe

312 do ctipe <- Type.canonicalize env tipe

314 Result.ok

313 Result.ok

315− ( (name, Can.Alias (map A.toValue args) ctipe Nothing)

314+ ( (name, Can.Alias (map A.toValue args) ctipe)

316 , Dups.none

315 , Dups.none

317 )

316 )

318

317

319

318

319+canonicalizeFields :: Env.Env -> [(A.Located N.Name, Src.Type)] -> Result i w [(A.Located N.Name, Can.FieldType)]

320+canonicalizeFields env fields =

321+ let

322+ len =

323+ fromIntegral (length fields)

324+

325+ canonicalizeField index (name, srcType) =

326+ do tipe <- Type.canonicalize env srcType

327+ return (name, Can.FieldType index tipe)

328+ in

329+ sequenceA (zipWith canonicalizeField [0..len] fields)

330+

331+

320

332

321-- CANONICALIZE UNION

333-- CANONICALIZE UNION

322

334

compiler/src/Canonicalize/Type.hs+18−4

@@ -63,8 +63,7 @@ canonicalize env (A.At typeRegion tipe) =

63 <*> canonicalize env b

64

65 Src.TRecord fields ext ->

66− do fieldDict <- Dups.checkFields fields

66+ do cfields <- sequenceA =<< Dups.checkFields (canonicalizeFields env fields)

67− cfields <- traverse (canonicalize env) fieldDict

68 return $ Can.TRecord cfields (fmap A.toValue ext)

67 return $ Can.TRecord cfields (fmap A.toValue ext)

69

68

70 Src.TUnit ->

69 Src.TUnit ->

@@ -86,6 +85,16 @@ canonicalize env (A.At typeRegion tipe) =

86 Result.throw $ Error.TupleLargerThanThree typeRegion

85 Result.throw $ Error.TupleLargerThanThree typeRegion

87

86

88

87

88+canonicalizeFields :: Env.Env -> [(A.Located N.Name, Src.Type)] -> [(A.Located N.Name, Result i w Can.FieldType)]

89+canonicalizeFields env fields =

90+ let

91+ len = fromIntegral (length fields)

92+ canonicalizeField index (name, srcType) =

93+ (name, Can.FieldType index <$> canonicalize env srcType)

94+ in

95+ zipWith canonicalizeField [0..len] fields

96+

97+

89

98

90-- CANONICALIZE TYPE

99-- CANONICALIZE TYPE

91

100

@@ -129,10 +138,10 @@ addFreeVars freeVars tipe =

129 List.foldl' addFreeVars freeVars args

138 List.foldl' addFreeVars freeVars args

130

139

131 Can.TRecord fields Nothing ->

140 Can.TRecord fields Nothing ->

132− Map.foldl addFreeVars freeVars fields

141+ Map.foldl addFieldFreeVars freeVars fields

133

142

134 Can.TRecord fields (Just ext) ->

143 Can.TRecord fields (Just ext) ->

135− Map.foldl addFreeVars (Map.insert ext () freeVars) fields

144+ Map.foldl addFieldFreeVars (Map.insert ext () freeVars) fields

136

145

137 Can.TUnit ->

146 Can.TUnit ->

138 freeVars

147 freeVars

@@ -147,3 +156,8 @@ addFreeVars freeVars tipe =

147

156

148 Can.TAlias _ _ args _ ->

157 Can.TAlias _ _ args _ ->

149 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args

158 List.foldl' (\fvs (_,arg) -> addFreeVars fvs arg) freeVars args

159+

160+

161+addFieldFreeVars :: Map.Map N.Name () -> Can.FieldType -> Map.Map N.Name ()

162+addFieldFreeVars freeVars (Can.FieldType _ tipe) =

163+ addFreeVars freeVars tipe

compiler/src/Elm/Compiler/Type/Extract.hs+2−3

@@ -10,7 +10,6 @@ module Elm.Compiler.Type.Extract

10

11

12import Data.Map ((!))

13−import qualified Data.Map as Map

14import qualified Data.Maybe as Maybe

13import qualified Data.Maybe as Maybe

15import qualified Data.Set as Set

14import qualified Data.Set as Set

16

15

@@ -53,7 +52,7 @@ extract astType =

53 <*> traverse extract args

52 <*> traverse extract args

54

53

55 Can.TRecord fields ext ->

54 Can.TRecord fields ext ->

56− do efields <- fmap Map.toList (traverse extract fields)

55+ do efields <- traverse (traverse extract) (Can.fieldsToList fields)

57 pure (T.Record efields ext)

56 pure (T.Record efields ext)

58

57

59 Can.TUnit ->

58 Can.TUnit ->

@@ -123,7 +122,7 @@ extractAlias :: I.Interfaces -> Opt.Global -> Extractor T.Alias

123extractAlias interfaces (Opt.Global home name) =

122extractAlias interfaces (Opt.Global home name) =

124 let

123 let

125 (I.Interface _ _ aliases _) = interfaces ! home

124 (I.Interface _ _ aliases _) = interfaces ! home

126− (Can.Alias args aliasType _) = I.toAliasInternals (aliases ! name)

125+ (Can.Alias args aliasType) = I.toAliasInternals (aliases ! name)

127 in

126 in

128 T.Alias (toPublicName home name) args <$> extract aliasType

127 T.Alias (toPublicName home name) args <$> extract aliasType

129

128

compiler/src/Elm/Docs.hs+1−1

@@ -453,7 +453,7 @@ addExport info (Module n c us as_ vs bs) (name, A.At region export) =

453 Result.ok $ Module n c us as_ vs newBinops

454

455 Can.ExportAlias ->

456− do let (Can.Alias tvars tipe _) = _iAliases info ! name

456+ do let (Can.Alias tvars tipe) = _iAliases info ! name

457 comment <- getComment region name info

458

459 let newAliases = Map.insert name (Alias comment tvars (Extract.fromType tipe)) as_

compiler/src/Optimize/Module.hs+10−15

@@ -90,16 +90,13 @@ addAliases home aliases graph =

90

91

92addAlias :: ModuleName.Canonical -> N.Name -> Can.Alias -> Opt.Graph -> Opt.Graph

93−addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph mains nodes fieldCounts) =

93+addAlias home name (Can.Alias _ tipe) graph@(Opt.Graph mains nodes fieldCounts) =

94− case maybeFields of

94+ case tipe of

95− Nothing ->

95+ Can.TRecord fields Nothing ->

96− graph

97−

98− Just fields ->

99 let

96 let

100 function =

97 function =

101− Opt.Function (map fst fields) $ Opt.Record $

98+ Opt.Function (map fst (Can.fieldsToList fields)) $ Opt.Record $

102− Map.fromList $ map toPair fields

99+ Map.mapWithKey (\field _ -> Opt.VarLocal field) fields

103

100

104 node =

101 node =

105 Opt.Define function Set.empty

102 Opt.Define function Set.empty

@@ -107,16 +104,14 @@ addAlias home name (Can.Alias _ _ maybeFields) graph@(Opt.Graph mains nodes fiel

107 Opt.Graph

104 Opt.Graph

108 mains

105 mains

109 (Map.insert (Opt.Global home name) node nodes)

106 (Map.insert (Opt.Global home name) node nodes)

110− (foldr addRecordCtorField fieldCounts fields)

107+ (Map.foldrWithKey addRecordCtorField fieldCounts fields)

111−

112

108

113−toPair :: (N.Name, Can.Type) -> (N.Name, Opt.Expr)

109+ _ ->

114−toPair (field, _) =

110+ graph

115− ( field, Opt.VarLocal field )

116

111

117

112

118−addRecordCtorField :: (N.Name, Can.Type) -> Map.Map N.Name Int -> Map.Map N.Name Int

113+addRecordCtorField :: N.Name -> Can.FieldType -> Map.Map N.Name Int -> Map.Map N.Name Int

119−addRecordCtorField (name, _) fields =

114+addRecordCtorField name _ fields =

120 Map.insertWith (+) name 1 fields

115 Map.insertWith (+) name 1 fields

121

116

122

117

compiler/src/Optimize/Port.hs+4−4

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

65

66 Can.TRecord fields Nothing ->

67 let

68− encodeField (name, fieldType) =

68+ encodeField (name, Can.FieldType _ fieldType) =

69 do encoder <- toEncoder fieldType

70 let value = Opt.Call encoder [Opt.Access (Opt.VarLocal N.dollar) name]

71 return $ Opt.Tuple (Opt.Str (N.toText name)) value Nothing

@@ -283,7 +283,7 @@ indexAndThen i tipe decoder =

283-- DECODE RECORDS

284

285

286−decodeRecord :: Map.Map N.Name Can.Type -> Names.Tracker Opt.Expr

286+decodeRecord :: Map.Map N.Name Can.FieldType -> Names.Tracker Opt.Expr

287decodeRecord fields =

288 let

289 toFieldExpr name _ =

@@ -297,8 +297,8 @@ decodeRecord fields =

297 Names.registerFieldDict fields (Map.toList fields)

298

299

300−fieldAndThen :: Opt.Expr -> (N.Name, Can.Type) -> Names.Tracker Opt.Expr

300+fieldAndThen :: Opt.Expr -> (N.Name, Can.FieldType) -> Names.Tracker Opt.Expr

301−fieldAndThen decoder (key, tipe) =

301+fieldAndThen decoder (key, Can.FieldType _ tipe) =

302 do andThen <- decode "andThen"

303 field <- decode "field"

304 typeDecoder <- toDecoder tipe

compiler/src/Reporting/Render/Type.hs+9−7

@@ -141,7 +141,7 @@ srcToDoc context (A.At _ tipe) =

141

142 Src.TRecord fields ext ->

143 record

144− (map fieldToDocs fields)

144+ (map srcFieldToDocs fields)

145 (fmap (D.fromName . A.toValue) ext)

146

147 Src.TUnit ->

@@ -154,8 +154,8 @@ srcToDoc context (A.At _ tipe) =

154 (map (srcToDoc None) cs)

155

156

157−fieldToDocs :: (A.Located N.Name, Src.Type) -> (Doc, Doc)

157+srcFieldToDocs :: (A.Located N.Name, Src.Type) -> (Doc, Doc)

158−fieldToDocs (A.At _ fieldName, fieldType) =

158+srcFieldToDocs (A.At _ fieldName, fieldType) =

159 ( D.fromName fieldName

160 , srcToDoc None fieldType

161 )

@@ -200,7 +200,7 @@ canToDoc localizer context tipe =

200

201 Can.TRecord fields ext ->

202 record

203− (map (entryToDocs localizer) (Map.toList fields))

203+ (map (canFieldToDoc localizer) (Can.fieldsToList fields))

204 (fmap D.fromName ext)

205

206 Can.TUnit ->

@@ -218,9 +218,11 @@ canToDoc localizer context tipe =

218 (map (canToDoc localizer App . snd) args)

219

220

221−entryToDocs :: L.Localizer -> (N.Name, Can.Type) -> (Doc, Doc)

221+canFieldToDoc :: L.Localizer -> (N.Name, Can.Type) -> (Doc, Doc)

222−entryToDocs localizer (name, tipe) =

222+canFieldToDoc localizer (name, tipe) =

223+ ( D.fromName name

223− (D.fromName name, canToDoc localizer None tipe)

224+ , canToDoc localizer None tipe

225+ )

224

226

225

227

226collectArgs :: Can.Type -> (Can.Type, [Can.Type])

228collectArgs :: Can.Type -> (Can.Type, [Can.Type])

compiler/src/Type/Instantiate.hs+6−1

@@ -62,7 +62,7 @@ fromSrcType freeVars sourceType =

62

63 Can.TRecord fields maybeExt ->

64 RecordN

65− <$> traverse (fromSrcType freeVars) fields

65+ <$> traverse (fromSrcFieldType freeVars) fields

66 <*>

67 case maybeExt of

68 Nothing ->

@@ -70,3 +70,8 @@ fromSrcType freeVars sourceType =

70

71 Just ext ->

72 return (freeVars ! ext)

73+

74+

75+fromSrcFieldType :: Map.Map N.Name Type -> Can.FieldType -> IO Type

76+fromSrcFieldType freeVars (Can.FieldType _ tipe) =

77+ fromSrcType freeVars tipe

compiler/src/Type/Solve.hs+6−1

@@ -526,7 +526,7 @@ srcTypeToVar rank pools flexVars srcType =

526 register rank pools (Structure (App1 home name argVars))

527

528 Can.TRecord fields maybeExt ->

529− do fieldVars <- traverse go fields

529+ do fieldVars <- traverse (srcFieldTypeToVar rank pools flexVars) fields

530 extVar <-

531 case maybeExt of

532 Nothing -> register rank pools emptyRecord1

@@ -555,6 +555,11 @@ srcTypeToVar rank pools flexVars srcType =

555 register rank pools (Alias home name argVars aliasVar)

556

557

558+srcFieldTypeToVar :: Int -> Pools -> Map.Map N.Name Variable -> Can.FieldType -> IO Variable

559+srcFieldTypeToVar rank pools flexVars (Can.FieldType _ srcTipe) =

560+ srcTypeToVar rank pools flexVars srcTipe

561+

562+

558

563

559-- COPY

564-- COPY

560

565

compiler/src/Type/Type.hs+7−1

@@ -400,7 +400,7 @@ termToCanType term =

400 return $ Can.TRecord Map.empty Nothing

401

402 Record1 fields extension ->

403− do canFields <- traverse variableToCanType fields

403+ do canFields <- traverse fieldToCanType fields

404 canExt <- Type.iteratedDealias <$> variableToCanType extension

405 return $

406 case canExt of

@@ -423,6 +423,12 @@ termToCanType term =

423 <*> traverse variableToCanType maybeC

424

425

426+fieldToCanType :: Variable -> StateT NameState IO Can.FieldType

427+fieldToCanType variable =

428+ do tipe <- variableToCanType variable

429+ return (Can.FieldType 0 tipe)

430+

431+

426

432

427-- TO ERROR TYPE

433-- TO ERROR TYPE

428

434