2a0a0e6 · elk · git.iko.soy

compiler/Docs.hs+3−4

compare with master

unifiedsplit

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

7import System.Exit

8import System.IO

9

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

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

11import Data.Aeson

12import Data.Aeson.Encode.Pretty

13import qualified Data.List as List

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

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

155 Var x -> toJSON x

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

157− EmptyRecord -> object []

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

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

159 where fields' = case ext of

158 where fields' = case ext of

160− EmptyRecord -> fields

159+ Nothing -> fields

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

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

162

161

163ctorToJson tipe (ctor, tipes) =

162ctorToJson tipe (ctor, tipes) =

164 object [ "name" .= ctor

163 object [ "name" .= ctor

compiler/Parse/Type.hs+7−7

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

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

2module Parse.Type where

3

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

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

5import Data.List (intercalate)

6import Text.Parsec

7

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

23record :: IParser T.Type

24record =

25 do char '{' ; whitespace

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

26+ rcrd <- extended <|> normal

27 dumbWhitespace ; char '}'

28− return (T.Record fs ext)

28+ return rcrd

29 where

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

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

31

32 -- extended record types require at least one field

33 extended = do

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

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

35 whitespace

36− (,) ext <$> commaSep1 fields

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

37

38− fields = do

38+ field = do

39 lbl <- rLabel

40 whitespace >> hasType >> whitespace

41 (,) lbl <$> expr

compiler/SourceSyntax/Type.hs+8−21

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

11data Type = Lambda Type Type

12 | Var String

13 | Data String [Type]

14− | EmptyRecord

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

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

16 deriving (Eq, Show)

15 deriving (Eq, Show)

17

16

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

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

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

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

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

21

20

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

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

23−recordOf fields = Record fields EmptyRecord

22+recordOf fields = Record fields Nothing

24

23

25listOf :: Type -> Type

24listOf :: Type -> Type

26listOf t = Data "_List" [t]

25listOf t = Data "_List" [t]

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

39 Data name tipes

38 Data name tipes

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

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

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

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

42− EmptyRecord -> P.braces P.empty

41+ Record fields ext ->

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

42+ P.braces $ case ext of

44− EmptyRecord -> prettyFields

43+ Nothing -> prettyFields

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

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

46 where

45 where

47− (fields, ext) = collectRecords tipe

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

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

49 prettyFields = commaSep . map prettyField $ fields

47 prettyFields = commaSep . map prettyField $ fields

50

48

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

55 Lambda arg body -> pretty arg : collectLambdas body

53 Lambda arg body -> pretty arg : collectLambdas body

56 _ -> [pretty tipe]

54 _ -> [pretty tipe]

57

55

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−

66prettyParens :: Type -> Doc

56prettyParens :: Type -> Doc

67prettyParens tipe = parensIf needed (pretty tipe)

57prettyParens tipe = parensIf needed (pretty tipe)

68 where

58 where

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

83 putWord8 1 >> put x

73 putWord8 1 >> put x

84 Data ctor tipes ->

74 Data ctor tipes ->

85 putWord8 2 >> put ctor >> put tipes

75 putWord8 2 >> put ctor >> put tipes

86− EmptyRecord ->

87− putWord8 3

88 Record fs ext ->

76 Record fs ext ->

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

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

90

78

91 get = do

79 get = do

92 n <- getWord8

80 n <- getWord8

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

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

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

95 1 -> Var <$> get

83 1 -> Var <$> get

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

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

97− 3 -> return EmptyRecord

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

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

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

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

compiler/Transform/Canonicalize.hs+1−2

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

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

48 Type.Var _ -> return tipe

49 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

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

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

53

52

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

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

compiler/Transform/Check.hs+3−4

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

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

103 T.Var x -> Set.singleton x

104 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

107

108 undeclared tvars tipes = Set.difference used declared

109 where

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

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

148 T.Var _ -> False

149 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

152

151

153 indented :: D.Declaration -> Doc

152 indented :: D.Declaration -> Doc

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

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

compiler/Type/Alias.hs+14−14

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

1+{-# OPTIONS_GHC -W #-}

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

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

2

3

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

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

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

30 go tipe =

31 go tipe =

31 case tipe of

32 case tipe of

32 Var _ -> tipe

33 Var _ -> tipe

33− EmptyRecord -> tipe

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

35 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

37

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

39 Map.empty moduleImports

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

83 tipe' =

84 case tipe of

85 Var _ -> tipe

86− EmptyRecord -> tipe

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

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

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

87 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

90

89

91allEqual [] = True

90allEqual [] = True

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

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

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

102 Lambda t1 t2 -> numFields t1 + numFields t2

101 Lambda t1 t2 -> numFields t1 + numFields t2

103 Var _ -> 0

102 Var _ -> 0

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

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

107

105

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

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

109diff general specific =

107diff general specific =

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

113 (Data gname gts, Data sname sts)

111 (Data gname gts, Data sname sts)

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

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

115 concat <$> zipWithM diff gts sts

113 concat <$> zipWithM diff gts sts

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

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

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

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

118− let (gfs,gext) = collectRecords general

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

119− (sfs,sext) = collectRecords specific

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

120− gfields = collectFields gfs

118+ let gfields = collectFields gfs

121 sfields = collectFields sfs

119 sfields = collectFields sfs

122

120

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

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

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

126 case isAligned of

124 case isAligned of

127 False -> Nothing

125 False -> Nothing

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

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

127+ sext' = case sext of

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

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

130− Record (flattenFields remaining) sext

129+ _ -> Record (flattenFields remaining) sext

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

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

133 (_,_) -> Nothing

134

135collectFields fields =

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

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

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

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

30 where

31− args = case ext of

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

32− T.EmptyRecord -> map snd fields

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

34

32

35 var = L.none . E.Var

33 var = L.none . E.Var

36 vars = take (length args) arguments

34 vars = take (length args) arguments

37

35

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

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

39 record = case ext of

37 record = case ext of

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

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

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

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

42

40

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

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

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

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

compiler/Type/Environment.hs+6−4

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

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

163 name ++ "' while checking types."

164

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

166−

167− Src.Record fields ext ->

165+ Src.Record fields ext -> do

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

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 =

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

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

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

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

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

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

101 where

100 where

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

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

compiler/Type/Type.hs+9−5

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

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

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

366 Var1 a -> toSrcType a

367− EmptyRecord1 -> return Src.EmptyRecord

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

368− Record1 fs ext -> do

368+ Record1 tfields extension -> do

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

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

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

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

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

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"

372 Nothing ->

376 Nothing ->

373 case name desc of

377 case name desc of

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

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