git.iko.soy/elk
on master help sign in
Assume arguments match the type annotations
commit8506ed8361f65d0ed8758a34b475a1ba05175940 authorEvan Czaplicki <evancz@users.noreply.github.com> dateMon 19 Sep 2016, 11:21 (10 years ago) parent3b23d86
6 files changed+120−96
compare with master
unifiedsplit
src/Reporting/Error/Type.hs+18−5 src/Type/Constrain/Expression.hs+58−47 src/Type/Constrain/Pattern.hs+1−1 src/Type/Environment.hs+28−30 src/Type/Inference.hs+5−3 src/Type/Type.hs+10−10
src/Reporting/Error/Type.hs+18−5
@@ -69,7 +69,7 @@ data Hint
6969 | Function (Maybe Var.Canonical)
7070 | UnexpectedArg (Maybe Var.Canonical) Int Int Region.Region
7171 | FunctionArity (Maybe Var.Canonical) Int Int Region.Region
72− | BadTypeAnnotation String
72+ | ReturnType String Int
7373 | Instance String
7474 | Literal String
7575 | Pattern Pattern
@@ -366,13 +366,26 @@ mismatchToReport localizer (MismatchInfo hint leftType rightType maybeReason) =
366366 )
367367 (text "Maybe you forgot some parentheses? Or a comma?")
368368
369− BadTypeAnnotation name ->
370− report
369+ ReturnType name 0 ->
370+ report
371371 Nothing
372372 ("The type annotation for " ++ Help.functionName name ++ " does not match its definition.")
373373 ( cmpHint
374− "The type annotation is saying:"
375− "But I am inferring that the definition has this type:"
374+ ( "The type annotation says " ++ Help.functionName name
375+ ++ " should be a:"
376+ )
377+ "But the value you defined has this type:"
378+ []
379+ )
380+
381+ ReturnType name arity ->
382+ report
383+ Nothing
384+ ("The " ++ Help.functionName name ++ " function does not match the type annotation.")
385+ ( cmpHint
386+ "The definition produces values of this type:"
387+ ( "But type annotation says " ++ Help.functionName name ++ " should return:"
388+ )
376389 []
377390 )
378391
src/Type/Constrain/Expression.hs+58−47
@@ -491,14 +491,12 @@ data Info = Info
491491
492492constrainDef :: Env.Env -> Info -> Canonical.Def -> IO Info
493493constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTipe) =
494− let qs = [] -- should come from the def, but I'm not sure what would live there...
495− in
496494 case (pattern, maybeTipe) of
497495 (P.Var name, Nothing) ->
498− constrainUnannotatedDef env info qs patternRegion name expr
496+ constrainUnannotatedDef env patternRegion name expr info
499497
500− (P.Var name, Just (A.A typeRegion tipe)) ->
501− constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe
498+ (P.Var name, Just (A.A _ tipe)) ->
499+ constrainAnnotatedDef env patternRegion name expr tipe info
502500
503501 _ ->
504502 error "canonical definitions must not have complex patterns as names in the contstraint generation phase"
@@ -506,66 +504,79 @@ constrainDef env info (Canonical.Def _ (A.A patternRegion pattern) expr maybeTip
506504
507505constrainUnannotatedDef
508506 :: Env.Env
509− -> Info
510− -> [String]
511507 -> R.Region
512508 -> String
513509 -> Canonical.Expr
510+ -> Info
514511 -> IO Info
515−constrainUnannotatedDef env info qs patternRegion name expr =
516− do -- Some mistake may be happening here. Currently, qs is always [].
517− rigidVars <- mapM mkRigid qs
518−
519− v <- mkVar Nothing
520−
512+constrainUnannotatedDef env patternRegion name expr info =
513+ do v <- mkVar Nothing
521514 let tipe = VarN v
522−
523− let env' = Env.addValues env (zip qs rigidVars)
524−
525− con <- constrain env' expr tipe
526−
515+ defCon <- constrain env expr tipe
527516 return $ info
528− { iRigid = rigidVars ++ iRigid info
529− , iFlex = v : iFlex info
517+ { iFlex = v : iFlex info
530518 , iHeaders = Map.insert name (A.A patternRegion tipe) (iHeaders info)
531− , iC2 = con /\ iC2 info
519+ , iC2 = defCon /\ iC2 info
532520 }
533521
534522
535−constrainAnnotatedDef
536− :: Env.Env
537− -> Info
538− -> [String]
539− -> R.Region
540− -> R.Region
541− -> String
542− -> Canonical.Expr
543− -> ST.Canonical
544− -> IO Info
545−constrainAnnotatedDef env info qs patternRegion typeRegion name expr tipe =
546− do -- Some mistake may be happening here. Currently, qs is always [].
547− rigidVars <- mapM mkRigid qs
548−
549− flexiVars <- mapM mkNamedVar qs
550−
551− let env' = Env.addValues env (zip qs flexiVars)
552−
553− (vars, typ) <- Env.instantiateType env tipe Map.empty
523+constrainAnnotatedDef :: Env.Env -> R.Region -> String -> Canonical.Expr -> ST.Canonical -> Info -> IO Info
524+constrainAnnotatedDef env region name expr tipe info =
525+ do (flexType, flexVars) <- Env.instantiateType Flex env tipe
554526
555527 let scheme =
556528 Scheme
557529 { _rigidQuantifiers = []
558− , _flexibleQuantifiers = flexiVars ++ vars
530+ , _flexibleQuantifiers = Map.elems flexVars
559531 , _constraint = CTrue
560− , _header = Map.singleton name (A.A patternRegion typ)
532+ , _header = Map.singleton name (A.A region flexType)
561533 }
562534
563− var <- mkVar Nothing
564− defCon <- constrain env' expr (VarN var)
565− let annCon =
566− CEqual (Error.BadTypeAnnotation name) typeRegion typ (VarN var)
535+ defCon <- constrainAnnDefHelp name expr tipe (ArgInfo env [] [])
567536
568537 return $ info
569538 { iSchemes = scheme : iSchemes info
570− , iC1 = iC1 info /\ ex [var] (defCon /\ fl rigidVars annCon)
539+ , iC1 = iC1 info /\ defCon
571540 }
541+
542+
543+
544+data ArgInfo =
545+ ArgInfo
546+ { _env :: Env.Env
547+ , _args :: [(P.Canonical, Type)]
548+ , _vars :: [Variable]
549+ }
550+
551+
552+constrainAnnDefHelp :: String -> Canonical.Expr -> ST.Canonical -> ArgInfo -> IO TypeConstraint
553+constrainAnnDefHelp name expr tipe (ArgInfo env args vars) =
554+ case (expr, tipe) of
555+ (A.A _ (E.Lambda arg result), ST.Lambda argType resultType) ->
556+ do (rigidArgType, newVars) <- Env.instantiateType Rigid env argType
557+
558+ constrainAnnDefHelp name result resultType $
559+ ArgInfo
560+ { _env = Env.addValues newVars env
561+ , _args = (arg, rigidArgType) : args
562+ , _vars = Map.elems newVars ++ vars
563+ }
564+
565+ (A.A region _, _) ->
566+ do (rigidType, newVars) <- Env.instantiateType Rigid env tipe
567+
568+ let finalEnv = Env.addValues newVars env
569+ let finalArgs = reverse args
570+ let rigidVars = Map.elems newVars ++ vars
571+
572+ (Pattern.Info headers argVars argCons) <-
573+ Pattern.joinInfos <$> mapM (uncurry (Pattern.constrain finalEnv)) finalArgs
574+
575+ resultVar <- mkVar Nothing
576+ let resultType = VarN resultVar
577+ defCon <- constrain finalEnv expr resultType
578+ let resultCon =
579+ CEqual (Error.ReturnType name (length args)) region resultType rigidType
580+
581+ return $ forall rigidVars $ ex (resultVar : argVars) $ CLet [monoscheme headers] $
582+ CAnd [ argCons, defCon, resultCon ]
src/Type/Constrain/Pattern.hs+1−1
@@ -1,5 +1,5 @@
11{-# OPTIONS_GHC -Wall #-}
2−module Type.Constrain.Pattern (Info(..), infoToScheme, constrain) where
2+module Type.Constrain.Pattern (Info(..), joinInfos, infoToScheme, constrain) where
33
44import Control.Arrow (second)
55import qualified Control.Monad as Monad
src/Type/Environment.hs+28−30
@@ -9,7 +9,6 @@ module Type.Environment
99 where
1010
1111import qualified Control.Monad.State as State
12−import qualified Data.List as List
1312import Data.Map ((!))
1413import qualified Data.Map as Map
1514import qualified Data.Set as Set
@@ -114,8 +113,8 @@ ctorToType env (name, (tvars, ctors)) =
114113
115114 go :: (V.Canonical, [T.Canonical]) -> State.StateT VarDict IO ([Type], Type)
116115 go (_, args) =
117− do types <- mapM (instantiator env) args
118− returnType <- instantiator env (T.App (T.Type name) (map T.Var tvars))
116+ do types <- mapM (instantiator Flex env) args
117+ returnType <- instantiator Flex env (T.App (T.Type name) (map T.Var tvars))
119118 return (types, returnType)
120119
121120
@@ -145,40 +144,34 @@ ctorNames env =
145144 Map.keys (_constructor env)
146145
147146
147+
148148-- UPDATE ENVIRONMENT
149149
150150
151−addValues :: Env -> [(String, Variable)] -> Env
152−addValues env newValues =
153− env
154− { _value =
155− List.foldl'
156− (\dict (name, var) -> Map.insert name (VarN var) dict)
157− (_value env)
158− newValues
159− }
151+addValues :: VarDict -> Env -> Env
152+addValues newValues env =
153+ env { _value = Map.union (_value env) (Map.map VarN newValues) }
160154
161155
162156
163157-- INSTANTIATE TYPES
164158
165159
166−instantiateType :: Env -> T.Canonical -> VarDict -> IO ([Variable], Type)
167−instantiateType env sourceType dict =
168− do (tipe, dict') <- State.runStateT (instantiator env sourceType) dict
169− return (Map.elems dict', tipe)
160+instantiateType :: Flex -> Env -> T.Canonical -> IO (Type, VarDict)
161+instantiateType flex env sourceType =
162+ State.runStateT (instantiator flex env sourceType) Map.empty
170163
171164
172−instantiator :: Env -> T.Canonical -> State.StateT VarDict IO Type
173−instantiator env sourceType =
174− instantiatorHelp env Set.empty sourceType
165+instantiator :: Flex -> Env -> T.Canonical -> State.StateT VarDict IO Type
166+instantiator flex env sourceType =
167+ instantiatorHelp flex env Set.empty sourceType
175168
176169
177−instantiatorHelp :: Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
178−instantiatorHelp env aliasVars sourceType =
170+instantiatorHelp :: Flex -> Env -> Set.Set String -> T.Canonical -> State.StateT VarDict IO Type
171+instantiatorHelp flex env aliasVars sourceType =
179172 let
180173 go =
181− instantiatorHelp env aliasVars
174+ instantiatorHelp flex env aliasVars
182175 in
183176 case sourceType of
184177 T.Lambda t1 t2 ->
@@ -190,24 +183,29 @@ instantiatorHelp env aliasVars sourceType =
190183
191184 else
192185 do dict <- State.get
193− case Map.lookup name dict of
194− Just variable ->
195− return (VarN variable)
186+ case Map.lookup name (_value env) of
187+ Just tipe ->
188+ return tipe
196189
197190 Nothing ->
198− do variable <- State.liftIO (mkNamedVar name)
199− State.put (Map.insert name variable dict)
200− return (VarN variable)
191+ case Map.lookup name dict of
192+ Just variable ->
193+ return (VarN variable)
194+
195+ Nothing ->
196+ do variable <- State.liftIO (mkNamedVar flex name)
197+ State.put (Map.insert name variable dict)
198+ return (VarN variable)
201199
202200 T.Aliased name args aliasType ->
203201 do targs <- mapM (\(arg,tipe) -> (,) arg <$> go tipe) args
204202 realType <-
205203 case aliasType of
206204 T.Filled tipe ->
207− instantiatorHelp env Set.empty tipe
205+ instantiatorHelp flex env Set.empty tipe
208206
209207 T.Holey tipe ->
210− instantiatorHelp env (Set.fromList (map fst args)) tipe
208+ instantiatorHelp flex env (Set.fromList (map fst args)) tipe
211209
212210 return (AliasN name targs realType)
213211
src/Type/Inference.hs+5−3
@@ -72,11 +72,13 @@ canonicalizeValues
7272 -> (ModuleName.Canonical, Module.Interface)
7373 -> IO [(String, ([T.Variable], T.Type))]
7474canonicalizeValues env (moduleName, iface) =
75− forM (Map.toList (Module.iTypes iface)) $ \(name,tipe) ->
76− do tipe' <- Env.instantiateType env tipe Map.empty
75+ forM (Map.toList (Module.iTypes iface)) $ \(name, tipe) ->
76+ do (flexType, flexVars) <- Env.instantiateType T.Flex env tipe
7777 return
7878 ( ModuleName.canonicalToString moduleName ++ "." ++ name
79− , tipe'
79+ , ( Map.elems flexVars
80+ , flexType
81+ )
8082 )
8183
8284
src/Type/Type.hs+10−10
@@ -183,14 +183,15 @@ mkVar maybeSuper =
183183 UF.fresh $ mkDescriptor (Var Flex maybeSuper Nothing)
184184
185185
186−mkNamedVar :: String -> IO Variable
187−mkNamedVar name =
188− UF.fresh $ mkDescriptor (Var Flex (toSuper name) Nothing)
186+mkNamedVar :: Flex -> String -> IO Variable
187+mkNamedVar flex name =
188+ UF.fresh $ mkDescriptor $ Var flex (toSuper name) $
189+ case flex of
190+ Flex ->
191+ Nothing
189192
190−
191−mkRigid :: String -> IO Variable
192−mkRigid name =
193− UF.fresh $ mkDescriptor (Var Rigid (toSuper name) (Just name))
193+ Rigid ->
194+ Just name
194195
195196
196197toSuper :: String -> Maybe Super
@@ -233,9 +234,8 @@ ex fqs constraint =
233234 CLet [Scheme [] fqs constraint Map.empty] CTrue
234235
235236
236−-- fl qs constraint == forall qs. constraint
237−fl :: [Variable] -> TypeConstraint -> TypeConstraint
238−fl rqs constraint =
237+forall :: [Variable] -> TypeConstraint -> TypeConstraint
238+forall rqs constraint =
239239 CLet [Scheme rqs [] constraint Map.empty] CTrue
240240
241241