yogsototh/elm
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Begin process of allowing "deriving" on type aliases.

Browse source
This commit is contained in:
Evan Czaplicki 2013-12-23 14:42:43 -08:00
parent 171f199db3
commit 32c78efe7d
3 changed files with 72 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

40
compiler/Parse/Declaration.hs
View file

@ -11,16 +11,16 @@ import Parse.Helpers
import qualified Parse.Expression as Expr
import qualified SourceSyntax.Type as T
import qualified Parse.Type as Type
import SourceSyntax.Declaration (Declaration(..), Assoc(..))
import qualified SourceSyntax.Declaration as D
declaration :: IParser (Declaration t v)
declaration :: IParser (D.Declaration t v)
declaration = alias <|> datatype <|> infixDecl <|> foreignDef <|> definition
definition :: IParser (Declaration t v)
definition = Definition <$> Expr.def
definition :: IParser (D.Declaration t v)
definition = D.Definition <$> Expr.def
alias :: IParser (Declaration t v)
alias :: IParser (D.Declaration t v)
alias = do
reserved "type" <?> "type alias (type Point = {x:Int, y:Int})"
forcedWS
@ -28,9 +28,13 @@ alias = do
args <- spacePrefix lowVar
padded equals
tipe <- Type.expr
return (TypeAlias alias args tipe)
json <- option [] $ do
padded (reserved "deriving")
string "Json"
return [D.Json]
return (D.TypeAlias alias args tipe json)
datatype :: IParser (Declaration t v)
datatype :: IParser (D.Declaration t v)
datatype = do
reserved "data" <?> "datatype definition (data T = A | B | ...)"
forcedWS
@ -38,27 +42,27 @@ datatype = do
args <- spacePrefix lowVar
padded equals
tcs <- pipeSep1 Type.constructor
return $ Datatype name args tcs
return $ D.Datatype name args tcs
infixDecl :: IParser (Declaration t v)
infixDecl :: IParser (D.Declaration t v)
infixDecl = do
assoc <- choice [ reserved "infixl" >> return L
, reserved "infix" >> return N
, reserved "infixr" >> return R ]
assoc <- choice [ reserved "infixl" >> return D.L
, reserved "infix" >> return D.N
, reserved "infixr" >> return D.R ]
forcedWS
n <- digit
forcedWS
Fixity assoc (read [n]) <$> anyOp
D.Fixity assoc (read [n]) <$> anyOp
foreignDef :: IParser (Declaration t v)
foreignDef :: IParser (D.Declaration t v)
foreignDef = do
try (reserved "foreign")
whitespace
importEvent <|> exportEvent
exportEvent :: IParser (Declaration t v)
exportEvent :: IParser (D.Declaration t v)
exportEvent = do
try (reserved "export") >> padded (reserved "jsevent")
eventName <- jsVar
@ -69,11 +73,11 @@ exportEvent = do
case tipe of
T.Data "Signal" [t] ->
case isExportable t of
Nothing -> return (ExportEvent eventName elmVar tipe)
Nothing -> return (D.ExportEvent eventName elmVar tipe)
Just err -> fail err
_ -> fail "When importing foreign events, the imported value must have type Signal."
importEvent :: IParser (Declaration t v)
importEvent :: IParser (D.Declaration t v)
importEvent = do
try (reserved "import") >> padded (reserved "jsevent")
eventName <- jsVar
@ -85,7 +89,7 @@ importEvent = do
case tipe of
T.Data "Signal" [t] ->
case isExportable t of
Nothing -> return (ImportEvent eventName baseValue elmVar tipe)
Nothing -> return (D.ImportEvent eventName baseValue elmVar tipe)
Just err -> fail err
_ -> fail "When importing foreign events, the imported value must have type Signal."

18
compiler/SourceSyntax/Declaration.hs
View file

@ -8,7 +8,7 @@ import Text.PrettyPrint as P
data Declaration tipe var
= Definition (Expr.Def tipe var)
| Datatype String [String] [(String,[Type])]
| TypeAlias String [String] Type
| TypeAlias String [String] Type [Deriveable]
| ImportEvent String (Expr.LExpr tipe var) String Type
| ExportEvent String String Type
| Fixity Assoc Int String
@ -17,6 +17,9 @@ data Declaration tipe var
data Assoc = L | N | R
deriving (Eq)
data Deriveable = Json | Binary | RecordConstructor
deriving (Eq, Show)
instance Show Assoc where
show assoc =
case assoc of
@ -37,9 +40,16 @@ instance Pretty (Declaration t v) where
prettyCtor (name, tipes) =
P.hang (P.text name) 2 (P.sep (map prettyParens tipes))
TypeAlias name tvars tipe ->
let alias = P.text name <+> P.hsep (map P.text tvars) in
P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe)
TypeAlias name tvars tipe deriveables ->
P.hang (P.text "type" <+> alias <+> P.equals) 4 (pretty tipe) <+> deriving'
where
alias = P.text name <+> P.hsep (map P.text tvars)
deriving' =
case deriveables of
[] -> P.empty
[d] -> P.text "deriving" <+> P.text (show d)
ds -> P.text "deriving" <+>
P.parens (P.hsep $ P.punctuate P.comma $ map (P.text . show) ds)
-- TODO: Actually write out the contained data in these cases.
ImportEvent _ _ _ _ -> P.text (show decl)

50
compiler/Transform/Check.hs
View file

@ -1,7 +1,7 @@
module Transform.Check (mistakes) where
import Transform.SortDefinitions (boundVars)
import SourceSyntax.Declaration (Declaration(..))
import qualified SourceSyntax.Declaration as D
import SourceSyntax.Expression
import SourceSyntax.Pattern
import SourceSyntax.Location
@ -14,19 +14,20 @@ import qualified Data.Set as Set
import Text.PrettyPrint as P
mistakes :: [Declaration t v] -> [Doc]
mistakes :: [D.Declaration t v] -> [Doc]
mistakes decls =
concat [ infiniteTypeAliases decls
, illFormedTypes decls
, map P.text (duplicateConstructors decls)
, map P.text (concatMap findErrors (getLets decls)) ]
, map P.text (concatMap findErrors (getLets decls))
, badDerivations decls ]
where
findErrors defs = duplicates defs ++ badOrder defs
getLets :: [Declaration t v] -> [[Def t v]]
getLets :: [D.Declaration t v] -> [[Def t v]]
getLets decls = defs : concatMap defLets defs
where
defs = [ d | Definition d <- decls ]
defs = [ d | D.Definition d <- decls ]
defLets def =
case def of
@ -69,13 +70,13 @@ duplicates defs =
defMsg = dupErr "definition of"
annMsg = dupErr "type annotation for"
duplicateConstructors :: [Declaration t v] -> [String]
duplicateConstructors :: [D.Declaration t v] -> [String]
duplicateConstructors decls =
map typeMsg (dups typeCtors) ++ map dataMsg (dups dataCtors)
where
typeCtors = List.sort [ name | Datatype name _ _ <- decls ]
typeCtors = List.sort [ name | D.Datatype name _ _ <- decls ]
dataCtors = List.sort . concat $
[ map fst patterns | Datatype _ _ patterns <- decls ]
[ map fst patterns | D.Datatype _ _ patterns <- decls ]
dataMsg = dupErr "definition of data constructor"
typeMsg = dupErr "definition of type constructor"
@ -96,11 +97,30 @@ badOrder defs = go defs
_ -> []
illFormedTypes :: [Declaration t v] -> [Doc]
badDerivations :: [D.Declaration t v] -> [Doc]
badDerivations decls = concatMap badDerivation derivations
where
derivations =
[ (decl, tvars, derives) | decl@(D.TypeAlias name tvars _ derives) <- decls ]
badDerivation (decl, tvars, derives) =
case (tvars, derives) of
(_:_, _)
| D.Json `elem` derives -> [report decl D.Json]
| D.Binary `elem` derives -> [report decl D.Binary]
_ -> []
report decl derive =
P.vcat [ P.text $ "Error: cannot derive '" ++ show derive ++ "' from this type alias."
, P.text "Make sure all type variables are replaced with concrete types:"
, P.text "\n"
, nest 4 (pretty decl)
]
illFormedTypes :: [D.Declaration t v] -> [Doc]
illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
where
aliases = [ (decl, tvars, [tipe]) | decl@(TypeAlias _ tvars tipe) <- decls ]
adts = [ (decl, tvars, concatMap snd ctors) | decl@(Datatype _ tvars ctors) <- decls ]
aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.Datatype _ tvars ctors) <- decls ]
freeVars tipe =
case tipe of
@ -141,9 +161,9 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
quote tvar = "'" ++ tvar ++ "'"
infiniteTypeAliases :: [Declaration t v] -> [Doc]
infiniteTypeAliases :: [D.Declaration t v] -> [Doc]
infiniteTypeAliases decls =
[ report decl | decl@(TypeAlias name _ tipe) <- decls, isInfinite name tipe ]
[ report decl | decl@(D.TypeAlias name _ tipe _) <- decls, isInfinite name tipe ]
where
isInfinite name tipe =
let infinite = isInfinite name in
@ -154,11 +174,11 @@ infiniteTypeAliases decls =
T.EmptyRecord -> False
T.Record fields ext -> infinite ext || any (infinite . snd) fields
report decl@(TypeAlias name args tipe) =
report decl@(D.TypeAlias name args tipe _) =
P.vcat [ P.text $ eightyCharLines 0 msg1
, indented decl
, P.text $ eightyCharLines 0 msg2
, indented (Datatype name args [(name,[tipe])])
, indented (D.Datatype name args [(name,[tipe])])
, P.text $ eightyCharLines 0 msg3 ++ "\n"
]
where