2a0a0e6 · elk · git.iko.soy

git.iko.soy/elk

Simplify SourceSyntax.Type AST, making record extension more restrictive as discussed with @maxsnew

commit2a0a0e6e3cb5da90cb8caf8bcb074f74a48770b4 authorEvan Czaplicki <info@elm-lang.org> dateMon 13 Jan 2014, 09:23 (13 years ago) parent9dda928

10 files changed+54−67

compare with master

unifiedsplit

compiler/Docs.hs+3−4 compiler/Parse/Type.hs+7−7 compiler/SourceSyntax/Type.hs+8−21 compiler/Transform/Canonicalize.hs+1−2 compiler/Transform/Check.hs+3−4 compiler/Type/Alias.hs+14−14 compiler/Type/Constrain/Declaration.hs+3−5 compiler/Type/Environment.hs+6−4 compiler/Type/ExtraChecks.hs−1 compiler/Type/Type.hs+9−5

compiler/Docs.hs+3−4

@@ -7,7 +7,7 @@ import System.FilePath

77import System.Exit

88import System.IO

10−import Control.Applicative ((<$>), (<*>))

10+import Control.Applicative ((<$>))

1111import Data.Aeson

1212import Data.Aeson.Encode.Pretty

1313import qualified Data.List as List

@@ -154,11 +154,10 @@ instance ToJSON Type where

154154 Lambda t1 t2 -> toJSON [ "->", toJSON t1, toJSON t2 ]

155155 Var x -> toJSON x

156156 Data name ts -> toJSON (toJSON name : map toJSON ts)

157− EmptyRecord -> object []

158157 Record fields ext -> object $ map (\(n,t) -> Text.pack n .= toJSON t) fields'

159158 where fields' = case ext of

160− EmptyRecord -> fields

161− _ -> ("_",ext) : fields

159+ Nothing -> fields

160+ Just x -> ("_", Var x) : fields

162161

163162ctorToJson tipe (ctor, tipes) =

164163 object [ "name" .= ctor

compiler/Parse/Type.hs+7−7

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

11{-# OPTIONS_GHC -Wall -fno-warn-unused-do-bind #-}

22module Parse.Type where

4−import Control.Applicative ((<$>),(<*>))

4+import Control.Applicative ((<$>),(<*>),(<*))

55import Data.List (intercalate)

66import Text.Parsec

@@ -23,19 +23,19 @@ tuple = do ts <- parens (commaSep expr)

2323record :: IParser T.Type

2424record =

2525 do char '{' ; whitespace

26− (ext,fs) <- extended <|> normal

26+ rcrd <- extended <|> normal

2727 dumbWhitespace ; char '}'

28− return (T.Record fs ext)

28+ return rcrd

2929 where

30− normal = (,) T.EmptyRecord <$> commaSep fields

30+ normal = flip T.Record Nothing <$> commaSep field

3131

3232 -- extended record types require at least one field

3333 extended = do

34− ext <- try (const <$> tvar <*> (whitespace >> string "|"))

34+ ext <- try (lowVar <* (whitespace >> string "|"))

3535 whitespace

36− (,) ext <$> commaSep1 fields

36+ flip T.Record (Just ext) <$> commaSep1 field

3737

38− fields = do

38+ field = do

3939 lbl <- rLabel

4040 whitespace >> hasType >> whitespace

4141 (,) lbl <$> expr

compiler/SourceSyntax/Type.hs+8−21

@@ -11,8 +11,7 @@ import Text.PrettyPrint as P

1111data Type = Lambda Type Type

1212 | Var String

1313 | Data String [Type]

14− | EmptyRecord

15− | Record [(String,Type)] Type

14+ | Record [(String,Type)] (Maybe String)

1615 deriving (Eq, Show)

1716

1817fieldMap :: [(String,a)] -> Map.Map String [a]

@@ -20,7 +19,7 @@ fieldMap fields =

2019 foldl (\r (x,t) -> Map.insertWith (++) x [t] r) Map.empty fields

2120

2221recordOf :: [(String,Type)] -> Type

23−recordOf fields = Record fields EmptyRecord

22+recordOf fields = Record fields Nothing

2423

2524listOf :: Type -> Type

2625listOf t = Data "_List" [t]

@@ -39,12 +38,11 @@ instance Pretty Type where

3938 Data name tipes

4039 | Help.isTuple name -> P.parens . P.sep . P.punctuate P.comma $ map pretty tipes

4140 | otherwise -> P.hang (P.text name) 2 (P.sep $ map prettyParens tipes)

42− EmptyRecord -> P.braces P.empty

43− Record _ _ -> P.braces $ case ext of

44− EmptyRecord -> prettyFields

45− _ -> P.hang (pretty ext <+> P.text "|") 4 prettyFields

41+ Record fields ext ->

42+ P.braces $ case ext of

43+ Nothing -> prettyFields

44+ Just x -> P.hang (P.text x <+> P.text "|") 4 prettyFields

4645 where

47− (fields, ext) = collectRecords tipe

4846 prettyField (f,t) = P.text f <+> P.text ":" <+> pretty t

4947 prettyFields = commaSep . map prettyField $ fields

5048

@@ -55,14 +53,6 @@ collectLambdas tipe =

5553 Lambda arg body -> pretty arg : collectLambdas body

5654 _ -> [pretty tipe]

5755

58−collectRecords :: Type -> ([(String,Type)], Type)

59−collectRecords = go []

60− where

61− go fields tipe =

62− case tipe of

63− Record fs ext -> go (fs ++ fields) ext

64− _ -> (fields, tipe)

65−

6656prettyParens :: Type -> Doc

6757prettyParens tipe = parensIf needed (pretty tipe)

6858 where

@@ -83,10 +73,8 @@ instance Binary Type where

8373 putWord8 1 >> put x

8474 Data ctor tipes ->

8575 putWord8 2 >> put ctor >> put tipes

86− EmptyRecord ->

87− putWord8 3

8876 Record fs ext ->

89− putWord8 4 >> put fs >> put ext

77+ putWord8 3 >> put fs >> put ext

9078

9179 get = do

9280 n <- getWord8

@@ -94,6 +82,5 @@ instance Binary Type where

9482 0 -> Lambda <$> get <*> get

9583 1 -> Var <$> get

9684 2 -> Data <$> get <*> get

97− 3 -> return EmptyRecord

98− 4 -> Record <$> get <*> get

85+ 3 -> Record <$> get <*> get

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

compiler/Transform/Canonicalize.hs+1−2

@@ -47,8 +47,7 @@ renameType renamer tipe =

4747 Type.Lambda a b -> Type.Lambda <$> rnm a <*> rnm b

4848 Type.Var _ -> return tipe

4949 Type.Data name ts -> Type.Data <$> renamer name <*> mapM rnm ts

50− Type.EmptyRecord -> return tipe

51− Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> rnm ext

50+ Type.Record fields ext -> Type.Record <$> mapM rnm' fields <*> return ext

5251 where rnm' (f,t) = (,) f <$> rnm t

5352

5453metadataModule :: Interfaces -> MetadataModule -> Either [Doc] MetadataModule

compiler/Transform/Check.hs+3−4

@@ -102,8 +102,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

102102 T.Lambda t1 t2 -> Set.union (freeVars t1) (freeVars t2)

103103 T.Var x -> Set.singleton x

104104 T.Data _ ts -> Set.unions (map freeVars ts)

105− T.EmptyRecord -> Set.empty

106− T.Record fields ext -> Set.unions (freeVars ext : map (freeVars . snd) fields)

105+ T.Record fields ext -> Set.unions (ext' : map (freeVars . snd) fields)

106+ where ext' = maybe Set.empty Set.singleton ext

107107

108108 undeclared tvars tipes = Set.difference used declared

109109 where

@@ -147,8 +147,7 @@ infiniteTypeAliases decls =

147147 T.Lambda a b -> infinite a || infinite b

148148 T.Var _ -> False

149149 T.Data name' ts -> name == name' || any infinite ts

150− T.EmptyRecord -> False

151− T.Record fields ext -> infinite ext || any (infinite . snd) fields

150+ T.Record fields _ -> any (infinite . snd) fields

152151

153152 indented :: D.Declaration -> Doc

154153 indented decl = P.text "\n " <> pretty decl <> P.text "\n"

compiler/Type/Alias.hs+14−14

@@ -1,3 +1,4 @@

1+{-# OPTIONS_GHC -W #-}

12module Type.Alias (realias, rules, canonicalRealias, Rules) where

34import Control.Applicative ((<$>),(<*>))

@@ -30,10 +31,9 @@ localizer moduleImports = go

3031 go tipe =

3132 case tipe of

3233 Var _ -> tipe

33− EmptyRecord -> tipe

3434 Lambda t1 t2 -> Lambda (go t1) (go t2)

3535 Data name ts -> Data (localize name) (map go ts)

36− Record fs ext -> Record (map (second go) fs) (go ext)

36+ Record fs ext -> Record (map (second go) fs) ext

3737

3838 byMethod = foldr (\(n,m) d -> Map.insertWith (++) n [m] d)

3939 Map.empty moduleImports

@@ -83,10 +83,9 @@ canonicalRealias aliases tipe =

8383 tipe' =

8484 case tipe of

8585 Var _ -> tipe

86− EmptyRecord -> tipe

8786 Lambda t1 t2 -> Lambda (f t1) (f t2)

8887 Data name ts -> Data name (map f ts)

89− Record fs ext -> Record (map (second f) fs) (f ext)

88+ Record fs ext -> Record (map (second f) fs) ext

9089

9190allEqual [] = True

9291allEqual (x:xs) = all (==x) xs

@@ -102,8 +101,7 @@ bestType tipes = fst $ List.minimumBy (\a b -> compare (snd a) (snd b)) pairs

102101 Lambda t1 t2 -> numFields t1 + numFields t2

103102 Var _ -> 0

104103 Data _ ts -> sum (map numFields ts)

105− EmptyRecord -> 0

106− Record fields ext -> length fields + sum (map (numFields . snd) fields) + numFields ext

104+ Record fields _ -> length fields + sum (map (numFields . snd) fields)

107105

108106diff :: Type -> Type -> Maybe [(String,Type)]

109107diff general specific =

@@ -113,11 +111,11 @@ diff general specific =

113111 (Data gname gts, Data sname sts)

114112 | gname == sname && length gts == length sts ->

115113 concat <$> zipWithM diff gts sts

116− (EmptyRecord, EmptyRecord) -> Just []

117− (Record _ _, Record _ _) ->

118− let (gfs,gext) = collectRecords general

119− (sfs,sext) = collectRecords specific

120− gfields = collectFields gfs

114+ (Record [] Nothing, Record [] Nothing) -> Just []

115+ (Record _ _, Record [] Nothing) -> Nothing

116+ (Record [] Nothing, Record _ _) -> Nothing

117+ (Record gfs gext, Record sfs sext) ->

118+ let gfields = collectFields gfs

121119 sfields = collectFields sfs

122120

123121 overlap = Map.intersectionWith (\gs ss -> length gs == length ss) sfields gfields

@@ -126,10 +124,12 @@ diff general specific =

126124 case isAligned of

127125 False -> Nothing

128126 True -> let remaining = Map.difference sfields gfields

129− sext' = if Map.null remaining then sext else

130− Record (flattenFields remaining) sext

127+ sext' = case sext of

128+ Just x | Map.null remaining -> Var x

129+ _ -> Record (flattenFields remaining) sext

130+ gext' = maybe (Record [] Nothing) Var gext

131131 matchMap = Map.intersectionWith (zipWith diff) gfields sfields

132− in concat <$> sequence (diff gext sext' : concat (Map.elems matchMap))

132+ in concat <$> sequence (diff gext' sext' : concat (Map.elems matchMap))

133133 (_,_) -> Nothing

134134

135135collectFields fields =

compiler/Type/Constrain/Declaration.hs+3−5

@@ -28,17 +28,15 @@ toDefs decl =

2828 TypeAlias name _ tipe@(T.Record fields ext) _ ->

2929 [ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]

3030 where

31− args = case ext of

32− T.EmptyRecord -> map snd fields

33− _ -> map snd fields ++ [ext]

31+ args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext

3432

3533 var = L.none . E.Var

3634 vars = take (length args) arguments

3735

3836 efields = zip (map fst fields) (map var vars)

3937 record = case ext of

40− T.EmptyRecord -> L.none $ E.Record efields

41− _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

38+ Nothing -> L.none $ E.Record efields

39+ Just _ -> foldl (\r (f,v) -> L.none $ E.Insert r f v) (var $ last vars) efields

4240

4341 -- Type aliases must be added to an extended equality dictionary,

4442 -- but they do not require any basic constraints.

compiler/Type/Environment.hs+6−4

@@ -162,7 +162,9 @@ instantiator env sourceType = go sourceType

162162 _ -> error $ "\nCould not find type constructor '" ++

163163 name ++ "' while checking types."

164164

165− Src.EmptyRecord -> return (TermN EmptyRecord1)

166−

167− Src.Record fields ext ->

168− TermN <$> (Record1 <$> Traverse.traverse (mapM go) (Src.fieldMap fields) <*> go ext)

165+ Src.Record fields ext -> do

166+ fields' <- Traverse.traverse (mapM go) (Src.fieldMap fields)

167+ ext' <- case ext of

168+ Nothing -> return $ TermN EmptyRecord1

169+ Just x -> go (Src.Var x)

170+ return $ TermN (Record1 fields' ext')

compiler/Type/ExtraChecks.hs−1

@@ -96,7 +96,6 @@ portTypes rules expr =

9696 | otherwise -> throw $ err msg "Elm values"

9797 T.Var _ -> throw $ err msg "type variables"

9898 T.Lambda _ _ -> throw $ err msg "Elm functions"

99− T.EmptyRecord -> throw $ err msg "Elm records"

10099 T.Record _ _ -> throw $ err msg "Elm records"

101100 where

102101 okay ctor = and [ List.isPrefixOf "JavaScript." ctor

compiler/Type/Type.hs+9−5

@@ -364,11 +364,15 @@ toSrcType variable = do

364364 return (Src.Data name (ts ++ [b']))

365365 Fun1 a b -> Src.Lambda <$> toSrcType a <*> toSrcType b

366366 Var1 a -> toSrcType a

367− EmptyRecord1 -> return Src.EmptyRecord

368− Record1 fs ext -> do

369− fs' <- traverse (mapM toSrcType) fs

370− let fs'' = concat [ map ((,) name) ts | (name,ts) <- Map.toList fs' ]

371− Src.Record fs'' <$> toSrcType ext

367+ EmptyRecord1 -> return $ Src.Record [] Nothing

368+ Record1 tfields extension -> do

369+ fields' <- traverse (mapM toSrcType) tfields

370+ let fields = concat [ map ((,) name) ts | (name,ts) <- Map.toList fields' ]

371+ ext' <- toSrcType extension

372+ return $ case ext' of

373+ Src.Record fs ext -> Src.Record (fs ++ fields) ext

374+ Src.Var x -> Src.Record fields (Just x)

375+ _ -> error "Used toSrcType on a type that is not well-formed"

372376 Nothing ->

373377 case name desc of

374378 Just x@(c:_) | Char.isLower c -> return (Src.Var x)