e24e0fa · elk · git.iko.soy

git.iko.soy/elk

Preserve source order of record fields

This allows the REPL and the docs to show record fields in the order they were written in the source code (if they were written in the source code!)

commite24e0fa9daf29a86c74990cb59d5b5272a2339bb authorEvan Czaplicki <evancz@users.noreply.github.com> dateTue 24 Apr 2018, 12:32 (9 years ago) parent2801245

14 files changed+142−61

compare with master

unifiedsplit

compiler/src/AST/Canonical.hs+32−4 compiler/src/AST/Utils/Type.hs+13−3 compiler/src/Canonicalize/Effects.hs+6−1 compiler/src/Canonicalize/Environment/Foreign.hs+7−7 compiler/src/Canonicalize/Environment/Local.hs+21−9 compiler/src/Canonicalize/Type.hs+18−4 compiler/src/Elm/Compiler/Type/Extract.hs+2−3 compiler/src/Elm/Docs.hs+1−1 compiler/src/Optimize/Module.hs+10−15 compiler/src/Optimize/Port.hs+4−4 compiler/src/Reporting/Render/Type.hs+9−7 compiler/src/Type/Instantiate.hs+6−1 compiler/src/Type/Solve.hs+6−1 compiler/src/Type/Type.hs+7−1

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

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

1515 , Annotation(..)

1616 , Type(..)

1717 , AliasType(..)

18+ , FieldType(..)

19+ , fieldsToList

1820 -- modules

1921 , Module(..)

2022 , Alias(..)

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

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

5456import Data.Binary

5557import qualified Data.ByteString as B

58+import qualified Data.List as List

5659import qualified Data.Map as Map

5760import Data.Text (Text)

5861

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

188191 = TLambda Type Type

189192 | TVar N.Name

190193 | 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)

192195 | TUnit

193196 | TTuple Type Type (Maybe Type)

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

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

199202 | Filled Type

200203

201204

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+

202225

203226-- MODULES

204227

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

216239 }

217240

218241

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

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

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

221244

222245

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

297320

298321

299322instance Binary Alias where

300− get = liftM3 Alias get get get

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

323+ get = liftM2 Alias get get

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

302325

303326

304327instance Binary Union where

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

376399 0 -> liftM Holey get

377400 1 -> liftM Filled get

378401 _ -> 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

1111

1212import qualified Data.Map as Map

1313

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

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

1515import qualified Elm.Name as N

1616

1717

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

5555 Map.findWithDefault tipe x typeTable

5656

5757 TRecord fields ext ->

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

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

5959

6060 TAlias home name args t' ->

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

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

7373 (fmap (dealiasHelp typeTable) maybeC)

7474

7575

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

77+dealiasField typeTable (FieldType index tipe) =

78+ FieldType index (dealiasHelp typeTable tipe)

79+

80+

7681

7782-- DEEP DEALIAS

7883

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

8792 tipe

8893

8994 TRecord fields ext ->

90− TRecord (Map.map deepDealias fields) ext

95+ TRecord (Map.map deepDealiasField fields) ext

9196

9297 TAlias _ _ args tipe' ->

9398 deepDealias (dealias args tipe')

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

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

103108

104109

110+deepDealiasField :: FieldType -> FieldType

111+deepDealiasField (FieldType index tipe) =

112+ FieldType index (deepDealias tipe)

113+

114+

105115

106116-- ITERATED DEALIAS

107117

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

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

202202 Left (tipe, Error.ExtendedRecord)

203203

204204 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

206211

207212

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

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

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

153153

154154

155155aliasToTypeHelp :: 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) =

157157 (

158158 Env.Alias (length vars) home vars tipe

159159 ,

160− case maybeRecordFields of

161− Nothing ->

162− Map.empty

163−

164− Just fields ->

160+ case tipe of

161+ Can.TRecord fields Nothing ->

165162 let

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

167164 alias =

168165 foldr

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

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

171− fields

168+ (Can.fieldsToList fields)

172169 in

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

171+

172+ _ ->

173+ Map.empty

174174 )

175175

176176

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

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

66 where

9−import Control.Arrow (first)

109import Control.Monad (foldM)

1110import qualified Data.Graph as Graph

1211import qualified Data.List as List

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

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

296295 case tipe of

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

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

297+ do cfields <- canonicalizeFields env fields

299298 fieldDict <- Dups.checkFields cfields

300299

301− let recordType = Can.TRecord fieldDict Nothing

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

303− let 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

300+ let

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

302+ recordType = Can.TRecord fieldDict Nothing

303+ vars = map A.toValue args

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

306305

307306 Result.ok

308− ( (name, alias)

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

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

310309 )

311310

312311 _ ->

313312 do ctipe <- Type.canonicalize env tipe

314313 Result.ok

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

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

316315 , Dups.none

317316 )

318317

319318

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+

320332

321333-- CANONICALIZE UNION

322334

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

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

6363 <*> canonicalize env b

6464

6565 Src.TRecord fields ext ->

66− do fieldDict <- Dups.checkFields fields

67− cfields <- traverse (canonicalize env) fieldDict

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

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

6968

7069 Src.TUnit ->

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

8685 Result.throw $ Error.TupleLargerThanThree typeRegion

8786

8887

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+

8998

9099-- CANONICALIZE TYPE

91100

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

129138 List.foldl' addFreeVars freeVars args

130139

131140 Can.TRecord fields Nothing ->

132− Map.foldl addFreeVars freeVars fields

141+ Map.foldl addFieldFreeVars freeVars fields

133142

134143 Can.TRecord fields (Just ext) ->

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

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

136145

137146 Can.TUnit ->

138147 freeVars

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

147156

148157 Can.TAlias _ _ args _ ->

149158 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

1010

1111

1212import Data.Map ((!))

13−import qualified Data.Map as Map

1413import qualified Data.Maybe as Maybe

1514import qualified Data.Set as Set

1615

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

5352 <*> traverse extract args

5453

5554 Can.TRecord fields ext ->

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

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

5756 pure (T.Record efields ext)

5857

5958 Can.TUnit ->

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

123122extractAlias interfaces (Opt.Global home name) =

124123 let

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

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

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

127126 in

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

129128

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) =

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

454454

455455 Can.ExportAlias ->

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

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

457457 comment <- getComment region name info

458458

459459 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 =

9090

9191

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

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

94− case maybeFields of

95− Nothing ->

96− graph

97−

98− Just fields ->

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

94+ case tipe of

95+ Can.TRecord fields Nothing ->

9996 let

10097 function =

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

102− Map.fromList $ map toPair fields

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

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

103100

104101 node =

105102 Opt.Define function Set.empty

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

107104 Opt.Graph

108105 mains

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

110− (foldr addRecordCtorField fieldCounts fields)

111−

107+ (Map.foldrWithKey addRecordCtorField fieldCounts fields)

112108

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

114−toPair (field, _) =

115− ( field, Opt.VarLocal field )

109+ _ ->

110+ graph

116111

117112

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

119−addRecordCtorField (name, _) fields =

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

114+addRecordCtorField name _ fields =

120115 Map.insertWith (+) name 1 fields

121116

122117

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

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

6565

6666 Can.TRecord fields Nothing ->

6767 let

68− encodeField (name, fieldType) =

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

6969 do encoder <- toEncoder fieldType

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

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

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

283283-- DECODE RECORDS

284284

285285

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

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

287287decodeRecord fields =

288288 let

289289 toFieldExpr name _ =

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

297297 Names.registerFieldDict fields (Map.toList fields)

298298

299299

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

301−fieldAndThen decoder (key, tipe) =

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

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

302302 do andThen <- decode "andThen"

303303 field <- decode "field"

304304 typeDecoder <- toDecoder tipe

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

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

141141

142142 Src.TRecord fields ext ->

143143 record

144− (map fieldToDocs fields)

144+ (map srcFieldToDocs fields)

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

146146

147147 Src.TUnit ->

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

154154 (map (srcToDoc None) cs)

155155

156156

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

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

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

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

159159 ( D.fromName fieldName

160160 , srcToDoc None fieldType

161161 )

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

200200

201201 Can.TRecord fields ext ->

202202 record

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

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

204204 (fmap D.fromName ext)

205205

206206 Can.TUnit ->

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

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

219219

220220

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

222−entryToDocs localizer (name, tipe) =

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

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

222+canFieldToDoc localizer (name, tipe) =

223+ ( D.fromName name

224+ , canToDoc localizer None tipe

225+ )

224226

225227

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

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

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

6262

6363 Can.TRecord fields maybeExt ->

6464 RecordN

65− <$> traverse (fromSrcType freeVars) fields

65+ <$> traverse (fromSrcFieldType freeVars) fields

6666 <*>

6767 case maybeExt of

6868 Nothing ->

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

7070

7171 Just ext ->

7272 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 =

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

527527

528528 Can.TRecord fields maybeExt ->

529− do fieldVars <- traverse go fields

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

530530 extVar <-

531531 case maybeExt of

532532 Nothing -> register rank pools emptyRecord1

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

555555 register rank pools (Alias home name argVars aliasVar)

556556

557557

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+

558563

559564-- COPY

560565

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

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

400400 return $ Can.TRecord Map.empty Nothing

401401

402402 Record1 fields extension ->

403− do canFields <- traverse variableToCanType fields

403+ do canFields <- traverse fieldToCanType fields

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

405405 return $

406406 case canExt of

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

423423 <*> traverse variableToCanType maybeC

424424

425425

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

427+fieldToCanType variable =

428+ do tipe <- variableToCanType variable

429+ return (Can.FieldType 0 tipe)

430+

431+

426432

427433-- TO ERROR TYPE

428434