32c78ef · elk · git.iko.soy

git.iko.soy/elk

on master help sign in

Begin process of allowing "deriving" on type aliases.

32c78efEvan Czaplicki13 years ago

compiler/Parse/Declaration.hs+22−18

compare with master

unifiedsplit

@@ -11,16 +11,16 @@ import Parse.Helpers

11import qualified Parse.Expression as Expr

12import qualified SourceSyntax.Type as T

13import qualified Parse.Type as Type

14−import SourceSyntax.Declaration (Declaration(..), Assoc(..))

14+import qualified SourceSyntax.Declaration as D

17−declaration :: IParser (Declaration t v)

17+declaration :: IParser (D.Declaration t v)

18declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition

20−definition :: IParser (Declaration t v)

20+definition :: IParser (D.Declaration t v)

21−definition = Definition <$> Expr.def

21+definition = D.Definition <$> Expr.def

23−alias :: IParser (Declaration t v)

23+alias :: IParser (D.Declaration t v)

24alias = do

25 reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"

26 forcedWS

@@ -28,9 +28,13 @@ alias = do

28 args <- spacePrefix lowVar

29 padded equals

30 tipe <- Type.expr

31+ json <- option [] $ do

32+ padded (reserved "deriving")

33+ string "Json"

34+ return [D.Json]

31− return (TypeAlias alias args tipe)

35+ return (D.TypeAlias alias args tipe json)

33−datatype :: IParser (Declaration t v)

37+datatype :: IParser (D.Declaration t v)

34datatype = do

38datatype = do

35 reserved "data" <?> "datatype definition (data T = A | B | ...)"

39 reserved "data" <?> "datatype definition (data T = A | B | ...)"

36 forcedWS

40 forcedWS

@@ -38,27 +42,27 @@ datatype = do

38 args <- spacePrefix lowVar

42 args <- spacePrefix lowVar

39 padded equals

43 padded equals

40 tcs <- pipeSep1 Type.constructor

44 tcs <- pipeSep1 Type.constructor

41− return $ Datatype name args tcs

45+ return $ D.Datatype name args tcs

44−infixDecl :: IParser (Declaration t v)

48+infixDecl :: IParser (D.Declaration t v)

45infixDecl = do

49infixDecl = do

46− assoc <- choice [ reserved "infixl" >> return L

50+ assoc <- choice [ reserved "infixl" >> return D.L

47− , reserved "infix" >> return N

51+ , reserved "infix" >> return D.N

48− , reserved "infixr" >> return R ]

52+ , reserved "infixr" >> return D.R ]

49 forcedWS

53 forcedWS

50 n <- digit

54 n <- digit

51 forcedWS

55 forcedWS

52− Fixity assoc (read [n]) <$> anyOp

56+ D.Fixity assoc (read [n]) <$> anyOp

55−foreignDef :: IParser (Declaration t v)

59+foreignDef :: IParser (D.Declaration t v)

56foreignDef = do

60foreignDef = do

57 try (reserved "foreign")

61 try (reserved "foreign")

58 whitespace

62 whitespace

59 importEvent <|> exportEvent

63 importEvent <|> exportEvent

61−exportEvent :: IParser (Declaration t v)

65+exportEvent :: IParser (D.Declaration t v)

62exportEvent = do

66exportEvent = do

63 try (reserved "export") >> padded (reserved "jsevent")

67 try (reserved "export") >> padded (reserved "jsevent")

64 eventName <- jsVar

68 eventName <- jsVar

@@ -69,11 +73,11 @@ exportEvent = do

69 case tipe of

73 case tipe of

70 T.Data "Signal" [t] ->

74 T.Data "Signal" [t] ->

71 case isExportable t of

75 case isExportable t of

72− Nothing -> return (ExportEvent eventName elmVar tipe)

76+ Nothing -> return (D.ExportEvent eventName elmVar tipe)

73 Just err -> fail err

77 Just err -> fail err

74 _ -> fail "When importing foreign events, the imported value must have type Signal."

78 _ -> fail "When importing foreign events, the imported value must have type Signal."

76−importEvent :: IParser (Declaration t v)

80+importEvent :: IParser (D.Declaration t v)

77importEvent = do

81importEvent = do

78 try (reserved "import") >> padded (reserved "jsevent")

82 try (reserved "import") >> padded (reserved "jsevent")

79 eventName <- jsVar

83 eventName <- jsVar

@@ -85,7 +89,7 @@ importEvent = do

85 case tipe of

89 case tipe of

86 T.Data "Signal" [t] ->

90 T.Data "Signal" [t] ->

87 case isExportable t of

91 case isExportable t of

88− Nothing -> return (ImportEvent eventName baseValue elmVar tipe)

92+ Nothing -> return (D.ImportEvent eventName baseValue elmVar tipe)

89 Just err -> fail err

93 Just err -> fail err

90 _ -> fail "When importing foreign events, the imported value must have type Signal."

94 _ -> fail "When importing foreign events, the imported value must have type Signal."

compiler/SourceSyntax/Declaration.hs+15−5

@@ -8,14 +8,17 @@ import Text.PrettyPrint as P

8data Declaration tipe var

9 = Definition (Expr.Def tipe var)

10 | Datatype String [String] [(String,[Type])]

11− | TypeAlias String [String] Type

11+ | TypeAlias String [String] Type [Deriveable]

12 | ImportEvent String (Expr.LExpr tipe var) String Type

13 | ExportEvent String String Type

14 | Fixity Assoc Int String

15 deriving (Eq, Show)

17data Assoc = L | N | R

18− deriving (Eq)

18+ deriving (Eq)

19+

20+data Deriveable = Json | Binary | RecordConstructor

21+ deriving (Eq, Show)

20instance Show Assoc where

23instance Show Assoc where

21 show assoc =

24 show assoc =

@@ -37,9 +40,16 @@ instance Pretty (Declaration t v) where

37 prettyCtor (name, tipes) =

40 prettyCtor (name, tipes) =

38 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

41 P.hang (P.text name) 2 (P.sep (map prettyParens tipes))

40− TypeAlias name tvars tipe ->

43+ TypeAlias name tvars tipe deriveables ->

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)

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)

44 -- TODO: Actually write out the contained data in these cases.

54 -- TODO: Actually write out the contained data in these cases.

45 ImportEvent _ _ _ _ -> P.text (show decl)

55 ImportEvent _ _ _ _ -> P.text (show decl)

compiler/Transform/Check.hs+35−15

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

1module Transform.Check (mistakes) where

3import Transform.SortDefinitions (boundVars)

4−import SourceSyntax.Declaration (Declaration(..))

4+import qualified SourceSyntax.Declaration as D

5import SourceSyntax.Expression

6import SourceSyntax.Pattern

7import SourceSyntax.Location

@@ -14,19 +14,20 @@ import qualified Data.Set as Set

14import Text.PrettyPrint as P

17−mistakes :: [Declaration t v] -> [Doc]

17+mistakes :: [D.Declaration t v] -> [Doc]

18mistakes decls =

19 concat [ infiniteTypeAliases decls

20 , illFormedTypes decls

21 , map P.text (duplicateConstructors decls)

22− , map P.text (concatMap findErrors (getLets decls)) ]

22+ , map P.text (concatMap findErrors (getLets decls))

23+ , badDerivations decls ]

23 where

24 where

24 findErrors defs = duplicates defs ++ badOrder defs

25 findErrors defs = duplicates defs ++ badOrder defs

26−getLets :: [Declaration t v] -> [[Def t v]]

27+getLets :: [D.Declaration t v] -> [[Def t v]]

27getLets decls = defs : concatMap defLets defs

28getLets decls = defs : concatMap defLets defs

28 where

29 where

29− defs = [ d | Definition d <- decls ]

30+ defs = [ d | D.Definition d <- decls ]

31 defLets def =

32 defLets def =

32 case def of

33 case def of

@@ -69,13 +70,13 @@ duplicates defs =

69 defMsg = dupErr "definition of"

70 defMsg = dupErr "definition of"

70 annMsg = dupErr "type annotation for"

71 annMsg = dupErr "type annotation for"

72−duplicateConstructors :: [Declaration t v] -> [String]

73+duplicateConstructors :: [D.Declaration t v] -> [String]

73duplicateConstructors decls =

74duplicateConstructors decls =

74 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)

75 where

76 where

76− typeCtors = List.sort [ name | Datatype name _ _ <- decls ]

77+ typeCtors = List.sort [ name | D.Datatype name _ _ <- decls ]

77 dataCtors = List.sort . concat $

78 dataCtors = List.sort . concat $

78− [ map fst patterns | Datatype _ _ patterns <- decls ]

79+ [ map fst patterns | D.Datatype _ _ patterns <- decls ]

79 dataMsg = dupErr "definition of data constructor"

80 dataMsg = dupErr "definition of data constructor"

80 typeMsg = dupErr "definition of type constructor"

81 typeMsg = dupErr "definition of type constructor"

@@ -96,11 +97,30 @@ badOrder defs = go defs

97 _ -> []

98 _ -> []

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+

99−illFormedTypes :: [Declaration t v] -> [Doc]

119+illFormedTypes :: [D.Declaration t v] -> [Doc]

100illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

120illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

101 where

121 where

102− aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]

122+ aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]

103− adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]

123+ adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]

104

124

105 freeVars tipe =

125 freeVars tipe =

106 case tipe of

126 case tipe of

@@ -141,9 +161,9 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))

141 quote tvar = "'" ++ tvar ++ "'"

161 quote tvar = "'" ++ tvar ++ "'"

142

162

143

163

144−infiniteTypeAliases :: [Declaration t v] -> [Doc]

164+infiniteTypeAliases :: [D.Declaration t v] -> [Doc]

145infiniteTypeAliases decls =

165infiniteTypeAliases decls =

146− [ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]

166+ [ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]

147 where

167 where

148 isInfinite name tipe =

168 isInfinite name tipe =

149 let infinite = isInfinite name in

169 let infinite = isInfinite name in

@@ -154,11 +174,11 @@ infiniteTypeAliases decls =

154 T.EmptyRecord -> False

174 T.EmptyRecord -> False

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

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

156

176

157− report decl@(TypeAlias name args tipe) =

177+ report decl@(D.TypeAlias name args tipe _) =

158 P.vcat [ P.text $ eightyCharLines 0 msg1

178 P.vcat [ P.text $ eightyCharLines 0 msg1

159 , indented decl

179 , indented decl

160 , P.text $ eightyCharLines 0 msg2

180 , P.text $ eightyCharLines 0 msg2

161− , indented (Datatype name args [(name,[tipe])])

181+ , indented (D.Datatype name args [(name,[tipe])])

162 , P.text $ eightyCharLines 0 msg3 ++ "\n"

182 , P.text $ eightyCharLines 0 msg3 ++ "\n"

163 ]

183 ]

164 where

184 where