git.iko.soy/elk
on master help sign in
Begin process of allowing "deriving" on type aliases.
commit32c78efe7d9598665dc8044b2ed92aec6d2d69d5 authorEvan Czaplicki <info@elm-lang.org> dateMon 23 Dec 2013, 14:42 (13 years ago) parent171f199
3 files changed+72−38
compare with master
unifiedsplit
compiler/Parse/Declaration.hs+22−18 compiler/SourceSyntax/Declaration.hs+15−5 compiler/Transform/Check.hs+35−15
compiler/Parse/Declaration.hs+22−18
@@ -11,16 +11,16 @@ import Parse.Helpers
1111import qualified Parse.Expression as Expr
1212import qualified SourceSyntax.Type as T
1313import qualified Parse.Type as Type
14−import SourceSyntax.Declaration (Declaration(..), Assoc(..))
14+import qualified SourceSyntax.Declaration as D
1515
1616
17−declaration :: IParser (Declaration t v)
17+declaration :: IParser (D.Declaration t v)
1818declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition
1919
20−definition :: IParser (Declaration t v)
21−definition = Definition <$> Expr.def
20+definition :: IParser (D.Declaration t v)
21+definition = D.Definition <$> Expr.def
2222
23−alias :: IParser (Declaration t v)
23+alias :: IParser (D.Declaration t v)
2424alias = do
2525 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
2626 forcedWS
@@ -28,9 +28,13 @@ alias = do
2828 args <- spacePrefix lowVar
2929 padded equals
3030 tipe <- Type.expr
31− return (TypeAlias alias args tipe)
31+ json <- option [] $ do
32+ padded (reserved "deriving")
33+ string "Json"
34+ return [D.Json]
35+ return (D.TypeAlias alias args tipe json)
3236
33−datatype :: IParser (Declaration t v)
37+datatype :: IParser (D.Declaration t v)
3438datatype = do
3539 reserved "data" <?> "datatype definition (data T = A | B | ...)"
3640 forcedWS
@@ -38,27 +42,27 @@ datatype = do
3842 args <- spacePrefix lowVar
3943 padded equals
4044 tcs <- pipeSep1 Type.constructor
41− return $ Datatype name args tcs
45+ return $ D.Datatype name args tcs
4246
4347
44−infixDecl :: IParser (Declaration t v)
48+infixDecl :: IParser (D.Declaration t v)
4549infixDecl = do
46− assoc <- choice [ reserved "infixl" >> return L
47− , reserved "infix" >> return N
48− , reserved "infixr" >> return R ]
50+ assoc <- choice [ reserved "infixl" >> return D.L
51+ , reserved "infix" >> return D.N
52+ , reserved "infixr" >> return D.R ]
4953 forcedWS
5054 n <- digit
5155 forcedWS
52− Fixity assoc (read [n]) <$> anyOp
56+ D.Fixity assoc (read [n]) <$> anyOp
5357
5458
55−foreignDef :: IParser (Declaration t v)
59+foreignDef :: IParser (D.Declaration t v)
5660foreignDef = do
5761 try (reserved "foreign")
5862 whitespace
5963 importEvent <|> exportEvent
6064
61−exportEvent :: IParser (Declaration t v)
65+exportEvent :: IParser (D.Declaration t v)
6266exportEvent = do
6367 try (reserved "export") >> padded (reserved "jsevent")
6468 eventName <- jsVar
@@ -69,11 +73,11 @@ exportEvent = do
6973 case tipe of
7074 T.Data "Signal" [t] ->
7175 case isExportable t of
72− Nothing -> return (ExportEvent eventName elmVar tipe)
76+ Nothing -> return (D.ExportEvent eventName elmVar tipe)
7377 Just err -> fail err
7478 _ -> fail "When importing foreign events, the imported value must have type Signal."
7579
76−importEvent :: IParser (Declaration t v)
80+importEvent :: IParser (D.Declaration t v)
7781importEvent = do
7882 try (reserved "import") >> padded (reserved "jsevent")
7983 eventName <- jsVar
@@ -85,7 +89,7 @@ importEvent = do
8589 case tipe of
8690 T.Data "Signal" [t] ->
8791 case isExportable t of
88− Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
92+ Nothing -> return (D.ImportEvent eventName baseValue elmVar tipe)
8993 Just err -> fail err
9094 _ -> fail "When importing foreign events, the imported value must have type Signal."
9195
compiler/SourceSyntax/Declaration.hs+15−5
@@ -8,14 +8,17 @@ import Text.PrettyPrint as P
88data Declaration tipe var
99 = Definition (Expr.Def tipe var)
1010 | Datatype String [String] [(String,[Type])]
11− | TypeAlias String [String] Type
11+ | TypeAlias String [String] Type [Deriveable]
1212 | ImportEvent String (Expr.LExpr tipe var) String Type
1313 | ExportEvent String String Type
1414 | Fixity Assoc Int String
1515 deriving (Eq, Show)
1616
1717data Assoc = L | N | R
18− deriving (Eq)
18+ deriving (Eq)
19+
20+data Deriveable = Json | Binary | RecordConstructor
21+ deriving (Eq, Show)
1922
2023instance Show Assoc where
2124 show assoc =
@@ -37,9 +40,16 @@ instance Pretty (Declaration t v) where
3740 prettyCtor (name, tipes) =
3841 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))
3942
40− TypeAlias name tvars tipe ->
41− let alias = P.text name <+> P.hsep (map P.text tvars) in
42− P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)
43+ TypeAlias name tvars tipe deriveables ->
44+ P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe) <+> deriving'
45+ where
46+ alias = P.text name <+> P.hsep (map P.text tvars)
47+ deriving' =
48+ case deriveables of
49+ [] -> P.empty
50+ [d] -> P.text "deriving" <+> P.text (show d)
51+ ds -> P.text "deriving" <+>
52+ P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)
4353
4454 -- TODO: Actually write out the contained data in these cases.
4555 ImportEvent _ _ _ _ -> P.text (show decl)
compiler/Transform/Check.hs+35−15
@@ -1,7 +1,7 @@
11module Transform.Check (mistakes) where
22
33import Transform.SortDefinitions (boundVars)
4−import SourceSyntax.Declaration (Declaration(..))
4+import qualified SourceSyntax.Declaration as D
55import SourceSyntax.Expression
66import SourceSyntax.Pattern
77import SourceSyntax.Location
@@ -14,19 +14,20 @@ import qualified Data.Set as Set
1414import Text.PrettyPrint as P
1515
1616
17−mistakes :: [Declaration t v] -> [Doc]
17+mistakes :: [D.Declaration t v] -> [Doc]
1818mistakes decls =
1919 concat [ infiniteTypeAliases decls
2020 , illFormedTypes decls
2121 , map P.text (duplicateConstructors decls)
22− , map P.text (concatMap findErrors (getLets decls)) ]
22+ , map P.text (concatMap findErrors (getLets decls))
23+ , badDerivations decls ]
2324 where
2425 findErrors defs = duplicates defs ++ badOrder defs
2526
26−getLets :: [Declaration t v] -> [[Def t v]]
27+getLets :: [D.Declaration t v] -> [[Def t v]]
2728getLets decls = defs : concatMap defLets defs
2829 where
29− defs = [ d | Definition d <- decls ]
30+ defs = [ d | D.Definition d <- decls ]
3031
3132 defLets def =
3233 case def of
@@ -69,13 +70,13 @@ duplicates defs =
6970 defMsg = dupErr "definition of"
7071 annMsg = dupErr "type annotation for"
7172
72−duplicateConstructors :: [Declaration t v] -> [String]
73+duplicateConstructors :: [D.Declaration t v] -> [String]
7374duplicateConstructors decls =
7475 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
7576 where
76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
77+ typeCtors = List.sort [ name | D.Datatype name _ _ <- decls ]
7778 dataCtors = List.sort . concat $
78− [ map fst patterns | Datatype _ _ patterns <- decls ]
79+ [ map fst patterns | D.Datatype _ _ patterns <- decls ]
7980 dataMsg = dupErr "definition of data constructor"
8081 typeMsg = dupErr "definition of type constructor"
8182
@@ -96,11 +97,30 @@ badOrder defs = go defs
9697
9798 _ -> []
9899
99−illFormedTypes :: [Declaration t v] -> [Doc]
100+badDerivations :: [D.Declaration t v] -> [Doc]
101+badDerivations decls = concatMap badDerivation derivations
102+ where
103+ derivations =
104+ [ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ]
105+ badDerivation (decl, tvars, derives) =
106+ case (tvars, derives) of
107+ (_:_, _)
108+ | D.Json `elem` derives -> [report decl D.Json]
109+ | D.Binary `elem` derives -> [report decl D.Binary]
110+ _ -> []
111+
112+ report decl derive =
113+ P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
114+ , P.text "Make sure all type variables are replaced with concrete types:"
115+ , P.text "\n"
116+ , nest 4 (pretty decl)
117+ ]
118+
119+illFormedTypes :: [D.Declaration t v] -> [Doc]
100120illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
101121 where
102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
122+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
123+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
104124
105125 freeVars tipe =
106126 case tipe of
@@ -141,9 +161,9 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
141161 quote tvar = "'" ++ tvar ++ "'"
142162
143163
144−infiniteTypeAliases :: [Declaration t v] -> [Doc]
164+infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
145165infiniteTypeAliases decls =
146− [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
166+ [ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]
147167 where
148168 isInfinite name tipe =
149169 let infinite = isInfinite name in
@@ -154,11 +174,11 @@ infiniteTypeAliases decls =
154174 T.EmptyRecord -> False
155175 T.Record fields ext -> infinite ext || any (infinite . snd) fields
156176
157− report decl@(TypeAlias name args tipe) =
177+ report decl@(D.TypeAlias name args tipe _) =
158178 P.vcat [ P.text $ eightyCharLines 0 msg1
159179 , indented decl
160180 , P.text $ eightyCharLines 0 msg2
161− , indented (Datatype name args [(name,[tipe])])
181+ , indented (D.Datatype name args [(name,[tipe])])
162182 , P.text $ eightyCharLines 0 msg3 ++ "\n"
163183 ]
164184 where