Skip to content
GitLab
Commit b57ff272 authored by Austin Seipp's avatar Austin Seipp
Browse files

compiler: de-lhs typecheck/ 



Signed-off-by: default avatarAustin Seipp <austin@well-typed.com>
parent bafba119
Expand all Hide whitespace changes
Inline Side-by-side
compiler/typecheck/FamInst.lhs → compiler/typecheck/FamInst.hs
View file @ b57ff272
The @FamInst@ type: family instance heads
-- The @FamInst@ type: family instance heads
\begin{code}
{-# LANGUAGE CPP, GADTs #-}
module FamInst (
......@@ -37,15 +36,15 @@ import Data.Map (Map)
import qualified Data.Map as Map
#include "HsVersions.h"
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Making a FamInst
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- All type variables in a FamInst must be fresh. This function
-- creates the fresh variables and applies the necessary substitution
-- It is defined here to avoid a dependency from FamInstEnv on the monad
......@@ -67,14 +66,13 @@ newFamInst flavor axiom@(CoAxiom { co_ax_branches = FirstBranch branch
, fi_tys = substTys subst lhs
, fi_rhs = substTy subst rhs
, fi_axiom = axiom }) }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Optimised overlap checking for family instances
%* *
%************************************************************************
* *
************************************************************************
For any two family instance modules that we import directly or indirectly, we
check whether the instances in the two modules are consistent, *unless* we can
......@@ -96,8 +94,8 @@ modules where both modules occur in the `HscTypes.dep_finsts' set (of the
`HscTypes.Dependencies') of one of our directly imported modules must have
already been checked. Everything else, we check now. (So that we can be
certain that the modules in our `HscTypes.dep_finsts' are consistent.)
-}
\begin{code}
-- The optimisation of overlap tests is based on determining pairs of modules
-- whose family instances need to be checked for consistency.
--
......@@ -173,13 +171,13 @@ getFamInsts hpt_fam_insts mod
lookupModuleEnv (eps_mod_fam_inst_env eps) mod) }
where
doc = ppr mod <+> ptext (sLit "is a family-instance module")
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Lookup
%* *
%************************************************************************
* *
************************************************************************
Look up the instance tycon of a family instance.
......@@ -200,8 +198,8 @@ then we have a coercion (ie, type instance of family instance coercion)
:Co:R42T Int :: T [Int] ~ :R42T Int
which implies that :R42T was declared as 'data instance T [a]'.
-}
\begin{code}
tcLookupFamInst :: FamInstEnvs -> TyCon -> [Type] -> Maybe FamInstMatch
tcLookupFamInst fam_envs tycon tys
| not (isOpenFamilyTyCon tycon)
......@@ -256,16 +254,15 @@ tcInstNewTyConTF_maybe fam_envs ty
= Just (rep_tc, inner_ty, fam_co `mkTcTransCo` nt_co)
| otherwise
= Nothing
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Extending the family instance environment
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
-- Add new locally-defined family instances
tcExtendLocalFamInstEnv :: [FamInst] -> TcM a -> TcM a
tcExtendLocalFamInstEnv fam_insts thing_inside
......@@ -312,18 +309,18 @@ addLocalFamInst (home_fie, my_fis) fam_inst
return (home_fie'', fam_inst : my_fis')
else
return (home_fie, my_fis) }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Checking an instance against conflicts with an instance env
%* *
%************************************************************************
* *
************************************************************************
Check whether a single family instance conflicts with those in two instance
environments (one for the EPS and one for the HPT).
-}
\begin{code}
checkForConflicts :: FamInstEnvs -> FamInst -> TcM Bool
checkForConflicts inst_envs fam_inst
= do { let conflicts = lookupFamInstEnvConflicts inst_envs fam_inst
......@@ -366,5 +363,3 @@ tcGetFamInstEnvs :: TcM FamInstEnvs
tcGetFamInstEnvs
= do { eps <- getEps; env <- getGblEnv
; return (eps_fam_inst_env eps, tcg_fam_inst_env env) }
\end{code}
compiler/typecheck/FunDeps.lhs → compiler/typecheck/FunDeps.hs
View file @ b57ff272
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 2000
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 2000
FunDeps - functional dependencies
It's better to read it as: "if we know these, then we're going to know these"
-}
\begin{code}
{-# LANGUAGE CPP #-}
module FunDeps (
......@@ -36,14 +36,13 @@ import FastString
import Data.List ( nubBy )
import Data.Maybe ( isJust )
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
\subsection{Generate equations from functional dependencies}
%* *
%************************************************************************
* *
************************************************************************
Each functional dependency with one variable in the RHS is responsible
......@@ -94,8 +93,8 @@ This means that the template variable would be instantiated to different
unification variables when producing the FD constraints.
Finally, the position parameters will help us rewrite the wanted constraint ``on the spot''
-}
\begin{code}
data Equation loc
= FDEqn { fd_qtvs :: [TyVar] -- Instantiate these type and kind vars to fresh unification vars
, fd_eqs :: [FDEq] -- and then make these equal
......@@ -109,8 +108,8 @@ data FDEq = FDEq { fd_pos :: Int -- We use '0' for the first position
instance Outputable FDEq where
ppr (FDEq { fd_pos = p, fd_ty_left = tyl, fd_ty_right = tyr })
= parens (int p <> comma <+> ppr tyl <> comma <+> ppr tyr)
\end{code}
{-
Given a bunch of predicates that must hold, such as
C Int t1, C Int t2, C Bool t3, ?x::t4, ?x::t5
......@@ -137,10 +136,8 @@ NOTA BENE:
* The equations unify types that are not already equal. So there
is no effect iff the result of improve is empty
-}
\begin{code}
instFD :: FunDep TyVar -> [TyVar] -> [Type] -> FunDep Type
-- A simpler version of instFD_WithPos to be used in checking instance coverage etc.
instFD (ls,rs) tvs tys
......@@ -340,14 +337,13 @@ checkClsFD fd clas_tvs
(ltys1, rtys1) = instFD fd clas_tvs tys_inst
(ltys2, irs2) = instFD_WithPos fd clas_tvs tys_actual
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
The Coverage condition for instance declarations
%* *
%************************************************************************
* *
************************************************************************
Note [Coverage condition]
~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -376,8 +372,8 @@ But it is a mistake to accept the instance because then this defn:
f = \ b x y -> if b then x .*. [y] else y
makes instance inference go into a loop, because it requires the constraint
Mul a [b] b
-}
\begin{code}
checkInstCoverage :: Bool -- Be liberal
-> Class -> [PredType] -> [Type]
-> Validity
......@@ -420,8 +416,8 @@ checkInstCoverage be_liberal clas theta inst_taus
<+> pprQuotedList rs ]
, ppWhen (not be_liberal && liberal_ok) $
ptext (sLit "Using UndecidableInstances might help") ]
\end{code}
{-
Note [Closing over kinds in coverage]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we have a fundep (a::k) -> b
......@@ -453,10 +449,10 @@ assumption `t1 ~ t2`, then we use the fact that if we know `t1` we
also know `t2` and the other way.
eg oclose [C (x,y) z, a ~ x] {a,y} = {a,y,z,x}
oclose is used (only) when checking the coverage condition for
oclose is used (only) when checking the coverage condition for
an instance declaration
-}
\begin{code}
oclose :: [PredType] -> TyVarSet -> TyVarSet
-- See Note [The liberal coverage condition]
oclose preds fixed_tvs
......@@ -487,13 +483,13 @@ oclose preds fixed_tvs
EqPred t1 t2 -> [([t1],[t2]), ([t2],[t1])]
TuplePred ts -> concatMap determined ts
_ -> []
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Check that a new instance decl is OK wrt fundeps
%* *
%************************************************************************
* *
************************************************************************
Here is the bad case:
class C a b | a->b where ...
......@@ -519,9 +515,8 @@ The instance decls don't overlap, because the third parameter keeps
them separate. But we want to make sure that given any constraint
D s1 s2 s3
if s1 matches
-}
\begin{code}
checkFunDeps :: InstEnvs -> ClsInst
-> Maybe [ClsInst] -- Nothing <=> ok
-- Just dfs <=> conflict with dfs
......@@ -569,7 +564,3 @@ trimRoughMatchTcs clas_tvs (ltvs, _) mb_tcs
where
select clas_tv mb_tc | clas_tv `elem` ltvs = mb_tc
| otherwise = Nothing
\end{code}
compiler/typecheck/Inst.lhs → compiler/typecheck/Inst.hs
View file @ b57ff272
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
The @Inst@ type: dictionaries or method instances
-}
\begin{code}
{-# LANGUAGE CPP #-}
module Inst (
......@@ -58,17 +58,15 @@ import Util
import Outputable
import Control.Monad( unless )
import Data.Maybe( isJust )
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Emitting constraints
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
emitWanteds :: CtOrigin -> TcThetaType -> TcM [EvVar]
emitWanteds origin theta = mapM (emitWanted origin) theta
......@@ -101,14 +99,13 @@ newMethodFromName origin name inst_ty
; wrap <- ASSERT( null rest && isSingleton theta )
instCall origin [inst_ty] (substTheta subst theta)
; return (mkHsWrap wrap (HsVar id)) }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Deep instantiation and skolemisation
%* *
%************************************************************************
* *
************************************************************************
Note [Deep skolemisation]
~~~~~~~~~~~~~~~~~~~~~~~~~
......@@ -134,9 +131,8 @@ In general,
ToDo: this eta-abstraction plays fast and loose with termination,
because it can introduce extra lambdas. Maybe add a `seq` to
fix this
-}
\begin{code}
deeplySkolemise
:: TcSigmaType
-> TcM (HsWrapper, [TyVar], [EvVar], TcRhoType)
......@@ -185,16 +181,15 @@ deeplyInstantiate orig ty
mkFunTys arg_tys rho2) }
| otherwise = return (idHsWrapper, ty)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Instantiating a call
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
----------------
instCall :: CtOrigin -> [TcType] -> TcThetaType -> TcM HsWrapper
-- Instantiate the constraints of a call
......@@ -235,20 +230,20 @@ instStupidTheta :: CtOrigin -> TcThetaType -> TcM ()
instStupidTheta orig theta
= do { _co <- instCallConstraints orig theta -- Discard the coercion
; return () }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Literals
%* *
%************************************************************************
* *
************************************************************************
In newOverloadedLit we convert directly to an Int or Integer if we
know that's what we want. This may save some time, by not
temporarily generating overloaded literals, but it won't catch all
cases (the rest are caught in lookupInst).
-}
\begin{code}
newOverloadedLit :: CtOrigin
-> HsOverLit Name
-> TcRhoType
......@@ -298,18 +293,15 @@ mkOverLit (HsFractional r)
; return (HsRat r rat_ty) }
mkOverLit (HsIsString src s) = return (HsString src s)
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Re-mappable syntax
Used only for arrow syntax -- find a way to nuke this
%* *
%************************************************************************
* *
************************************************************************
Suppose we are doing the -XRebindableSyntax thing, and we encounter
a do-expression. We have to find (>>) in the current environment, which is
......@@ -332,8 +324,8 @@ the expected type.
In fact tcSyntaxName just generates the RHS for then72, because we only
want an actual binding in the do-expression case. For literals, we can
just use the expression inline.
-}
\begin{code}
tcSyntaxName :: CtOrigin
-> TcType -- Type to instantiate it at
-> (Name, HsExpr Name) -- (Standard name, user name)
......@@ -374,16 +366,15 @@ syntaxNameCtxt name orig ty tidy_env
<+> ppr (tidyType tidy_env ty))
, nest 2 (pprArisingAt inst_loc) ]
; return (tidy_env, msg) }
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Instances
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
getOverlapFlag :: Maybe OverlapMode -> TcM OverlapFlag
getOverlapFlag overlap_mode
= do { dflags <- getDynFlags
......@@ -492,8 +483,8 @@ addLocalInst (home_ie, my_insts) ispec
dupInstErr ispec (head dups)
; return (extendInstEnv home_ie' ispec, ispec:my_insts') }
\end{code}
{-
Note [Signature files and type class instances]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Instances in signature files do not have an effect when compiling:
......@@ -539,13 +530,13 @@ See also Note [Signature lazy interface loading]. We can't
rely on this, however, since sometimes we'll have spurious
type class instances in the EPS, see #9422 (sigof02dm)
%************************************************************************
%* *
************************************************************************
* *
Errors and tracing
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
traceDFuns :: [ClsInst] -> TcRn ()
traceDFuns ispecs
= traceTc "Adding instances:" (vcat (map pp ispecs))
......@@ -573,15 +564,15 @@ addClsInstsErr herald ispecs
-- The sortWith just arranges that instances are dislayed in order
-- of source location, which reduced wobbling in error messages,
-- and is better for users
\end{code}
%************************************************************************
%* *
{-
************************************************************************
* *
Simple functions over evidence variables
%* *
%************************************************************************
* *
************************************************************************
-}
\begin{code}
---------------- Getting free tyvars -------------------------
tyVarsOfCt :: Ct -> TcTyVarSet
tyVarsOfCt (CTyEqCan { cc_tyvar = tv, cc_rhs = xi }) = extendVarSet (tyVarsOfType xi) tv
......@@ -610,4 +601,3 @@ tyVarsOfImplic (Implic { ic_skols = skols
tyVarsOfBag :: (a -> TyVarSet) -> Bag a -> TyVarSet
tyVarsOfBag tvs_of = foldrBag (unionVarSet . tvs_of) emptyVarSet
\end{code}
compiler/typecheck/TcAnnotations.lhs → compiler/typecheck/TcAnnotations.hs
View file @ b57ff272
%
% (c) The University of Glasgow 2006
% (c) The AQUA Project, Glasgow University, 1993-1998
%
{-
(c) The University of Glasgow 2006
(c) The AQUA Project, Glasgow University, 1993-1998
\section[TcAnnotations]{Typechecking annotations}
-}
\begin{code}
{-# LANGUAGE CPP #-}
module TcAnnotations ( tcAnnotations, annCtxt ) where
......@@ -22,9 +22,6 @@ import SrcLoc
import Outputable
import FastString
\end{code}
\begin{code}
#ifndef GHCI
......@@ -61,4 +58,3 @@ annProvenanceToTarget mod ModuleAnnProvenance = ModuleTarget mod
annCtxt :: OutputableBndr id => AnnDecl id -> SDoc
annCtxt ann
= hang (ptext (sLit "In the annotation:")) 2 (ppr ann)
\end{code}
\ No newline at end of file
compiler/typecheck/TcArrows.lhs → compiler/typecheck/TcArrows.hs
View file @ b57ff272
%
% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
{-
(c) The University of Glasgow 2006
(c) The GRASP/AQUA Project, Glasgow University, 1992-1998
Typecheck arrow notation
-}
\begin{code}
{-# LANGUAGE RankNTypes #-}
module TcArrows ( tcProc ) where
......@@ -27,7 +27,7 @@ import Inst
import Name
import Coercion ( Role(..) )
import TysWiredIn
import VarSet
import VarSet
import TysPrim
import BasicTypes( Arity )
import SrcLoc
......@@ -36,14 +36,14 @@ import FastString
import Util
import Control.Monad
\end{code}
{-
Note [Arrow overivew]
~~~~~~~~~~~~~~~~~~~~~
Here's a summary of arrows and how they typecheck. First, here's
a cut-down syntax:
expr ::= ....
expr ::= ....
| proc pat cmd
cmd ::= cmd exp -- Arrow application
......@@ -57,7 +57,7 @@ a cut-down syntax:
| (type, carg_type)
Note that
* The 'exp' in an arrow form can mention only
* The 'exp' in an arrow form can mention only
"arrow-local" variables
* An "arrow-local" variable is bound by an enclosing
......@@ -71,38 +71,37 @@ Note that
(| e1 <<< arr snd |) e2
%************************************************************************
%* *
Proc
%* *
%************************************************************************
************************************************************************
* *
Proc
* *
************************************************************************
-}
\begin{code}
tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr
-> TcRhoType -- Expected type of whole proc expression
-> TcM (OutPat TcId, LHsCmdTop TcId, TcCoercion)
tcProc pat cmd exp_ty
= newArrowScope $
do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
do { (co, (exp_ty1, res_ty)) <- matchExpectedAppTy exp_ty
; (co1, (arr_ty, arg_ty)) <- matchExpectedAppTy exp_ty1
; let cmd_env = CmdEnv { cmd_arr = arr_ty }
; (pat', cmd') <- tcPat ProcExpr pat arg_ty $
tcCmdTop cmd_env cmd (unitTy, res_ty)
; let res_co = mkTcTransCo co (mkTcAppCo co1 (mkTcNomReflCo res_ty))
; return (pat', cmd', res_co) }
\end{code}
%************************************************************************
%* *