@@ -19,12 +19,10 @@ module Language.PureScript.TypeChecker.Types (
1919) where
2020
2121import Data.List
22−import Data.Maybe (isJust, fromMaybe)
23−import Data.Function
22+import Data.Maybe (fromMaybe)
2423import qualified Data.Data as D
2524import Data.Generics
26− (extT, something, everywhere, everywhereM, everything,
27− everywhereBut, mkT, mkM, mkQ, extM, extQ)
25+ (mkT, something, everywhere, everywhereBut, mkQ, extQ)
2826
2927import Language.PureScript.Values
3028import Language.PureScript.Types
@@ -40,8 +38,7 @@ import Control.Monad.State
4038import Control.Monad.Error
4139
4240import Control.Applicative
43−import Control.Arrow (Arrow(..), Kleisli(..), (***), (&&&), second)
44−import qualified Control.Category as C
41+import Control.Arrow (Arrow(..))
4542
4643import qualified Data.Map as M
4744
@@ -60,7 +57,7 @@ instance Unifiable Type where
6057 apply _ t = t
6158 unknowns (TUnknown (Unknown u)) = [u]
6259 unknowns (SaturatedTypeSynonym _ tys) = concatMap unknowns tys
63− unknowns (ForAll idents ty) = unknowns ty
60+ unknowns (ForAll _ ty) = unknowns ty
6461 unknowns (Array t) = unknowns t
6562 unknowns (Object r) = unknowns r
6663 unknowns (Function args ret) = concatMap unknowns args ++ unknowns ret
@@ -85,16 +82,16 @@ instance Unifiable Row where
8582 unifyRows :: [(String, Type)] -> Row -> [(String, Type)] -> Row -> Subst ()
8683 unifyRows [] (RUnknown u) sd r = replace u (rowFromList (sd, r))
8784 unifyRows sd r [] (RUnknown u) = replace u (rowFromList (sd, r))
88− unifyRows ns@((name, ty):row) r others u@(RUnknown un) = do
85+ unifyRows ((name, ty):row) r others u@(RUnknown un) = do
8986 occursCheck un ty
90− forM row $ \(_, ty) -> occursCheck un ty
87+ forM row $ \(_, t) -> occursCheck un t
9188 u' <- fresh
9289 u ~~ RCons name ty u'
9390 unifyRows row r others u'
9491 unifyRows [] REmpty [] REmpty = return ()
9592 unifyRows [] (RowVar v1) [] (RowVar v2) | v1 == v2 = return ()
9693 unifyRows [] (RSkolem s1) [] (RSkolem s2) | s1 == s2 = return ()
97− unifyRows sd1 r1 sd2 r2 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd1, r1)) ++ " with " ++ prettyPrintRow (rowFromList (sd2, r2)) ++ "."
94+ unifyRows sd3 r3 sd4 r4 = throwError $ "Cannot unify " ++ prettyPrintRow (rowFromList (sd3, r3)) ++ " with " ++ prettyPrintRow (rowFromList (sd4, r4)) ++ "."
9895 apply s (RUnknown u) = runSubstitution s u
9996 apply s (RCons name ty r) = RCons name (apply s ty) (apply s r)
10097 apply _ r = r
@@ -136,11 +133,11 @@ unifyTypes t1 t2 = rethrow (\e -> "Error unifying type " ++ prettyPrintType t1 +
136133 unifyTypes' (TypeConstructor c1) (TypeConstructor c2) = do
137134 modulePath <- checkModulePath `fmap` get
138135 guardWith ("Cannot unify " ++ show c1 ++ " with " ++ show c2 ++ ".") (qualify modulePath c1 == qualify modulePath c2)
139− unifyTypes' (TypeApp t1 t2) (TypeApp t3 t4) = do
140− t1 `unifyTypes` t3
141− t2 `unifyTypes` t4
136+ unifyTypes' (TypeApp t3 t4) (TypeApp t5 t6) = do
137+ t3 `unifyTypes` t5
138+ t4 `unifyTypes` t6
142139 unifyTypes' (Skolem s1) (Skolem s2) | s1 == s2 = return ()
143− unifyTypes' t1 t2 = throwError $ "Cannot unify " ++ prettyPrintType t1 ++ " with " ++ prettyPrintType t2 ++ "."
140+ unifyTypes' t3 t4 = throwError $ "Cannot unify " ++ prettyPrintType t3 ++ " with " ++ prettyPrintType t4 ++ "."
144141
145142isFunction :: Value -> Bool
146143isFunction (Abs _ _) = True
@@ -152,12 +149,12 @@ typeOf name val = do
152149 (ty, sub, checks) <- runSubst $ case name of
153150 Just ident | isFunction val ->
154151 case val of
155− TypedValue val ty -> do
152+ TypedValue value ty -> do
156153 kind <- liftCheck $ kindOf ty
157154 guardWith ("Expected type of kind *, was " ++ prettyPrintKind kind) $ kind == Star
158155 ty' <- replaceAllTypeSynonyms ty
159156 modulePath <- checkModulePath <$> get
160− bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check val ty'
157+ bindNames (M.singleton (modulePath, ident) (ty, LocalVariable)) $ check value ty'
161158 return ty'
162159 _ -> do
163160 me <- fresh
@@ -175,7 +172,7 @@ escapeCheck checks ty sub =
175172 let
176173 visibleUnknowns = nub $ unknowns ty
177174 in
178− forM_ checks $ \check -> case check of
175+ forM_ checks $ \c -> case c of
179176 AnyUnifiable t -> do
180177 let unsolvedUnknowns = nub . unknowns $ apply sub t
181178 guardWith "Escape check fails" $ null $ unsolvedUnknowns \\ visibleUnknowns
@@ -214,18 +211,18 @@ replaceAllTypeVars :: (D.Data d) => [(String, Type)] -> d -> d
214211replaceAllTypeVars = foldl' (\f (name, ty) -> replaceTypeVars name ty . f) id
215212
216213replaceTypeVars :: (D.Data d) => String -> Type -> d -> d
217−replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replace)
214+replaceTypeVars name t = everywhereBut (mkQ False isShadowed) (mkT replaceTypeVar)
218215 where
219− replace (TypeVar v) | v == name = t
220− replace t = t
216+ replaceTypeVar (TypeVar v) | v == name = t
217+ replaceTypeVar other = other
221218 isShadowed (ForAll v _) | v == name = True
222219 isShadowed _ = False
223220
224221replaceRowVars :: (D.Data d) => String -> Row -> d -> d
225−replaceRowVars name r = everywhere (mkT replace)
222+replaceRowVars name r = everywhere (mkT replaceRowVar)
226223 where
227− replace (RowVar v) | v == name = r
228− replace t = t
224+ replaceRowVar (RowVar v) | v == name = r
225+ replaceRowVar other = other
229226
230227replaceAllVarsWithUnknowns :: Type -> Subst Type
231228replaceAllVarsWithUnknowns (ForAll ident ty) = replaceVarWithUnknown ident ty >>= replaceAllVarsWithUnknowns
@@ -244,14 +241,10 @@ replaceAllTypeSynonyms d = do
244241 either throwError return $ saturateAllTypeSynonyms syns d
245242
246243desaturateAllTypeSynonyms :: (D.Data d) => d -> d
247−desaturateAllTypeSynonyms = everywhere (mkT replace)
244+desaturateAllTypeSynonyms = everywhere (mkT replaceSaturatedTypeSynonym)
248245 where
249− replace (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
250− replace t = t
251−
252−expandAllTypeSynonyms :: Type -> Subst Type
253−expandAllTypeSynonyms (SaturatedTypeSynonym name args) = expandTypeSynonym name args >>= expandAllTypeSynonyms
254−expandAllTypeSynonyms ty = return ty
246+ replaceSaturatedTypeSynonym (SaturatedTypeSynonym name args) = foldl TypeApp (TypeConstructor name) args
247+ replaceSaturatedTypeSynonym t = t
255248
256249expandTypeSynonym :: Qualified ProperName -> [Type] -> Subst Type
257250expandTypeSynonym name args = do
@@ -276,9 +269,9 @@ infer' (StringLiteral _) = return String
276269infer' (BooleanLiteral _) = return Boolean
277270infer' (ArrayLiteral vals) = do
278271 ts <- mapM (infer) vals
279− arr <- fresh
280− forM_ ts $ \t -> arr ~~ Array t
281− return arr
272+ els <- fresh
273+ forM_ ts $ \t -> els ~~ Array t
274+ return els
282275infer' (Unary op val) = do
283276 t <- infer val
284277 inferUnary op t
@@ -324,7 +317,7 @@ infer' app@(App _ _) = do
324317 ret <- fresh
325318 checkFunctionApplications ft argss ret
326319 return ret
327−infer' (Var var@(Qualified mp name)) = do
320+infer' (Var var) = do
328321 ty <- lookupVariable var
329322 replaceAllTypeSynonyms ty
330323infer' (Block ss) = do
@@ -355,6 +348,7 @@ infer' (TypedValue val ty) = do
355348 ty' <- replaceAllTypeSynonyms ty
356349 check val ty'
357350 return ty'
351+infer' _ = error "Invalid argument to infer"
358352
359353inferProperty :: Type -> String -> Subst (Maybe Type)
360354inferProperty (Object row) prop = do
@@ -366,7 +360,7 @@ inferProperty (SaturatedTypeSynonym name args) prop = do
366360inferProperty (ForAll ident ty) prop = do
367361 replaced <- replaceVarWithUnknown ident ty
368362 inferProperty replaced prop
369−inferProperty _ prop = return Nothing
363+inferProperty _ _ = return Nothing
370364
371365inferUnary :: UnaryOperator -> Type -> Subst Type
372366inferUnary op val =
@@ -487,6 +481,7 @@ inferBinder val (ArrayBinder binders rest) = do
487481inferBinder val (NamedBinder name binder) = do
488482 m <- inferBinder val binder
489483 return $ M.insert name val m
484+inferBinder _ _ = error "Invalid argument to inferBinder"
490485
491486inferGuardedBinder :: Type -> Binder -> Subst (M.Map Ident Type)
492487inferGuardedBinder val (GuardedBinder cond binder) = do
@@ -511,11 +506,11 @@ assignVariable name = do
511506 _ -> return ()
512507
513508checkStatement :: M.Map Ident Type -> Type -> Statement -> Subst (Bool, M.Map Ident Type)
514−checkStatement mass ret (VariableIntroduction name val) = do
509+checkStatement mass _ (VariableIntroduction name val) = do
515510 assignVariable name
516511 t <- infer val
517512 return (False, M.insert name t mass)
518−checkStatement mass ret (Assignment ident val) = do
513+checkStatement mass _ (Assignment ident val) = do
519514 t <- infer val
520515 case M.lookup ident mass of
521516 Nothing -> throwError $ "No local variable with name " ++ show ident
@@ -567,7 +562,7 @@ checkBlock mass ret (s:ss) = do
567562 bindLocalVariables (M.toList mass1) $ case (b1, ss) of
568563 (True, []) -> return (True, mass1)
569564 (True, _) -> throwError "Unreachable code"
570− (False, ss) -> checkBlock mass1 ret ss
565+ (False, ss') -> checkBlock mass1 ret ss'
571566
572567skolemize :: String -> Type -> Subst Type
573568skolemize ident ty = do
@@ -609,7 +604,7 @@ check' app@(App _ _) ret = do
609604 let (f, argss) = unfoldApplication app
610605 ft <- infer f
611606 checkFunctionApplications ft argss ret
612−check' v@(Var var@(Qualified mp name)) ty = do
607+check' (Var var) ty = do
613608 ty1 <- lookupVariable var
614609 repl <- replaceAllTypeSynonyms ty1
615610 repl `subsumes` ty
@@ -663,21 +658,21 @@ checkProperties ps row lax = let (ts, r') = rowToList row in go ps ts r' where
663658 go [] ((p, _): _) _ | lax = return ()
664659 | otherwise = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have property " ++ p
665660 go ((p,_):_) [] REmpty = throwError $ "Property " ++ p ++ " is not present in closed object type " ++ prettyPrintRow row
666− go ((p,v):ps) [] u@(RUnknown _) = do
661+ go ((p,v):ps') [] u@(RUnknown _) = do
667662 ty <- infer v
668663 rest <- fresh
669664 u ~~ RCons p ty rest
670− go ps [] rest
671− go ((p,v):ps) ts r =
665+ go ps' [] rest
666+ go ((p,v):ps') ts r =
672667 case lookup p ts of
673668 Nothing -> do
674669 ty <- infer v
675670 rest <- fresh
676671 r ~~ RCons p ty rest
677− go ps ts rest
672+ go ps' ts rest
678673 Just ty -> do
679674 check v ty
680− go ps (delete (p, ty) ts) r
675+ go ps' (delete (p, ty) ts) r
681676 go _ _ _ = throwError $ prettyPrintValue (ObjectLiteral ps) ++ " does not have type " ++ prettyPrintType (Object row)
682677
683678unfoldApplication :: Value -> (Value, [[Value]])