Get rid of experimental code for handling "deriving"
This commit is contained in:
Evan Czaplicki
parent
3640376be8
commit
6ba394c9cb
12 changed files with 54 additions and 114 deletions
|
|
@ -35,8 +35,8 @@ build noPrelude interfaces source =
|
|||
| null exs =
|
||||
let get = Set.toList . Pattern.boundVars in
|
||||
concat [ get pattern | Definition (Expr.Definition pattern _ _) <- decls ] ++
|
||||
concat [ map fst ctors | Datatype _ _ ctors _ <- decls ] ++
|
||||
[ name | TypeAlias name _ (Type.Record _ _) _ <- decls ]
|
||||
concat [ map fst ctors | Datatype _ _ ctors <- decls ] ++
|
||||
[ name | TypeAlias name _ (Type.Record _ _) <- decls ]
|
||||
| otherwise = exs
|
||||
|
||||
metaModule <- Canonical.metadataModule interfaces $
|
||||
|
|
@ -48,9 +48,9 @@ build noPrelude interfaces source =
|
|||
-- reorder AST into strongly connected components
|
||||
, program = SD.sortDefs . Expr.dummyLet $ TcDecl.toExpr decls
|
||||
, types = Map.empty
|
||||
, datatypes = [ (name,vars,ctors,ds) | Datatype name vars ctors ds <- decls ]
|
||||
, datatypes = [ (name,vars,ctors) | Datatype name vars ctors <- decls ]
|
||||
, fixities = [ (assoc,level,op) | Fixity assoc level op <- decls ]
|
||||
, aliases = [ (name,tvs,tipe,ds) | TypeAlias name tvs tipe ds <- decls ]
|
||||
, aliases = [ (name,tvs,tipe) | TypeAlias name tvs tipe <- decls ]
|
||||
}
|
||||
|
||||
types <- TI.infer interfaces metaModule
|
||||
|
|
|
|||
|
|
@ -134,14 +134,13 @@ collect infixes types aliases adts things =
|
|||
collect (Map.insert name (assoc,prec) infixes) types aliases adts rest
|
||||
D.Definition (E.TypeAnnotation name tipe) ->
|
||||
collect infixes (insert name [ "type" .= tipe ] types) aliases adts rest
|
||||
D.TypeAlias name vars tipe derivations ->
|
||||
let fields = ["typeVariables" .= vars, "type" .= tipe, "deriving" .= derivations ]
|
||||
D.TypeAlias name vars tipe ->
|
||||
let fields = ["typeVariables" .= vars, "type" .= tipe ]
|
||||
in collect infixes types (insert name fields aliases) adts rest
|
||||
D.Datatype name vars ctors derivations ->
|
||||
D.Datatype name vars ctors ->
|
||||
let tipe = Data name (map Var vars)
|
||||
fields = ["typeVariables" .= vars
|
||||
, "constructors" .= map (ctorToJson tipe) ctors
|
||||
, "deriving" .= derivations ]
|
||||
, "constructors" .= map (ctorToJson tipe) ctors ]
|
||||
in collect infixes types aliases (insert name fields adts) rest
|
||||
where
|
||||
insert name fields dict = Map.insert name (obj name fields) dict
|
||||
|
|
@ -162,6 +161,3 @@ instance ToJSON Type where
|
|||
ctorToJson tipe (ctor, tipes) =
|
||||
object [ "name" .= ctor
|
||||
, "type" .= foldr Lambda tipe tipes ]
|
||||
|
||||
instance ToJSON D.Derivation where
|
||||
toJSON = toJSON . show
|
||||
|
|
@ -24,11 +24,7 @@ alias = do
|
|||
args <- spacePrefix lowVar
|
||||
padded equals
|
||||
tipe <- Type.expr
|
||||
json <- option [] $ do
|
||||
try $ padded (reserved "deriving")
|
||||
string "Json"
|
||||
return [D.Json]
|
||||
return (D.TypeAlias name args tipe json)
|
||||
return (D.TypeAlias name args tipe)
|
||||
|
||||
datatype :: IParser D.ParseDeclaration
|
||||
datatype = do
|
||||
|
|
@ -38,7 +34,7 @@ datatype = do
|
|||
args <- spacePrefix lowVar
|
||||
padded equals
|
||||
tcs <- pipeSep1 Type.constructor
|
||||
return $ D.Datatype name args tcs []
|
||||
return $ D.Datatype name args tcs
|
||||
|
||||
|
||||
infixDecl :: IParser D.ParseDeclaration
|
||||
|
|
@ -60,4 +56,4 @@ port =
|
|||
whitespace
|
||||
let port' op ctor expr = do { try op ; whitespace ; ctor name <$> expr }
|
||||
D.Port <$> choice [ port' hasType D.PPAnnotation Type.expr
|
||||
, port' equals D.PPDef Expr.expr ]
|
||||
, port' equals D.PPDef Expr.expr ]
|
||||
|
|
|
|||
|
|
@ -9,8 +9,8 @@ import Text.PrettyPrint as P
|
|||
|
||||
data Declaration' port def
|
||||
= Definition def
|
||||
| Datatype String [String] [(String,[T.Type])] [Derivation]
|
||||
| TypeAlias String [String] T.Type [Derivation]
|
||||
| Datatype String [String] [(String,[T.Type])]
|
||||
| TypeAlias String [String] T.Type
|
||||
| Port port
|
||||
| Fixity Assoc Int String
|
||||
deriving (Show)
|
||||
|
|
@ -18,9 +18,6 @@ data Declaration' port def
|
|||
data Assoc = L | N | R
|
||||
deriving (Eq)
|
||||
|
||||
data Derivation = Json | JS | Binary | New
|
||||
deriving (Eq, Show)
|
||||
|
||||
data ParsePort
|
||||
= PPAnnotation String T.Type
|
||||
| PPDef String Expr.LParseExpr
|
||||
|
|
@ -34,23 +31,6 @@ data Port
|
|||
type ParseDeclaration = Declaration' ParsePort Expr.ParseDef
|
||||
type Declaration = Declaration' Port Expr.Def
|
||||
|
||||
instance Binary Derivation where
|
||||
get = do n <- getWord8
|
||||
return $ case n of
|
||||
0 -> Json
|
||||
1 -> JS
|
||||
2 -> Binary
|
||||
3 -> New
|
||||
_ -> error "Unable to decode Derivation. You may have corrupted binary files,\n\
|
||||
\so please report an issue at <https://github.com/evancz/Elm/issues>"
|
||||
|
||||
put derivation =
|
||||
putWord8 $ case derivation of
|
||||
Json -> 0
|
||||
JS -> 1
|
||||
Binary -> 2
|
||||
New -> 3
|
||||
|
||||
instance Show Assoc where
|
||||
show assoc =
|
||||
case assoc of
|
||||
|
|
@ -73,19 +53,18 @@ instance (Pretty port, Pretty def) => Pretty (Declaration' port def) where
|
|||
case decl of
|
||||
Definition def -> pretty def
|
||||
|
||||
Datatype tipe tvars ctors deriveables ->
|
||||
Datatype tipe tvars ctors ->
|
||||
P.hang (P.text "data" <+> P.text tipe <+> P.hsep (map P.text tvars)) 4
|
||||
(P.sep $ zipWith join ("=" : repeat "|") ctors) <+> prettyDeriving deriveables
|
||||
(P.sep $ zipWith join ("=" : repeat "|") ctors)
|
||||
where
|
||||
join c ctor = P.text c <+> prettyCtor ctor
|
||||
prettyCtor (name, tipes) =
|
||||
P.hang (P.text name) 2 (P.sep (map T.prettyParens tipes))
|
||||
|
||||
TypeAlias name tvars tipe deriveables ->
|
||||
alias <+> prettyDeriving deriveables
|
||||
TypeAlias name tvars tipe ->
|
||||
P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
|
||||
where
|
||||
name' = P.text name <+> P.hsep (map P.text tvars)
|
||||
alias = P.hang (P.text "type" <+> name' <+> P.equals) 4 (pretty tipe)
|
||||
|
||||
Port port -> pretty port
|
||||
|
||||
|
|
@ -112,11 +91,3 @@ instance Pretty Port where
|
|||
|
||||
prettyPort :: (Pretty a) => String -> String -> a -> Doc
|
||||
prettyPort name op e = P.text "port" <+> P.text name <+> P.text op <+> pretty e
|
||||
|
||||
prettyDeriving :: [Derivation] -> Doc
|
||||
prettyDeriving deriveables =
|
||||
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)
|
||||
|
|
@ -50,8 +50,8 @@ data MetadataModule =
|
|||
} deriving Show
|
||||
|
||||
type Interfaces = Map.Map String ModuleInterface
|
||||
type ADT = (String, [String], [(String,[Type])], [Derivation])
|
||||
type Alias = (String, [String], Type, [Derivation])
|
||||
type ADT = (String, [String], [(String,[Type])])
|
||||
type Alias = (String, [String], Type)
|
||||
|
||||
data ModuleInterface = ModuleInterface {
|
||||
iVersion :: Version.Version,
|
||||
|
|
|
|||
|
|
@ -27,11 +27,11 @@ interface moduleName iface =
|
|||
, iFixities = iFixities iface -- cannot have canonicalized operators while parsing
|
||||
}
|
||||
where
|
||||
both f g (a,b,c,d) = (f a, b, g c, d)
|
||||
both f g (a,b,c) = (f a, b, g c)
|
||||
prefix name = moduleName ++ "." ++ name
|
||||
|
||||
pair name = (name, moduleName ++ "." ++ name)
|
||||
canon (name,_,_,_) = pair name
|
||||
canon (name,_,_) = pair name
|
||||
canons = Map.fromList $ concat
|
||||
[ map canon (iAdts iface), map canon (iAliases iface) ]
|
||||
|
||||
|
|
@ -56,24 +56,24 @@ metadataModule ifaces modul =
|
|||
[] -> Right ()
|
||||
missings -> Left [ P.text $ "The following imports were not found: " ++ List.intercalate ", " missings ]
|
||||
program' <- rename initialEnv (program modul)
|
||||
aliases' <- mapM (three4 renameType') (aliases modul)
|
||||
datatypes' <- mapM (three4 (mapM (two2 (mapM renameType')))) (datatypes modul)
|
||||
aliases' <- mapM (three3 renameType') (aliases modul)
|
||||
datatypes' <- mapM (three3 (mapM (two2 (mapM renameType')))) (datatypes modul)
|
||||
return $ modul { program = program'
|
||||
, aliases = aliases'
|
||||
, datatypes = datatypes' }
|
||||
where
|
||||
two2 f (a,b) = (,) a <$> f b
|
||||
three4 f (a,b,c,d) = (,,,) a b <$> f c <*> return d
|
||||
three3 f (a,b,c) = (,,) a b <$> f c
|
||||
renameType' =
|
||||
Either.either (\err -> Left [P.text err]) return . renameType (replace "type" initialEnv)
|
||||
|
||||
get1 (a,_,_,_) = a
|
||||
get1 (a,_,_) = a
|
||||
canon (name, importMethod) =
|
||||
let pair pre var = (pre ++ drop (length name + 1) var, var)
|
||||
iface = ifaces Map.! name
|
||||
allNames = concat [ Map.keys (iTypes iface)
|
||||
, map get1 (iAliases iface)
|
||||
, concat [ n : map fst ctors | (n,_,ctors,_) <- iAdts iface ] ]
|
||||
, concat [ n : map fst ctors | (n,_,ctors) <- iAdts iface ] ]
|
||||
in case importMethod of
|
||||
As alias -> map (pair (alias ++ ".")) allNames
|
||||
Hiding vars -> map (pair "") $ filter (flip Set.notMember vs) allNames
|
||||
|
|
|
|||
|
|
@ -21,8 +21,7 @@ mistakes decls =
|
|||
concat [ infiniteTypeAliases decls
|
||||
, illFormedTypes decls
|
||||
, map P.text (duplicateConstructors decls)
|
||||
, map P.text (duplicates decls)
|
||||
, badDerivations decls ]
|
||||
, map P.text (duplicates decls) ]
|
||||
|
||||
dups :: Ord a => [a] -> [a]
|
||||
dups = map head . filter ((>1) . length) . List.group . List.sort
|
||||
|
|
@ -67,35 +66,14 @@ duplicateConstructors decls =
|
|||
map (dupErr "definition of type constructor") (dups typeCtors) ++
|
||||
map (dupErr "definition of data constructor") (dups dataCtors)
|
||||
where
|
||||
typeCtors = [ name | D.Datatype name _ _ _ <- decls ]
|
||||
dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns _ <- decls ]
|
||||
|
||||
badDerivations :: [D.Declaration] -> [Doc]
|
||||
badDerivations decls = concatMap badDerivation derivations
|
||||
where
|
||||
derivations =
|
||||
[ (decl, tvars, derives) | decl@(D.TypeAlias _ tvars _ derives) <- decls ] ++
|
||||
[ (decl, tvars, derives) | decl@(D.Datatype _ 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)
|
||||
]
|
||||
typeCtors = [ name | D.Datatype name _ _ <- decls ]
|
||||
dataCtors = concat [ map fst patterns | D.Datatype _ _ patterns <- decls ]
|
||||
|
||||
illFormedTypes :: [D.Declaration] -> [Doc]
|
||||
illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
|
||||
where
|
||||
aliases = [ (decl, tvars, [tipe]) | decl@(D.TypeAlias _ tvars tipe _) <- decls ]
|
||||
adts = [ (decl, tvars, concatMap snd ctors) | decl@(D.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
|
||||
|
|
@ -138,8 +116,8 @@ illFormedTypes decls = map report (Maybe.mapMaybe isIllFormed (aliases ++ adts))
|
|||
|
||||
infiniteTypeAliases :: [D.Declaration] -> [Doc]
|
||||
infiniteTypeAliases decls =
|
||||
[ report name tvars tipe ds | D.TypeAlias name tvars tipe ds <- decls
|
||||
, infiniteType name tipe ]
|
||||
[ report name tvars tipe | D.TypeAlias name tvars tipe <- decls
|
||||
, infiniteType name tipe ]
|
||||
where
|
||||
infiniteType name tipe =
|
||||
let infinite = infiniteType name in
|
||||
|
|
@ -152,11 +130,11 @@ infiniteTypeAliases decls =
|
|||
indented :: D.Declaration -> Doc
|
||||
indented decl = P.text "\n " <> pretty decl <> P.text "\n"
|
||||
|
||||
report name args tipe derivations =
|
||||
report name args tipe =
|
||||
P.vcat [ P.text $ eightyCharLines 0 msg1
|
||||
, indented $ D.TypeAlias name args tipe derivations
|
||||
, indented $ D.TypeAlias name args tipe
|
||||
, P.text $ eightyCharLines 0 msg2
|
||||
, indented $ D.Datatype name args [(name,[tipe])] derivations
|
||||
, indented $ D.Datatype name args [(name,[tipe])]
|
||||
, P.text $ eightyCharLines 0 msg3 ++ "\n"
|
||||
]
|
||||
where
|
||||
|
|
|
|||
|
|
@ -23,11 +23,11 @@ combineAnnotations = go
|
|||
-- simple cases, pass them through with no changes
|
||||
[] -> return []
|
||||
|
||||
Datatype name tvars ctors ds : rest ->
|
||||
(:) (Datatype name tvars ctors ds) <$> go rest
|
||||
Datatype name tvars ctors : rest ->
|
||||
(:) (Datatype name tvars ctors) <$> go rest
|
||||
|
||||
TypeAlias name tvars alias ds : rest ->
|
||||
(:) (TypeAlias name tvars alias ds) <$> go rest
|
||||
TypeAlias name tvars alias : rest ->
|
||||
(:) (TypeAlias name tvars alias) <$> go rest
|
||||
|
||||
Fixity assoc prec op : rest ->
|
||||
(:) (Fixity assoc prec op) <$> go rest
|
||||
|
|
|
|||
|
|
@ -64,9 +64,9 @@ metadataModule modul =
|
|||
, imports = map (first var) (imports modul)
|
||||
, program = expression (program modul)
|
||||
, aliases =
|
||||
let makeSafe (name,tvars,tipe,ds) = (var name, tvars, tipe, ds)
|
||||
let makeSafe (name,tvars,tipe) = (var name, tvars, tipe)
|
||||
in map makeSafe (aliases modul)
|
||||
, datatypes =
|
||||
let makeSafe (name,tvars,ctors,ds) = (var name, tvars, map (first var) ctors, ds)
|
||||
let makeSafe (name,tvars,ctors) = (var name, tvars, map (first var) ctors)
|
||||
in map makeSafe (datatypes modul)
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -21,7 +21,7 @@ collect interfaces moduleAliases =
|
|||
rawAliases =
|
||||
moduleAliases ++ concatMap iAliases (Map.elems interfaces)
|
||||
|
||||
isPrimitive (_,_,tipe,_) =
|
||||
isPrimitive (_,_,tipe) =
|
||||
case tipe of
|
||||
Data _ [] -> True
|
||||
_ -> False
|
||||
|
|
@ -68,7 +68,7 @@ canonicalRealias aliases tipe =
|
|||
[] -> if tipe == tipe' then tipe else f tipe'
|
||||
tipes -> f (bestType tipes)
|
||||
where
|
||||
tryRealias (name, args, aliasTipe, _) =
|
||||
tryRealias (name, args, aliasTipe) =
|
||||
case diff aliasTipe tipe of
|
||||
Nothing -> []
|
||||
Just kvs ->
|
||||
|
|
@ -136,4 +136,4 @@ collectFields fields =
|
|||
foldr (\(f,t) fs -> Map.insertWith (++) f [t] fs) Map.empty fields
|
||||
|
||||
flattenFields fields =
|
||||
concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)
|
||||
concatMap (\(f,ts) -> map ((,) f) ts) (Map.toList fields)
|
||||
|
|
|
|||
|
|
@ -15,7 +15,7 @@ toDefs decl =
|
|||
case decl of
|
||||
Definition def -> [def]
|
||||
|
||||
Datatype name tvars constructors _ -> concatMap toDefs' constructors
|
||||
Datatype name tvars constructors -> concatMap toDefs' constructors
|
||||
where
|
||||
toDefs' (ctor, tipes) =
|
||||
let vars = take (length tipes) arguments
|
||||
|
|
@ -23,7 +23,7 @@ toDefs decl =
|
|||
body = L.none . E.Data ctor $ map (L.none . E.Var) vars
|
||||
in [ definition ctor (buildFunction body vars) (foldr T.Lambda tbody tipes) ]
|
||||
|
||||
TypeAlias name _ tipe@(T.Record fields ext) _ ->
|
||||
TypeAlias name _ tipe@(T.Record fields ext) ->
|
||||
[ definition name (buildFunction record vars) (foldr T.Lambda tipe args) ]
|
||||
where
|
||||
args = map snd fields ++ maybe [] (\x -> [T.Var x]) ext
|
||||
|
|
@ -38,8 +38,7 @@ toDefs decl =
|
|||
|
||||
-- Type aliases must be added to an extended equality dictionary,
|
||||
-- but they do not require any basic constraints.
|
||||
-- TODO: with the ability to derive code, you may need to generate stuff!
|
||||
TypeAlias _ _ _ _ -> []
|
||||
TypeAlias _ _ _ -> []
|
||||
|
||||
Port port ->
|
||||
case port of
|
||||
|
|
@ -60,4 +59,4 @@ buildFunction body@(L.L s _) vars =
|
|||
foldr (\p e -> L.L s (E.Lambda p e)) body (map P.PVar vars)
|
||||
|
||||
definition :: String -> E.LExpr -> T.Type -> E.Def
|
||||
definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
|
||||
definition name expr tipe = E.Definition (P.PVar name) expr (Just tipe)
|
||||
|
|
|
|||
|
|
@ -29,7 +29,7 @@ data Environment = Environment {
|
|||
initialEnvironment :: [ADT] -> [Alias] -> IO Environment
|
||||
initialEnvironment datatypes aliases = do
|
||||
types <- makeTypes datatypes
|
||||
let aliases' = Map.fromList $ map (\(a,b,c,_) -> (a,(b,c))) aliases
|
||||
let aliases' = Map.fromList $ map (\(a,b,c) -> (a,(b,c))) aliases
|
||||
env = Environment {
|
||||
constructor = Map.empty,
|
||||
value = Map.empty,
|
||||
|
|
@ -42,7 +42,7 @@ makeTypes :: [ADT] -> IO TypeDict
|
|||
makeTypes datatypes =
|
||||
Map.fromList <$> mapM makeCtor (builtins ++ map nameAndKind datatypes)
|
||||
where
|
||||
nameAndKind (name, tvars, _, _) = (name, length tvars)
|
||||
nameAndKind (name, tvars, _) = (name, length tvars)
|
||||
|
||||
makeCtor (name, _) = do
|
||||
ctor <- VarN <$> namedVar Constant name
|
||||
|
|
@ -84,7 +84,7 @@ makeConstructors env datatypes = Map.fromList builtins
|
|||
|
||||
|
||||
ctorToType :: Environment -> ADT -> [ (String, IO (Int, [Variable], [Type], Type)) ]
|
||||
ctorToType env (name, tvars, ctors, _) =
|
||||
ctorToType env (name, tvars, ctors) =
|
||||
zip (map fst ctors) (map inst ctors)
|
||||
where
|
||||
inst :: (String, [Src.Type]) -> IO (Int, [Variable], [Type], Type)
|
||||
|
|
@ -167,4 +167,4 @@ instantiator env sourceType = go sourceType
|
|||
ext' <- case ext of
|
||||
Nothing -> return $ TermN EmptyRecord1
|
||||
Just x -> go (Src.Var x)
|
||||
return $ TermN (Record1 fields' ext')
|
||||
return $ TermN (Record1 fields' ext')
|
||||
|
|
|
|||
Loading…
Reference in a new issue