Begin process of allowing "deriving" on type aliases.
This commit is contained in:
parent
171f199db3
commit
32c78efe7d
3 changed files with 72 additions and 38 deletions
|
@ -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."
|
||||
|
||||
|
|
|
@ -8,14 +8,17 @@ 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
|
||||
deriving (Eq, Show)
|
||||
|
||||
data Assoc = L | N | R
|
||||
deriving (Eq)
|
||||
deriving (Eq)
|
||||
|
||||
data Deriveable = Json | Binary | RecordConstructor
|
||||
deriving (Eq, Show)
|
||||
|
||||
instance Show Assoc where
|
||||
show assoc =
|
||||
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue